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 #include <limits.h> /* For CHAR_BIT. */
32 /* This file is part of the core Lisp implementation, and thus must
33 deal with the real data structures. If the Lisp implementation is
34 replaced, this file likely will not be used. */
36 #undef HIDE_LISP_IMPLEMENTATION
39 #include "intervals.h"
45 #include "blockinput.h"
46 #include "character.h"
47 #include "syssignal.h"
48 #include "termhooks.h" /* For struct terminal. */
52 /* GC_CHECK_MARKED_OBJECTS means do sanity checks on allocated objects.
53 Doable only if GC_MARK_STACK. */
55 # undef GC_CHECK_MARKED_OBJECTS
58 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
59 memory. Can do this only if using gmalloc.c and if not checking
62 #if (defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC \
63 || defined GC_CHECK_MARKED_OBJECTS)
64 #undef GC_MALLOC_CHECK
78 #ifdef DOUG_LEA_MALLOC
82 /* Specify maximum number of areas to mmap. It would be nice to use a
83 value that explicitly means "no limit". */
85 #define MMAP_MAX_AREAS 100000000
87 #else /* not DOUG_LEA_MALLOC */
89 /* The following come from gmalloc.c. */
91 extern size_t _bytes_used
;
92 extern size_t __malloc_extra_blocks
;
93 extern void *_malloc_internal (size_t);
94 extern void _free_internal (void *);
96 #endif /* not DOUG_LEA_MALLOC */
98 #if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
101 /* When GTK uses the file chooser dialog, different backends can be loaded
102 dynamically. One such a backend is the Gnome VFS backend that gets loaded
103 if you run Gnome. That backend creates several threads and also allocates
106 Also, gconf and gsettings may create several threads.
108 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
109 functions below are called from malloc, there is a chance that one
110 of these threads preempts the Emacs main thread and the hook variables
111 end up in an inconsistent state. So we have a mutex to prevent that (note
112 that the backend handles concurrent access to malloc within its own threads
113 but Emacs code running in the main thread is not included in that control).
115 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
116 happens in one of the backend threads we will have two threads that tries
117 to run Emacs code at once, and the code is not prepared for that.
118 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
120 static pthread_mutex_t alloc_mutex
;
122 #define BLOCK_INPUT_ALLOC \
125 if (pthread_equal (pthread_self (), main_thread)) \
127 pthread_mutex_lock (&alloc_mutex); \
130 #define UNBLOCK_INPUT_ALLOC \
133 pthread_mutex_unlock (&alloc_mutex); \
134 if (pthread_equal (pthread_self (), main_thread)) \
139 #else /* ! defined HAVE_PTHREAD */
141 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
142 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
144 #endif /* ! defined HAVE_PTHREAD */
145 #endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
147 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
148 to a struct Lisp_String. */
150 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
151 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
152 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
154 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
155 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
156 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
158 /* Value is the number of bytes of S, a pointer to a struct Lisp_String.
159 Be careful during GC, because S->size contains the mark bit for
162 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
164 /* Global variables. */
165 struct emacs_globals globals
;
167 /* Number of bytes of consing done since the last gc. */
169 EMACS_INT consing_since_gc
;
171 /* Similar minimum, computed from Vgc_cons_percentage. */
173 EMACS_INT gc_relative_threshold
;
175 /* Minimum number of bytes of consing since GC before next GC,
176 when memory is full. */
178 EMACS_INT memory_full_cons_threshold
;
180 /* Nonzero during GC. */
184 /* Nonzero means abort if try to GC.
185 This is for code which is written on the assumption that
186 no GC will happen, so as to verify that assumption. */
190 /* Number of live and free conses etc. */
192 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_vector_size
;
193 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
194 static EMACS_INT total_free_floats
, total_floats
;
196 /* Points to memory space allocated as "spare", to be freed if we run
197 out of memory. We keep one large block, four cons-blocks, and
198 two string blocks. */
200 static char *spare_memory
[7];
202 /* Amount of spare memory to keep in large reserve block, or to see
203 whether this much is available when malloc fails on a larger request. */
205 #define SPARE_MEMORY (1 << 14)
207 /* Number of extra blocks malloc should get when it needs more core. */
209 static int malloc_hysteresis
;
211 /* Initialize it to a nonzero value to force it into data space
212 (rather than bss space). That way unexec will remap it into text
213 space (pure), on some systems. We have not implemented the
214 remapping on more recent systems because this is less important
215 nowadays than in the days of small memories and timesharing. */
217 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
218 #define PUREBEG (char *) pure
220 /* Pointer to the pure area, and its size. */
222 static char *purebeg
;
223 static ptrdiff_t pure_size
;
225 /* Number of bytes of pure storage used before pure storage overflowed.
226 If this is non-zero, this implies that an overflow occurred. */
228 static ptrdiff_t pure_bytes_used_before_overflow
;
230 /* Value is non-zero if P points into pure space. */
232 #define PURE_POINTER_P(P) \
233 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
235 /* Index in pure at which next pure Lisp object will be allocated.. */
237 static ptrdiff_t pure_bytes_used_lisp
;
239 /* Number of bytes allocated for non-Lisp objects in pure storage. */
241 static ptrdiff_t pure_bytes_used_non_lisp
;
243 /* If nonzero, this is a warning delivered by malloc and not yet
246 const char *pending_malloc_warning
;
248 /* Maximum amount of C stack to save when a GC happens. */
250 #ifndef MAX_SAVE_STACK
251 #define MAX_SAVE_STACK 16000
254 /* Buffer in which we save a copy of the C stack at each GC. */
256 #if MAX_SAVE_STACK > 0
257 static char *stack_copy
;
258 static ptrdiff_t stack_copy_size
;
261 /* Non-zero means ignore malloc warnings. Set during initialization.
262 Currently not used. */
264 static int ignore_warnings
;
266 static Lisp_Object Qgc_cons_threshold
;
267 Lisp_Object Qchar_table_extra_slots
;
269 /* Hook run after GC has finished. */
271 static Lisp_Object Qpost_gc_hook
;
273 static void mark_buffer (Lisp_Object
);
274 static void mark_terminals (void);
275 static void gc_sweep (void);
276 static Lisp_Object
make_pure_vector (ptrdiff_t);
277 static void mark_glyph_matrix (struct glyph_matrix
*);
278 static void mark_face_cache (struct face_cache
*);
280 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
281 static void refill_memory_reserve (void);
283 static struct Lisp_String
*allocate_string (void);
284 static void compact_small_strings (void);
285 static void free_large_strings (void);
286 static void sweep_strings (void);
287 static void free_misc (Lisp_Object
);
288 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
290 /* When scanning the C stack for live Lisp objects, Emacs keeps track
291 of what memory allocated via lisp_malloc is intended for what
292 purpose. This enumeration specifies the type of memory. */
303 /* We used to keep separate mem_types for subtypes of vectors such as
304 process, hash_table, frame, terminal, and window, but we never made
305 use of the distinction, so it only caused source-code complexity
306 and runtime slowdown. Minor but pointless. */
310 static void *lisp_malloc (size_t, enum mem_type
);
313 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
315 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
316 #include <stdio.h> /* For fprintf. */
319 /* A unique object in pure space used to make some Lisp objects
320 on free lists recognizable in O(1). */
322 static Lisp_Object Vdead
;
323 #define DEADP(x) EQ (x, Vdead)
325 #ifdef GC_MALLOC_CHECK
327 enum mem_type allocated_mem_type
;
329 #endif /* GC_MALLOC_CHECK */
331 /* A node in the red-black tree describing allocated memory containing
332 Lisp data. Each such block is recorded with its start and end
333 address when it is allocated, and removed from the tree when it
336 A red-black tree is a balanced binary tree with the following
339 1. Every node is either red or black.
340 2. Every leaf is black.
341 3. If a node is red, then both of its children are black.
342 4. Every simple path from a node to a descendant leaf contains
343 the same number of black nodes.
344 5. The root is always black.
346 When nodes are inserted into the tree, or deleted from the tree,
347 the tree is "fixed" so that these properties are always true.
349 A red-black tree with N internal nodes has height at most 2
350 log(N+1). Searches, insertions and deletions are done in O(log N).
351 Please see a text book about data structures for a detailed
352 description of red-black trees. Any book worth its salt should
357 /* Children of this node. These pointers are never NULL. When there
358 is no child, the value is MEM_NIL, which points to a dummy node. */
359 struct mem_node
*left
, *right
;
361 /* The parent of this node. In the root node, this is NULL. */
362 struct mem_node
*parent
;
364 /* Start and end of allocated region. */
368 enum {MEM_BLACK
, MEM_RED
} color
;
374 /* Base address of stack. Set in main. */
376 Lisp_Object
*stack_base
;
378 /* Root of the tree describing allocated Lisp memory. */
380 static struct mem_node
*mem_root
;
382 /* Lowest and highest known address in the heap. */
384 static void *min_heap_address
, *max_heap_address
;
386 /* Sentinel node of the tree. */
388 static struct mem_node mem_z
;
389 #define MEM_NIL &mem_z
391 static struct Lisp_Vector
*allocate_vectorlike (ptrdiff_t);
392 static void lisp_free (void *);
393 static void mark_stack (void);
394 static int live_vector_p (struct mem_node
*, void *);
395 static int live_buffer_p (struct mem_node
*, void *);
396 static int live_string_p (struct mem_node
*, void *);
397 static int live_cons_p (struct mem_node
*, void *);
398 static int live_symbol_p (struct mem_node
*, void *);
399 static int live_float_p (struct mem_node
*, void *);
400 static int live_misc_p (struct mem_node
*, void *);
401 static void mark_maybe_object (Lisp_Object
);
402 static void mark_memory (void *, void *);
403 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
404 static void mem_init (void);
405 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
406 static void mem_insert_fixup (struct mem_node
*);
408 static void mem_rotate_left (struct mem_node
*);
409 static void mem_rotate_right (struct mem_node
*);
410 static void mem_delete (struct mem_node
*);
411 static void mem_delete_fixup (struct mem_node
*);
412 static inline struct mem_node
*mem_find (void *);
415 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
416 static void check_gcpros (void);
419 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
425 /* Recording what needs to be marked for gc. */
427 struct gcpro
*gcprolist
;
429 /* Addresses of staticpro'd variables. Initialize it to a nonzero
430 value; otherwise some compilers put it into BSS. */
432 #define NSTATICS 0x640
433 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
435 /* Index of next unused slot in staticvec. */
437 static int staticidx
= 0;
439 static void *pure_alloc (size_t, int);
442 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
443 ALIGNMENT must be a power of 2. */
445 #define ALIGN(ptr, ALIGNMENT) \
446 ((void *) (((uintptr_t) (ptr) + (ALIGNMENT) - 1) \
447 & ~ ((ALIGNMENT) - 1)))
451 /************************************************************************
453 ************************************************************************/
455 /* Function malloc calls this if it finds we are near exhausting storage. */
458 malloc_warning (const char *str
)
460 pending_malloc_warning
= str
;
464 /* Display an already-pending malloc warning. */
467 display_malloc_warning (void)
469 call3 (intern ("display-warning"),
471 build_string (pending_malloc_warning
),
472 intern ("emergency"));
473 pending_malloc_warning
= 0;
476 /* Called if we can't allocate relocatable space for a buffer. */
479 buffer_memory_full (ptrdiff_t nbytes
)
481 /* If buffers use the relocating allocator, no need to free
482 spare_memory, because we may have plenty of malloc space left
483 that we could get, and if we don't, the malloc that fails will
484 itself cause spare_memory to be freed. If buffers don't use the
485 relocating allocator, treat this like any other failing
489 memory_full (nbytes
);
492 /* This used to call error, but if we've run out of memory, we could
493 get infinite recursion trying to build the string. */
494 xsignal (Qnil
, Vmemory_signal_data
);
498 #ifndef XMALLOC_OVERRUN_CHECK
499 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
502 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
505 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
506 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
507 block size in little-endian order. The trailer consists of
508 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
510 The header is used to detect whether this block has been allocated
511 through these functions, as some low-level libc functions may
512 bypass the malloc hooks. */
514 #define XMALLOC_OVERRUN_CHECK_SIZE 16
515 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
516 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
518 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
519 hold a size_t value and (2) the header size is a multiple of the
520 alignment that Emacs needs for C types and for USE_LSB_TAG. */
521 #define XMALLOC_BASE_ALIGNMENT \
524 union { long double d; intmax_t i; void *p; } u; \
529 /* A common multiple of the positive integers A and B. Ideally this
530 would be the least common multiple, but there's no way to do that
531 as a constant expression in C, so do the best that we can easily do. */
532 # define COMMON_MULTIPLE(a, b) \
533 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
534 # define XMALLOC_HEADER_ALIGNMENT \
535 COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
537 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
539 #define XMALLOC_OVERRUN_SIZE_SIZE \
540 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
541 + XMALLOC_HEADER_ALIGNMENT - 1) \
542 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
543 - XMALLOC_OVERRUN_CHECK_SIZE)
545 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
546 { '\x9a', '\x9b', '\xae', '\xaf',
547 '\xbf', '\xbe', '\xce', '\xcf',
548 '\xea', '\xeb', '\xec', '\xed',
549 '\xdf', '\xde', '\x9c', '\x9d' };
551 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
552 { '\xaa', '\xab', '\xac', '\xad',
553 '\xba', '\xbb', '\xbc', '\xbd',
554 '\xca', '\xcb', '\xcc', '\xcd',
555 '\xda', '\xdb', '\xdc', '\xdd' };
557 /* Insert and extract the block size in the header. */
560 xmalloc_put_size (unsigned char *ptr
, size_t size
)
563 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
565 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
571 xmalloc_get_size (unsigned char *ptr
)
575 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
576 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
585 /* The call depth in overrun_check functions. For example, this might happen:
587 overrun_check_malloc()
588 -> malloc -> (via hook)_-> emacs_blocked_malloc
589 -> overrun_check_malloc
590 call malloc (hooks are NULL, so real malloc is called).
591 malloc returns 10000.
592 add overhead, return 10016.
593 <- (back in overrun_check_malloc)
594 add overhead again, return 10032
595 xmalloc returns 10032.
600 overrun_check_free(10032)
602 free(10016) <- crash, because 10000 is the original pointer. */
604 static ptrdiff_t check_depth
;
606 /* Like malloc, but wraps allocated block with header and trailer. */
609 overrun_check_malloc (size_t size
)
611 register unsigned char *val
;
612 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
613 if (SIZE_MAX
- overhead
< size
)
616 val
= (unsigned char *) malloc (size
+ overhead
);
617 if (val
&& check_depth
== 1)
619 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
620 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
621 xmalloc_put_size (val
, size
);
622 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
623 XMALLOC_OVERRUN_CHECK_SIZE
);
630 /* Like realloc, but checks old block for overrun, and wraps new block
631 with header and trailer. */
634 overrun_check_realloc (void *block
, size_t size
)
636 register unsigned char *val
= (unsigned char *) block
;
637 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
638 if (SIZE_MAX
- overhead
< size
)
643 && memcmp (xmalloc_overrun_check_header
,
644 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
645 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
647 size_t osize
= xmalloc_get_size (val
);
648 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
649 XMALLOC_OVERRUN_CHECK_SIZE
))
651 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
652 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
653 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
656 val
= realloc (val
, size
+ overhead
);
658 if (val
&& check_depth
== 1)
660 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
661 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
662 xmalloc_put_size (val
, size
);
663 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
664 XMALLOC_OVERRUN_CHECK_SIZE
);
670 /* Like free, but checks block for overrun. */
673 overrun_check_free (void *block
)
675 unsigned char *val
= (unsigned char *) block
;
680 && memcmp (xmalloc_overrun_check_header
,
681 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
682 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
684 size_t osize
= xmalloc_get_size (val
);
685 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
686 XMALLOC_OVERRUN_CHECK_SIZE
))
688 #ifdef XMALLOC_CLEAR_FREE_MEMORY
689 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
690 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
692 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
693 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
694 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
705 #define malloc overrun_check_malloc
706 #define realloc overrun_check_realloc
707 #define free overrun_check_free
711 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
712 there's no need to block input around malloc. */
713 #define MALLOC_BLOCK_INPUT ((void)0)
714 #define MALLOC_UNBLOCK_INPUT ((void)0)
716 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
717 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
720 /* Like malloc but check for no memory and block interrupt input.. */
723 xmalloc (size_t size
)
729 MALLOC_UNBLOCK_INPUT
;
737 /* Like realloc but check for no memory and block interrupt input.. */
740 xrealloc (void *block
, size_t size
)
745 /* We must call malloc explicitly when BLOCK is 0, since some
746 reallocs don't do this. */
750 val
= realloc (block
, size
);
751 MALLOC_UNBLOCK_INPUT
;
759 /* Like free but block interrupt input. */
768 MALLOC_UNBLOCK_INPUT
;
769 /* We don't call refill_memory_reserve here
770 because that duplicates doing so in emacs_blocked_free
771 and the criterion should go there. */
775 /* Other parts of Emacs pass large int values to allocator functions
776 expecting ptrdiff_t. This is portable in practice, but check it to
778 verify (INT_MAX
<= PTRDIFF_MAX
);
781 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
782 Signal an error on memory exhaustion, and block interrupt input. */
785 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
787 xassert (0 <= nitems
&& 0 < item_size
);
788 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
789 memory_full (SIZE_MAX
);
790 return xmalloc (nitems
* item_size
);
794 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
795 Signal an error on memory exhaustion, and block interrupt input. */
798 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
800 xassert (0 <= nitems
&& 0 < item_size
);
801 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
802 memory_full (SIZE_MAX
);
803 return xrealloc (pa
, nitems
* item_size
);
807 /* Grow PA, which points to an array of *NITEMS items, and return the
808 location of the reallocated array, updating *NITEMS to reflect its
809 new size. The new array will contain at least NITEMS_INCR_MIN more
810 items, but will not contain more than NITEMS_MAX items total.
811 ITEM_SIZE is the size of each item, in bytes.
813 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
814 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
817 If PA is null, then allocate a new array instead of reallocating
818 the old one. Thus, to grow an array A without saving its old
819 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
822 Block interrupt input as needed. If memory exhaustion occurs, set
823 *NITEMS to zero if PA is null, and signal an error (i.e., do not
827 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
828 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
830 /* The approximate size to use for initial small allocation
831 requests. This is the largest "small" request for the GNU C
833 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
835 /* If the array is tiny, grow it to about (but no greater than)
836 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
837 ptrdiff_t n
= *nitems
;
838 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
839 ptrdiff_t half_again
= n
>> 1;
840 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
842 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
843 NITEMS_MAX, and what the C language can represent safely. */
844 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
845 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
846 ? nitems_max
: C_language_max
);
847 ptrdiff_t nitems_incr_max
= n_max
- n
;
848 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
850 xassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
853 if (nitems_incr_max
< incr
)
854 memory_full (SIZE_MAX
);
856 pa
= xrealloc (pa
, n
* item_size
);
862 /* Like strdup, but uses xmalloc. */
865 xstrdup (const char *s
)
867 size_t len
= strlen (s
) + 1;
868 char *p
= (char *) xmalloc (len
);
874 /* Unwind for SAFE_ALLOCA */
877 safe_alloca_unwind (Lisp_Object arg
)
879 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
889 /* Like malloc but used for allocating Lisp data. NBYTES is the
890 number of bytes to allocate, TYPE describes the intended use of the
891 allocated memory block (for strings, for conses, ...). */
894 static void *lisp_malloc_loser
;
898 lisp_malloc (size_t nbytes
, enum mem_type type
)
904 #ifdef GC_MALLOC_CHECK
905 allocated_mem_type
= type
;
908 val
= (void *) malloc (nbytes
);
911 /* If the memory just allocated cannot be addressed thru a Lisp
912 object's pointer, and it needs to be,
913 that's equivalent to running out of memory. */
914 if (val
&& type
!= MEM_TYPE_NON_LISP
)
917 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
918 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
920 lisp_malloc_loser
= val
;
927 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
928 if (val
&& type
!= MEM_TYPE_NON_LISP
)
929 mem_insert (val
, (char *) val
+ nbytes
, type
);
932 MALLOC_UNBLOCK_INPUT
;
934 memory_full (nbytes
);
938 /* Free BLOCK. This must be called to free memory allocated with a
939 call to lisp_malloc. */
942 lisp_free (void *block
)
946 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
947 mem_delete (mem_find (block
));
949 MALLOC_UNBLOCK_INPUT
;
952 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
954 /* The entry point is lisp_align_malloc which returns blocks of at most
955 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
957 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
958 #define USE_POSIX_MEMALIGN 1
961 /* BLOCK_ALIGN has to be a power of 2. */
962 #define BLOCK_ALIGN (1 << 10)
964 /* Padding to leave at the end of a malloc'd block. This is to give
965 malloc a chance to minimize the amount of memory wasted to alignment.
966 It should be tuned to the particular malloc library used.
967 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
968 posix_memalign on the other hand would ideally prefer a value of 4
969 because otherwise, there's 1020 bytes wasted between each ablocks.
970 In Emacs, testing shows that those 1020 can most of the time be
971 efficiently used by malloc to place other objects, so a value of 0 can
972 still preferable unless you have a lot of aligned blocks and virtually
974 #define BLOCK_PADDING 0
975 #define BLOCK_BYTES \
976 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
978 /* Internal data structures and constants. */
980 #define ABLOCKS_SIZE 16
982 /* An aligned block of memory. */
987 char payload
[BLOCK_BYTES
];
988 struct ablock
*next_free
;
990 /* `abase' is the aligned base of the ablocks. */
991 /* It is overloaded to hold the virtual `busy' field that counts
992 the number of used ablock in the parent ablocks.
993 The first ablock has the `busy' field, the others have the `abase'
994 field. To tell the difference, we assume that pointers will have
995 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
996 is used to tell whether the real base of the parent ablocks is `abase'
997 (if not, the word before the first ablock holds a pointer to the
999 struct ablocks
*abase
;
1000 /* The padding of all but the last ablock is unused. The padding of
1001 the last ablock in an ablocks is not allocated. */
1003 char padding
[BLOCK_PADDING
];
1007 /* A bunch of consecutive aligned blocks. */
1010 struct ablock blocks
[ABLOCKS_SIZE
];
1013 /* Size of the block requested from malloc or posix_memalign. */
1014 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1016 #define ABLOCK_ABASE(block) \
1017 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1018 ? (struct ablocks *)(block) \
1021 /* Virtual `busy' field. */
1022 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1024 /* Pointer to the (not necessarily aligned) malloc block. */
1025 #ifdef USE_POSIX_MEMALIGN
1026 #define ABLOCKS_BASE(abase) (abase)
1028 #define ABLOCKS_BASE(abase) \
1029 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
1032 /* The list of free ablock. */
1033 static struct ablock
*free_ablock
;
1035 /* Allocate an aligned block of nbytes.
1036 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1037 smaller or equal to BLOCK_BYTES. */
1039 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1042 struct ablocks
*abase
;
1044 eassert (nbytes
<= BLOCK_BYTES
);
1048 #ifdef GC_MALLOC_CHECK
1049 allocated_mem_type
= type
;
1055 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1057 #ifdef DOUG_LEA_MALLOC
1058 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1059 because mapped region contents are not preserved in
1061 mallopt (M_MMAP_MAX
, 0);
1064 #ifdef USE_POSIX_MEMALIGN
1066 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1072 base
= malloc (ABLOCKS_BYTES
);
1073 abase
= ALIGN (base
, BLOCK_ALIGN
);
1078 MALLOC_UNBLOCK_INPUT
;
1079 memory_full (ABLOCKS_BYTES
);
1082 aligned
= (base
== abase
);
1084 ((void**)abase
)[-1] = base
;
1086 #ifdef DOUG_LEA_MALLOC
1087 /* Back to a reasonable maximum of mmap'ed areas. */
1088 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1092 /* If the memory just allocated cannot be addressed thru a Lisp
1093 object's pointer, and it needs to be, that's equivalent to
1094 running out of memory. */
1095 if (type
!= MEM_TYPE_NON_LISP
)
1098 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1099 XSETCONS (tem
, end
);
1100 if ((char *) XCONS (tem
) != end
)
1102 lisp_malloc_loser
= base
;
1104 MALLOC_UNBLOCK_INPUT
;
1105 memory_full (SIZE_MAX
);
1110 /* Initialize the blocks and put them on the free list.
1111 If `base' was not properly aligned, we can't use the last block. */
1112 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1114 abase
->blocks
[i
].abase
= abase
;
1115 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1116 free_ablock
= &abase
->blocks
[i
];
1118 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1120 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1121 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1122 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1123 eassert (ABLOCKS_BASE (abase
) == base
);
1124 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1127 abase
= ABLOCK_ABASE (free_ablock
);
1128 ABLOCKS_BUSY (abase
) =
1129 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1131 free_ablock
= free_ablock
->x
.next_free
;
1133 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1134 if (type
!= MEM_TYPE_NON_LISP
)
1135 mem_insert (val
, (char *) val
+ nbytes
, type
);
1138 MALLOC_UNBLOCK_INPUT
;
1140 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1145 lisp_align_free (void *block
)
1147 struct ablock
*ablock
= block
;
1148 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1151 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1152 mem_delete (mem_find (block
));
1154 /* Put on free list. */
1155 ablock
->x
.next_free
= free_ablock
;
1156 free_ablock
= ablock
;
1157 /* Update busy count. */
1158 ABLOCKS_BUSY (abase
)
1159 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1161 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1162 { /* All the blocks are free. */
1163 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1164 struct ablock
**tem
= &free_ablock
;
1165 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1169 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1172 *tem
= (*tem
)->x
.next_free
;
1175 tem
= &(*tem
)->x
.next_free
;
1177 eassert ((aligned
& 1) == aligned
);
1178 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1179 #ifdef USE_POSIX_MEMALIGN
1180 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1182 free (ABLOCKS_BASE (abase
));
1184 MALLOC_UNBLOCK_INPUT
;
1187 /* Return a new buffer structure allocated from the heap with
1188 a call to lisp_malloc. */
1191 allocate_buffer (void)
1194 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1196 XSETPVECTYPESIZE (b
, PVEC_BUFFER
,
1197 ((sizeof (struct buffer
) + sizeof (EMACS_INT
) - 1)
1198 / sizeof (EMACS_INT
)));
1203 #ifndef SYSTEM_MALLOC
1205 /* Arranging to disable input signals while we're in malloc.
1207 This only works with GNU malloc. To help out systems which can't
1208 use GNU malloc, all the calls to malloc, realloc, and free
1209 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1210 pair; unfortunately, we have no idea what C library functions
1211 might call malloc, so we can't really protect them unless you're
1212 using GNU malloc. Fortunately, most of the major operating systems
1213 can use GNU malloc. */
1216 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1217 there's no need to block input around malloc. */
1219 #ifndef DOUG_LEA_MALLOC
1220 extern void * (*__malloc_hook
) (size_t, const void *);
1221 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1222 extern void (*__free_hook
) (void *, const void *);
1223 /* Else declared in malloc.h, perhaps with an extra arg. */
1224 #endif /* DOUG_LEA_MALLOC */
1225 static void * (*old_malloc_hook
) (size_t, const void *);
1226 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1227 static void (*old_free_hook
) (void*, const void*);
1229 #ifdef DOUG_LEA_MALLOC
1230 # define BYTES_USED (mallinfo ().uordblks)
1232 # define BYTES_USED _bytes_used
1235 #ifdef GC_MALLOC_CHECK
1236 static int dont_register_blocks
;
1239 static size_t bytes_used_when_reconsidered
;
1241 /* Value of _bytes_used, when spare_memory was freed. */
1243 static size_t bytes_used_when_full
;
1245 /* This function is used as the hook for free to call. */
1248 emacs_blocked_free (void *ptr
, const void *ptr2
)
1252 #ifdef GC_MALLOC_CHECK
1258 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1261 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1266 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1270 #endif /* GC_MALLOC_CHECK */
1272 __free_hook
= old_free_hook
;
1275 /* If we released our reserve (due to running out of memory),
1276 and we have a fair amount free once again,
1277 try to set aside another reserve in case we run out once more. */
1278 if (! NILP (Vmemory_full
)
1279 /* Verify there is enough space that even with the malloc
1280 hysteresis this call won't run out again.
1281 The code here is correct as long as SPARE_MEMORY
1282 is substantially larger than the block size malloc uses. */
1283 && (bytes_used_when_full
1284 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1285 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1286 refill_memory_reserve ();
1288 __free_hook
= emacs_blocked_free
;
1289 UNBLOCK_INPUT_ALLOC
;
1293 /* This function is the malloc hook that Emacs uses. */
1296 emacs_blocked_malloc (size_t size
, const void *ptr
)
1301 __malloc_hook
= old_malloc_hook
;
1302 #ifdef DOUG_LEA_MALLOC
1303 /* Segfaults on my system. --lorentey */
1304 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1306 __malloc_extra_blocks
= malloc_hysteresis
;
1309 value
= (void *) malloc (size
);
1311 #ifdef GC_MALLOC_CHECK
1313 struct mem_node
*m
= mem_find (value
);
1316 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1318 fprintf (stderr
, "Region in use is %p...%p, %td bytes, type %d\n",
1319 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1324 if (!dont_register_blocks
)
1326 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1327 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1330 #endif /* GC_MALLOC_CHECK */
1332 __malloc_hook
= emacs_blocked_malloc
;
1333 UNBLOCK_INPUT_ALLOC
;
1335 /* fprintf (stderr, "%p malloc\n", value); */
1340 /* This function is the realloc hook that Emacs uses. */
1343 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1348 __realloc_hook
= old_realloc_hook
;
1350 #ifdef GC_MALLOC_CHECK
1353 struct mem_node
*m
= mem_find (ptr
);
1354 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1357 "Realloc of %p which wasn't allocated with malloc\n",
1365 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1367 /* Prevent malloc from registering blocks. */
1368 dont_register_blocks
= 1;
1369 #endif /* GC_MALLOC_CHECK */
1371 value
= (void *) realloc (ptr
, size
);
1373 #ifdef GC_MALLOC_CHECK
1374 dont_register_blocks
= 0;
1377 struct mem_node
*m
= mem_find (value
);
1380 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1384 /* Can't handle zero size regions in the red-black tree. */
1385 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1388 /* fprintf (stderr, "%p <- realloc\n", value); */
1389 #endif /* GC_MALLOC_CHECK */
1391 __realloc_hook
= emacs_blocked_realloc
;
1392 UNBLOCK_INPUT_ALLOC
;
1399 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1400 normal malloc. Some thread implementations need this as they call
1401 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1402 calls malloc because it is the first call, and we have an endless loop. */
1405 reset_malloc_hooks (void)
1407 __free_hook
= old_free_hook
;
1408 __malloc_hook
= old_malloc_hook
;
1409 __realloc_hook
= old_realloc_hook
;
1411 #endif /* HAVE_PTHREAD */
1414 /* Called from main to set up malloc to use our hooks. */
1417 uninterrupt_malloc (void)
1420 #ifdef DOUG_LEA_MALLOC
1421 pthread_mutexattr_t attr
;
1423 /* GLIBC has a faster way to do this, but let's keep it portable.
1424 This is according to the Single UNIX Specification. */
1425 pthread_mutexattr_init (&attr
);
1426 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1427 pthread_mutex_init (&alloc_mutex
, &attr
);
1428 #else /* !DOUG_LEA_MALLOC */
1429 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1430 and the bundled gmalloc.c doesn't require it. */
1431 pthread_mutex_init (&alloc_mutex
, NULL
);
1432 #endif /* !DOUG_LEA_MALLOC */
1433 #endif /* HAVE_PTHREAD */
1435 if (__free_hook
!= emacs_blocked_free
)
1436 old_free_hook
= __free_hook
;
1437 __free_hook
= emacs_blocked_free
;
1439 if (__malloc_hook
!= emacs_blocked_malloc
)
1440 old_malloc_hook
= __malloc_hook
;
1441 __malloc_hook
= emacs_blocked_malloc
;
1443 if (__realloc_hook
!= emacs_blocked_realloc
)
1444 old_realloc_hook
= __realloc_hook
;
1445 __realloc_hook
= emacs_blocked_realloc
;
1448 #endif /* not SYNC_INPUT */
1449 #endif /* not SYSTEM_MALLOC */
1453 /***********************************************************************
1455 ***********************************************************************/
1457 /* Number of intervals allocated in an interval_block structure.
1458 The 1020 is 1024 minus malloc overhead. */
1460 #define INTERVAL_BLOCK_SIZE \
1461 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1463 /* Intervals are allocated in chunks in form of an interval_block
1466 struct interval_block
1468 /* Place `intervals' first, to preserve alignment. */
1469 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1470 struct interval_block
*next
;
1473 /* Current interval block. Its `next' pointer points to older
1476 static struct interval_block
*interval_block
;
1478 /* Index in interval_block above of the next unused interval
1481 static int interval_block_index
;
1483 /* Number of free and live intervals. */
1485 static EMACS_INT total_free_intervals
, total_intervals
;
1487 /* List of free intervals. */
1489 static INTERVAL interval_free_list
;
1492 /* Initialize interval allocation. */
1495 init_intervals (void)
1497 interval_block
= NULL
;
1498 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1499 interval_free_list
= 0;
1503 /* Return a new interval. */
1506 make_interval (void)
1510 /* eassert (!handling_signal); */
1514 if (interval_free_list
)
1516 val
= interval_free_list
;
1517 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1521 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1523 register struct interval_block
*newi
;
1525 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1528 newi
->next
= interval_block
;
1529 interval_block
= newi
;
1530 interval_block_index
= 0;
1532 val
= &interval_block
->intervals
[interval_block_index
++];
1535 MALLOC_UNBLOCK_INPUT
;
1537 consing_since_gc
+= sizeof (struct interval
);
1539 RESET_INTERVAL (val
);
1545 /* Mark Lisp objects in interval I. */
1548 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1550 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1552 mark_object (i
->plist
);
1556 /* Mark the interval tree rooted in TREE. Don't call this directly;
1557 use the macro MARK_INTERVAL_TREE instead. */
1560 mark_interval_tree (register INTERVAL tree
)
1562 /* No need to test if this tree has been marked already; this
1563 function is always called through the MARK_INTERVAL_TREE macro,
1564 which takes care of that. */
1566 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1570 /* Mark the interval tree rooted in I. */
1572 #define MARK_INTERVAL_TREE(i) \
1574 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1575 mark_interval_tree (i); \
1579 #define UNMARK_BALANCE_INTERVALS(i) \
1581 if (! NULL_INTERVAL_P (i)) \
1582 (i) = balance_intervals (i); \
1586 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1587 can't create number objects in macros. */
1590 make_number (EMACS_INT n
)
1594 obj
.s
.type
= Lisp_Int
;
1599 /* Convert the pointer-sized word P to EMACS_INT while preserving its
1600 type and ptr fields. */
1602 widen_to_Lisp_Object (void *p
)
1604 intptr_t i
= (intptr_t) p
;
1605 #ifdef USE_LISP_UNION_TYPE
1614 /***********************************************************************
1616 ***********************************************************************/
1618 /* Lisp_Strings are allocated in string_block structures. When a new
1619 string_block is allocated, all the Lisp_Strings it contains are
1620 added to a free-list string_free_list. When a new Lisp_String is
1621 needed, it is taken from that list. During the sweep phase of GC,
1622 string_blocks that are entirely free are freed, except two which
1625 String data is allocated from sblock structures. Strings larger
1626 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1627 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1629 Sblocks consist internally of sdata structures, one for each
1630 Lisp_String. The sdata structure points to the Lisp_String it
1631 belongs to. The Lisp_String points back to the `u.data' member of
1632 its sdata structure.
1634 When a Lisp_String is freed during GC, it is put back on
1635 string_free_list, and its `data' member and its sdata's `string'
1636 pointer is set to null. The size of the string is recorded in the
1637 `u.nbytes' member of the sdata. So, sdata structures that are no
1638 longer used, can be easily recognized, and it's easy to compact the
1639 sblocks of small strings which we do in compact_small_strings. */
1641 /* Size in bytes of an sblock structure used for small strings. This
1642 is 8192 minus malloc overhead. */
1644 #define SBLOCK_SIZE 8188
1646 /* Strings larger than this are considered large strings. String data
1647 for large strings is allocated from individual sblocks. */
1649 #define LARGE_STRING_BYTES 1024
1651 /* Structure describing string memory sub-allocated from an sblock.
1652 This is where the contents of Lisp strings are stored. */
1656 /* Back-pointer to the string this sdata belongs to. If null, this
1657 structure is free, and the NBYTES member of the union below
1658 contains the string's byte size (the same value that STRING_BYTES
1659 would return if STRING were non-null). If non-null, STRING_BYTES
1660 (STRING) is the size of the data, and DATA contains the string's
1662 struct Lisp_String
*string
;
1664 #ifdef GC_CHECK_STRING_BYTES
1667 unsigned char data
[1];
1669 #define SDATA_NBYTES(S) (S)->nbytes
1670 #define SDATA_DATA(S) (S)->data
1671 #define SDATA_SELECTOR(member) member
1673 #else /* not GC_CHECK_STRING_BYTES */
1677 /* When STRING is non-null. */
1678 unsigned char data
[1];
1680 /* When STRING is null. */
1684 #define SDATA_NBYTES(S) (S)->u.nbytes
1685 #define SDATA_DATA(S) (S)->u.data
1686 #define SDATA_SELECTOR(member) u.member
1688 #endif /* not GC_CHECK_STRING_BYTES */
1690 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1694 /* Structure describing a block of memory which is sub-allocated to
1695 obtain string data memory for strings. Blocks for small strings
1696 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1697 as large as needed. */
1702 struct sblock
*next
;
1704 /* Pointer to the next free sdata block. This points past the end
1705 of the sblock if there isn't any space left in this block. */
1706 struct sdata
*next_free
;
1708 /* Start of data. */
1709 struct sdata first_data
;
1712 /* Number of Lisp strings in a string_block structure. The 1020 is
1713 1024 minus malloc overhead. */
1715 #define STRING_BLOCK_SIZE \
1716 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1718 /* Structure describing a block from which Lisp_String structures
1723 /* Place `strings' first, to preserve alignment. */
1724 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1725 struct string_block
*next
;
1728 /* Head and tail of the list of sblock structures holding Lisp string
1729 data. We always allocate from current_sblock. The NEXT pointers
1730 in the sblock structures go from oldest_sblock to current_sblock. */
1732 static struct sblock
*oldest_sblock
, *current_sblock
;
1734 /* List of sblocks for large strings. */
1736 static struct sblock
*large_sblocks
;
1738 /* List of string_block structures. */
1740 static struct string_block
*string_blocks
;
1742 /* Free-list of Lisp_Strings. */
1744 static struct Lisp_String
*string_free_list
;
1746 /* Number of live and free Lisp_Strings. */
1748 static EMACS_INT total_strings
, total_free_strings
;
1750 /* Number of bytes used by live strings. */
1752 static EMACS_INT total_string_size
;
1754 /* Given a pointer to a Lisp_String S which is on the free-list
1755 string_free_list, return a pointer to its successor in the
1758 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1760 /* Return a pointer to the sdata structure belonging to Lisp string S.
1761 S must be live, i.e. S->data must not be null. S->data is actually
1762 a pointer to the `u.data' member of its sdata structure; the
1763 structure starts at a constant offset in front of that. */
1765 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1768 #ifdef GC_CHECK_STRING_OVERRUN
1770 /* We check for overrun in string data blocks by appending a small
1771 "cookie" after each allocated string data block, and check for the
1772 presence of this cookie during GC. */
1774 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1775 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1776 { '\xde', '\xad', '\xbe', '\xef' };
1779 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1782 /* Value is the size of an sdata structure large enough to hold NBYTES
1783 bytes of string data. The value returned includes a terminating
1784 NUL byte, the size of the sdata structure, and padding. */
1786 #ifdef GC_CHECK_STRING_BYTES
1788 #define SDATA_SIZE(NBYTES) \
1789 ((SDATA_DATA_OFFSET \
1791 + sizeof (ptrdiff_t) - 1) \
1792 & ~(sizeof (ptrdiff_t) - 1))
1794 #else /* not GC_CHECK_STRING_BYTES */
1796 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1797 less than the size of that member. The 'max' is not needed when
1798 SDATA_DATA_OFFSET is a multiple of sizeof (ptrdiff_t), because then the
1799 alignment code reserves enough space. */
1801 #define SDATA_SIZE(NBYTES) \
1802 ((SDATA_DATA_OFFSET \
1803 + (SDATA_DATA_OFFSET % sizeof (ptrdiff_t) == 0 \
1805 : max (NBYTES, sizeof (ptrdiff_t) - 1)) \
1807 + sizeof (ptrdiff_t) - 1) \
1808 & ~(sizeof (ptrdiff_t) - 1))
1810 #endif /* not GC_CHECK_STRING_BYTES */
1812 /* Extra bytes to allocate for each string. */
1814 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1816 /* Exact bound on the number of bytes in a string, not counting the
1817 terminating null. A string cannot contain more bytes than
1818 STRING_BYTES_BOUND, nor can it be so long that the size_t
1819 arithmetic in allocate_string_data would overflow while it is
1820 calculating a value to be passed to malloc. */
1821 #define STRING_BYTES_MAX \
1822 min (STRING_BYTES_BOUND, \
1823 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \
1825 - offsetof (struct sblock, first_data) \
1826 - SDATA_DATA_OFFSET) \
1827 & ~(sizeof (EMACS_INT) - 1)))
1829 /* Initialize string allocation. Called from init_alloc_once. */
1834 total_strings
= total_free_strings
= total_string_size
= 0;
1835 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1836 string_blocks
= NULL
;
1837 string_free_list
= NULL
;
1838 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1839 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1843 #ifdef GC_CHECK_STRING_BYTES
1845 static int check_string_bytes_count
;
1847 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1850 /* Like GC_STRING_BYTES, but with debugging check. */
1853 string_bytes (struct Lisp_String
*s
)
1856 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1858 if (!PURE_POINTER_P (s
)
1860 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1865 /* Check validity of Lisp strings' string_bytes member in B. */
1868 check_sblock (struct sblock
*b
)
1870 struct sdata
*from
, *end
, *from_end
;
1874 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1876 /* Compute the next FROM here because copying below may
1877 overwrite data we need to compute it. */
1880 /* Check that the string size recorded in the string is the
1881 same as the one recorded in the sdata structure. */
1883 CHECK_STRING_BYTES (from
->string
);
1886 nbytes
= GC_STRING_BYTES (from
->string
);
1888 nbytes
= SDATA_NBYTES (from
);
1890 nbytes
= SDATA_SIZE (nbytes
);
1891 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1896 /* Check validity of Lisp strings' string_bytes member. ALL_P
1897 non-zero means check all strings, otherwise check only most
1898 recently allocated strings. Used for hunting a bug. */
1901 check_string_bytes (int all_p
)
1907 for (b
= large_sblocks
; b
; b
= b
->next
)
1909 struct Lisp_String
*s
= b
->first_data
.string
;
1911 CHECK_STRING_BYTES (s
);
1914 for (b
= oldest_sblock
; b
; b
= b
->next
)
1918 check_sblock (current_sblock
);
1921 #endif /* GC_CHECK_STRING_BYTES */
1923 #ifdef GC_CHECK_STRING_FREE_LIST
1925 /* Walk through the string free list looking for bogus next pointers.
1926 This may catch buffer overrun from a previous string. */
1929 check_string_free_list (void)
1931 struct Lisp_String
*s
;
1933 /* Pop a Lisp_String off the free-list. */
1934 s
= string_free_list
;
1937 if ((uintptr_t) s
< 1024)
1939 s
= NEXT_FREE_LISP_STRING (s
);
1943 #define check_string_free_list()
1946 /* Return a new Lisp_String. */
1948 static struct Lisp_String
*
1949 allocate_string (void)
1951 struct Lisp_String
*s
;
1953 /* eassert (!handling_signal); */
1957 /* If the free-list is empty, allocate a new string_block, and
1958 add all the Lisp_Strings in it to the free-list. */
1959 if (string_free_list
== NULL
)
1961 struct string_block
*b
;
1964 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1965 memset (b
, 0, sizeof *b
);
1966 b
->next
= string_blocks
;
1969 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1972 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1973 string_free_list
= s
;
1976 total_free_strings
+= STRING_BLOCK_SIZE
;
1979 check_string_free_list ();
1981 /* Pop a Lisp_String off the free-list. */
1982 s
= string_free_list
;
1983 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1985 MALLOC_UNBLOCK_INPUT
;
1987 /* Probably not strictly necessary, but play it safe. */
1988 memset (s
, 0, sizeof *s
);
1990 --total_free_strings
;
1993 consing_since_gc
+= sizeof *s
;
1995 #ifdef GC_CHECK_STRING_BYTES
1996 if (!noninteractive
)
1998 if (++check_string_bytes_count
== 200)
2000 check_string_bytes_count
= 0;
2001 check_string_bytes (1);
2004 check_string_bytes (0);
2006 #endif /* GC_CHECK_STRING_BYTES */
2012 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
2013 plus a NUL byte at the end. Allocate an sdata structure for S, and
2014 set S->data to its `u.data' member. Store a NUL byte at the end of
2015 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
2016 S->data if it was initially non-null. */
2019 allocate_string_data (struct Lisp_String
*s
,
2020 EMACS_INT nchars
, EMACS_INT nbytes
)
2022 struct sdata
*data
, *old_data
;
2024 ptrdiff_t needed
, old_nbytes
;
2026 if (STRING_BYTES_MAX
< nbytes
)
2029 /* Determine the number of bytes needed to store NBYTES bytes
2031 needed
= SDATA_SIZE (nbytes
);
2032 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
2033 old_nbytes
= GC_STRING_BYTES (s
);
2037 if (nbytes
> LARGE_STRING_BYTES
)
2039 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
2041 #ifdef DOUG_LEA_MALLOC
2042 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2043 because mapped region contents are not preserved in
2046 In case you think of allowing it in a dumped Emacs at the
2047 cost of not being able to re-dump, there's another reason:
2048 mmap'ed data typically have an address towards the top of the
2049 address space, which won't fit into an EMACS_INT (at least on
2050 32-bit systems with the current tagging scheme). --fx */
2051 mallopt (M_MMAP_MAX
, 0);
2054 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
2056 #ifdef DOUG_LEA_MALLOC
2057 /* Back to a reasonable maximum of mmap'ed areas. */
2058 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2061 b
->next_free
= &b
->first_data
;
2062 b
->first_data
.string
= NULL
;
2063 b
->next
= large_sblocks
;
2066 else if (current_sblock
== NULL
2067 || (((char *) current_sblock
+ SBLOCK_SIZE
2068 - (char *) current_sblock
->next_free
)
2069 < (needed
+ GC_STRING_EXTRA
)))
2071 /* Not enough room in the current sblock. */
2072 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2073 b
->next_free
= &b
->first_data
;
2074 b
->first_data
.string
= NULL
;
2078 current_sblock
->next
= b
;
2086 data
= b
->next_free
;
2087 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2089 MALLOC_UNBLOCK_INPUT
;
2092 s
->data
= SDATA_DATA (data
);
2093 #ifdef GC_CHECK_STRING_BYTES
2094 SDATA_NBYTES (data
) = nbytes
;
2097 s
->size_byte
= nbytes
;
2098 s
->data
[nbytes
] = '\0';
2099 #ifdef GC_CHECK_STRING_OVERRUN
2100 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2101 GC_STRING_OVERRUN_COOKIE_SIZE
);
2104 /* If S had already data assigned, mark that as free by setting its
2105 string back-pointer to null, and recording the size of the data
2109 SDATA_NBYTES (old_data
) = old_nbytes
;
2110 old_data
->string
= NULL
;
2113 consing_since_gc
+= needed
;
2117 /* Sweep and compact strings. */
2120 sweep_strings (void)
2122 struct string_block
*b
, *next
;
2123 struct string_block
*live_blocks
= NULL
;
2125 string_free_list
= NULL
;
2126 total_strings
= total_free_strings
= 0;
2127 total_string_size
= 0;
2129 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2130 for (b
= string_blocks
; b
; b
= next
)
2133 struct Lisp_String
*free_list_before
= string_free_list
;
2137 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2139 struct Lisp_String
*s
= b
->strings
+ i
;
2143 /* String was not on free-list before. */
2144 if (STRING_MARKED_P (s
))
2146 /* String is live; unmark it and its intervals. */
2149 if (!NULL_INTERVAL_P (s
->intervals
))
2150 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2153 total_string_size
+= STRING_BYTES (s
);
2157 /* String is dead. Put it on the free-list. */
2158 struct sdata
*data
= SDATA_OF_STRING (s
);
2160 /* Save the size of S in its sdata so that we know
2161 how large that is. Reset the sdata's string
2162 back-pointer so that we know it's free. */
2163 #ifdef GC_CHECK_STRING_BYTES
2164 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2167 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2169 data
->string
= NULL
;
2171 /* Reset the strings's `data' member so that we
2175 /* Put the string on the free-list. */
2176 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2177 string_free_list
= s
;
2183 /* S was on the free-list before. Put it there again. */
2184 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2185 string_free_list
= s
;
2190 /* Free blocks that contain free Lisp_Strings only, except
2191 the first two of them. */
2192 if (nfree
== STRING_BLOCK_SIZE
2193 && total_free_strings
> STRING_BLOCK_SIZE
)
2196 string_free_list
= free_list_before
;
2200 total_free_strings
+= nfree
;
2201 b
->next
= live_blocks
;
2206 check_string_free_list ();
2208 string_blocks
= live_blocks
;
2209 free_large_strings ();
2210 compact_small_strings ();
2212 check_string_free_list ();
2216 /* Free dead large strings. */
2219 free_large_strings (void)
2221 struct sblock
*b
, *next
;
2222 struct sblock
*live_blocks
= NULL
;
2224 for (b
= large_sblocks
; b
; b
= next
)
2228 if (b
->first_data
.string
== NULL
)
2232 b
->next
= live_blocks
;
2237 large_sblocks
= live_blocks
;
2241 /* Compact data of small strings. Free sblocks that don't contain
2242 data of live strings after compaction. */
2245 compact_small_strings (void)
2247 struct sblock
*b
, *tb
, *next
;
2248 struct sdata
*from
, *to
, *end
, *tb_end
;
2249 struct sdata
*to_end
, *from_end
;
2251 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2252 to, and TB_END is the end of TB. */
2254 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2255 to
= &tb
->first_data
;
2257 /* Step through the blocks from the oldest to the youngest. We
2258 expect that old blocks will stabilize over time, so that less
2259 copying will happen this way. */
2260 for (b
= oldest_sblock
; b
; b
= b
->next
)
2263 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2265 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2267 /* Compute the next FROM here because copying below may
2268 overwrite data we need to compute it. */
2271 #ifdef GC_CHECK_STRING_BYTES
2272 /* Check that the string size recorded in the string is the
2273 same as the one recorded in the sdata structure. */
2275 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2277 #endif /* GC_CHECK_STRING_BYTES */
2280 nbytes
= GC_STRING_BYTES (from
->string
);
2282 nbytes
= SDATA_NBYTES (from
);
2284 if (nbytes
> LARGE_STRING_BYTES
)
2287 nbytes
= SDATA_SIZE (nbytes
);
2288 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2290 #ifdef GC_CHECK_STRING_OVERRUN
2291 if (memcmp (string_overrun_cookie
,
2292 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2293 GC_STRING_OVERRUN_COOKIE_SIZE
))
2297 /* FROM->string non-null means it's alive. Copy its data. */
2300 /* If TB is full, proceed with the next sblock. */
2301 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2302 if (to_end
> tb_end
)
2306 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2307 to
= &tb
->first_data
;
2308 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2311 /* Copy, and update the string's `data' pointer. */
2314 xassert (tb
!= b
|| to
< from
);
2315 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2316 to
->string
->data
= SDATA_DATA (to
);
2319 /* Advance past the sdata we copied to. */
2325 /* The rest of the sblocks following TB don't contain live data, so
2326 we can free them. */
2327 for (b
= tb
->next
; b
; b
= next
)
2335 current_sblock
= tb
;
2339 string_overflow (void)
2341 error ("Maximum string size exceeded");
2344 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2345 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2346 LENGTH must be an integer.
2347 INIT must be an integer that represents a character. */)
2348 (Lisp_Object length
, Lisp_Object init
)
2350 register Lisp_Object val
;
2351 register unsigned char *p
, *end
;
2355 CHECK_NATNUM (length
);
2356 CHECK_CHARACTER (init
);
2358 c
= XFASTINT (init
);
2359 if (ASCII_CHAR_P (c
))
2361 nbytes
= XINT (length
);
2362 val
= make_uninit_string (nbytes
);
2364 end
= p
+ SCHARS (val
);
2370 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2371 int len
= CHAR_STRING (c
, str
);
2372 EMACS_INT string_len
= XINT (length
);
2374 if (string_len
> STRING_BYTES_MAX
/ len
)
2376 nbytes
= len
* string_len
;
2377 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2382 memcpy (p
, str
, len
);
2392 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2393 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2394 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2395 (Lisp_Object length
, Lisp_Object init
)
2397 register Lisp_Object val
;
2398 struct Lisp_Bool_Vector
*p
;
2399 ptrdiff_t length_in_chars
;
2400 EMACS_INT length_in_elts
;
2403 CHECK_NATNUM (length
);
2405 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2407 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2409 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2410 slot `size' of the struct Lisp_Bool_Vector. */
2411 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2413 /* No Lisp_Object to trace in there. */
2414 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0);
2416 p
= XBOOL_VECTOR (val
);
2417 p
->size
= XFASTINT (length
);
2419 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2420 / BOOL_VECTOR_BITS_PER_CHAR
);
2421 if (length_in_chars
)
2423 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2425 /* Clear any extraneous bits in the last byte. */
2426 p
->data
[length_in_chars
- 1]
2427 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2434 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2435 of characters from the contents. This string may be unibyte or
2436 multibyte, depending on the contents. */
2439 make_string (const char *contents
, ptrdiff_t nbytes
)
2441 register Lisp_Object val
;
2442 ptrdiff_t nchars
, multibyte_nbytes
;
2444 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2445 &nchars
, &multibyte_nbytes
);
2446 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2447 /* CONTENTS contains no multibyte sequences or contains an invalid
2448 multibyte sequence. We must make unibyte string. */
2449 val
= make_unibyte_string (contents
, nbytes
);
2451 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2456 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2459 make_unibyte_string (const char *contents
, ptrdiff_t length
)
2461 register Lisp_Object val
;
2462 val
= make_uninit_string (length
);
2463 memcpy (SDATA (val
), contents
, length
);
2468 /* Make a multibyte string from NCHARS characters occupying NBYTES
2469 bytes at CONTENTS. */
2472 make_multibyte_string (const char *contents
,
2473 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2475 register Lisp_Object val
;
2476 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2477 memcpy (SDATA (val
), contents
, nbytes
);
2482 /* Make a string from NCHARS characters occupying NBYTES bytes at
2483 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2486 make_string_from_bytes (const char *contents
,
2487 ptrdiff_t nchars
, ptrdiff_t nbytes
)
2489 register Lisp_Object val
;
2490 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2491 memcpy (SDATA (val
), contents
, nbytes
);
2492 if (SBYTES (val
) == SCHARS (val
))
2493 STRING_SET_UNIBYTE (val
);
2498 /* Make a string from NCHARS characters occupying NBYTES bytes at
2499 CONTENTS. The argument MULTIBYTE controls whether to label the
2500 string as multibyte. If NCHARS is negative, it counts the number of
2501 characters by itself. */
2504 make_specified_string (const char *contents
,
2505 ptrdiff_t nchars
, ptrdiff_t nbytes
, int multibyte
)
2507 register Lisp_Object val
;
2512 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2517 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2518 memcpy (SDATA (val
), contents
, nbytes
);
2520 STRING_SET_UNIBYTE (val
);
2525 /* Make a string from the data at STR, treating it as multibyte if the
2529 build_string (const char *str
)
2531 return make_string (str
, strlen (str
));
2535 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2536 occupying LENGTH bytes. */
2539 make_uninit_string (EMACS_INT length
)
2544 return empty_unibyte_string
;
2545 val
= make_uninit_multibyte_string (length
, length
);
2546 STRING_SET_UNIBYTE (val
);
2551 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2552 which occupy NBYTES bytes. */
2555 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2558 struct Lisp_String
*s
;
2563 return empty_multibyte_string
;
2565 s
= allocate_string ();
2566 allocate_string_data (s
, nchars
, nbytes
);
2567 XSETSTRING (string
, s
);
2568 string_chars_consed
+= nbytes
;
2574 /***********************************************************************
2576 ***********************************************************************/
2578 /* We store float cells inside of float_blocks, allocating a new
2579 float_block with malloc whenever necessary. Float cells reclaimed
2580 by GC are put on a free list to be reallocated before allocating
2581 any new float cells from the latest float_block. */
2583 #define FLOAT_BLOCK_SIZE \
2584 (((BLOCK_BYTES - sizeof (struct float_block *) \
2585 /* The compiler might add padding at the end. */ \
2586 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2587 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2589 #define GETMARKBIT(block,n) \
2590 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2591 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2594 #define SETMARKBIT(block,n) \
2595 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2596 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2598 #define UNSETMARKBIT(block,n) \
2599 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2600 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2602 #define FLOAT_BLOCK(fptr) \
2603 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2605 #define FLOAT_INDEX(fptr) \
2606 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2610 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2611 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2612 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2613 struct float_block
*next
;
2616 #define FLOAT_MARKED_P(fptr) \
2617 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2619 #define FLOAT_MARK(fptr) \
2620 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2622 #define FLOAT_UNMARK(fptr) \
2623 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2625 /* Current float_block. */
2627 static struct float_block
*float_block
;
2629 /* Index of first unused Lisp_Float in the current float_block. */
2631 static int float_block_index
;
2633 /* Free-list of Lisp_Floats. */
2635 static struct Lisp_Float
*float_free_list
;
2638 /* Initialize float allocation. */
2644 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2645 float_free_list
= 0;
2649 /* Return a new float object with value FLOAT_VALUE. */
2652 make_float (double float_value
)
2654 register Lisp_Object val
;
2656 /* eassert (!handling_signal); */
2660 if (float_free_list
)
2662 /* We use the data field for chaining the free list
2663 so that we won't use the same field that has the mark bit. */
2664 XSETFLOAT (val
, float_free_list
);
2665 float_free_list
= float_free_list
->u
.chain
;
2669 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2671 register struct float_block
*new;
2673 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2675 new->next
= float_block
;
2676 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2678 float_block_index
= 0;
2680 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2681 float_block_index
++;
2684 MALLOC_UNBLOCK_INPUT
;
2686 XFLOAT_INIT (val
, float_value
);
2687 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2688 consing_since_gc
+= sizeof (struct Lisp_Float
);
2695 /***********************************************************************
2697 ***********************************************************************/
2699 /* We store cons cells inside of cons_blocks, allocating a new
2700 cons_block with malloc whenever necessary. Cons cells reclaimed by
2701 GC are put on a free list to be reallocated before allocating
2702 any new cons cells from the latest cons_block. */
2704 #define CONS_BLOCK_SIZE \
2705 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2706 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2708 #define CONS_BLOCK(fptr) \
2709 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2711 #define CONS_INDEX(fptr) \
2712 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2716 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2717 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2718 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2719 struct cons_block
*next
;
2722 #define CONS_MARKED_P(fptr) \
2723 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2725 #define CONS_MARK(fptr) \
2726 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2728 #define CONS_UNMARK(fptr) \
2729 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2731 /* Current cons_block. */
2733 static struct cons_block
*cons_block
;
2735 /* Index of first unused Lisp_Cons in the current block. */
2737 static int cons_block_index
;
2739 /* Free-list of Lisp_Cons structures. */
2741 static struct Lisp_Cons
*cons_free_list
;
2744 /* Initialize cons allocation. */
2750 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2755 /* Explicitly free a cons cell by putting it on the free-list. */
2758 free_cons (struct Lisp_Cons
*ptr
)
2760 ptr
->u
.chain
= cons_free_list
;
2764 cons_free_list
= ptr
;
2767 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2768 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2769 (Lisp_Object car
, Lisp_Object cdr
)
2771 register Lisp_Object val
;
2773 /* eassert (!handling_signal); */
2779 /* We use the cdr for chaining the free list
2780 so that we won't use the same field that has the mark bit. */
2781 XSETCONS (val
, cons_free_list
);
2782 cons_free_list
= cons_free_list
->u
.chain
;
2786 if (cons_block_index
== CONS_BLOCK_SIZE
)
2788 register struct cons_block
*new;
2789 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2791 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2792 new->next
= cons_block
;
2794 cons_block_index
= 0;
2796 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2800 MALLOC_UNBLOCK_INPUT
;
2804 eassert (!CONS_MARKED_P (XCONS (val
)));
2805 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2806 cons_cells_consed
++;
2810 #ifdef GC_CHECK_CONS_LIST
2811 /* Get an error now if there's any junk in the cons free list. */
2813 check_cons_list (void)
2815 struct Lisp_Cons
*tail
= cons_free_list
;
2818 tail
= tail
->u
.chain
;
2822 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2825 list1 (Lisp_Object arg1
)
2827 return Fcons (arg1
, Qnil
);
2831 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2833 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2838 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2840 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2845 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2847 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2852 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2854 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2855 Fcons (arg5
, Qnil
)))));
2859 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2860 doc
: /* Return a newly created list with specified arguments as elements.
2861 Any number of arguments, even zero arguments, are allowed.
2862 usage: (list &rest OBJECTS) */)
2863 (ptrdiff_t nargs
, Lisp_Object
*args
)
2865 register Lisp_Object val
;
2871 val
= Fcons (args
[nargs
], val
);
2877 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2878 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2879 (register Lisp_Object length
, Lisp_Object init
)
2881 register Lisp_Object val
;
2882 register EMACS_INT size
;
2884 CHECK_NATNUM (length
);
2885 size
= XFASTINT (length
);
2890 val
= Fcons (init
, val
);
2895 val
= Fcons (init
, val
);
2900 val
= Fcons (init
, val
);
2905 val
= Fcons (init
, val
);
2910 val
= Fcons (init
, val
);
2925 /***********************************************************************
2927 ***********************************************************************/
2929 /* Singly-linked list of all vectors. */
2931 static struct Lisp_Vector
*all_vectors
;
2933 /* Handy constants for vectorlike objects. */
2936 header_size
= offsetof (struct Lisp_Vector
, contents
),
2937 word_size
= sizeof (Lisp_Object
)
2940 /* Value is a pointer to a newly allocated Lisp_Vector structure
2941 with room for LEN Lisp_Objects. */
2943 static struct Lisp_Vector
*
2944 allocate_vectorlike (ptrdiff_t len
)
2946 struct Lisp_Vector
*p
;
2951 #ifdef DOUG_LEA_MALLOC
2952 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2953 because mapped region contents are not preserved in
2955 mallopt (M_MMAP_MAX
, 0);
2958 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2959 /* eassert (!handling_signal); */
2961 nbytes
= header_size
+ len
* word_size
;
2962 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
2964 #ifdef DOUG_LEA_MALLOC
2965 /* Back to a reasonable maximum of mmap'ed areas. */
2966 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2969 consing_since_gc
+= nbytes
;
2970 vector_cells_consed
+= len
;
2972 p
->header
.next
.vector
= all_vectors
;
2975 MALLOC_UNBLOCK_INPUT
;
2981 /* Allocate a vector with LEN slots. */
2983 struct Lisp_Vector
*
2984 allocate_vector (EMACS_INT len
)
2986 struct Lisp_Vector
*v
;
2987 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2989 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2990 memory_full (SIZE_MAX
);
2991 v
= allocate_vectorlike (len
);
2992 v
->header
.size
= len
;
2997 /* Allocate other vector-like structures. */
2999 struct Lisp_Vector
*
3000 allocate_pseudovector (int memlen
, int lisplen
, int tag
)
3002 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
3005 /* Only the first lisplen slots will be traced normally by the GC. */
3006 for (i
= 0; i
< lisplen
; ++i
)
3007 v
->contents
[i
] = Qnil
;
3009 XSETPVECTYPESIZE (v
, tag
, lisplen
);
3013 struct Lisp_Hash_Table
*
3014 allocate_hash_table (void)
3016 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3021 allocate_window (void)
3023 return ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3028 allocate_terminal (void)
3030 struct terminal
*t
= ALLOCATE_PSEUDOVECTOR (struct terminal
,
3031 next_terminal
, PVEC_TERMINAL
);
3032 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3033 memset (&t
->next_terminal
, 0,
3034 (char*) (t
+ 1) - (char*) &t
->next_terminal
);
3040 allocate_frame (void)
3042 struct frame
*f
= ALLOCATE_PSEUDOVECTOR (struct frame
,
3043 face_cache
, PVEC_FRAME
);
3044 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3045 memset (&f
->face_cache
, 0,
3046 (char *) (f
+ 1) - (char *) &f
->face_cache
);
3051 struct Lisp_Process
*
3052 allocate_process (void)
3054 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3058 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3059 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3060 See also the function `vector'. */)
3061 (register Lisp_Object length
, Lisp_Object init
)
3064 register ptrdiff_t sizei
;
3065 register ptrdiff_t i
;
3066 register struct Lisp_Vector
*p
;
3068 CHECK_NATNUM (length
);
3070 p
= allocate_vector (XFASTINT (length
));
3071 sizei
= XFASTINT (length
);
3072 for (i
= 0; i
< sizei
; i
++)
3073 p
->contents
[i
] = init
;
3075 XSETVECTOR (vector
, p
);
3080 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3081 doc
: /* Return a newly created vector with specified arguments as elements.
3082 Any number of arguments, even zero arguments, are allowed.
3083 usage: (vector &rest OBJECTS) */)
3084 (ptrdiff_t nargs
, Lisp_Object
*args
)
3086 register Lisp_Object len
, val
;
3088 register struct Lisp_Vector
*p
;
3090 XSETFASTINT (len
, nargs
);
3091 val
= Fmake_vector (len
, Qnil
);
3093 for (i
= 0; i
< nargs
; i
++)
3094 p
->contents
[i
] = args
[i
];
3099 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3100 doc
: /* Create a byte-code object with specified arguments as elements.
3101 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3102 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3103 and (optional) INTERACTIVE-SPEC.
3104 The first four arguments are required; at most six have any
3106 The ARGLIST can be either like the one of `lambda', in which case the arguments
3107 will be dynamically bound before executing the byte code, or it can be an
3108 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3109 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3110 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3111 argument to catch the left-over arguments. If such an integer is used, the
3112 arguments will not be dynamically bound but will be instead pushed on the
3113 stack before executing the byte-code.
3114 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3115 (ptrdiff_t nargs
, Lisp_Object
*args
)
3117 register Lisp_Object len
, val
;
3119 register struct Lisp_Vector
*p
;
3121 XSETFASTINT (len
, nargs
);
3122 if (!NILP (Vpurify_flag
))
3123 val
= make_pure_vector (nargs
);
3125 val
= Fmake_vector (len
, Qnil
);
3127 if (nargs
> 1 && STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3128 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3129 earlier because they produced a raw 8-bit string for byte-code
3130 and now such a byte-code string is loaded as multibyte while
3131 raw 8-bit characters converted to multibyte form. Thus, now we
3132 must convert them back to the original unibyte form. */
3133 args
[1] = Fstring_as_unibyte (args
[1]);
3136 for (i
= 0; i
< nargs
; i
++)
3138 if (!NILP (Vpurify_flag
))
3139 args
[i
] = Fpurecopy (args
[i
]);
3140 p
->contents
[i
] = args
[i
];
3142 XSETPVECTYPE (p
, PVEC_COMPILED
);
3143 XSETCOMPILED (val
, p
);
3149 /***********************************************************************
3151 ***********************************************************************/
3153 /* Like struct Lisp_Symbol, but padded so that the size is a multiple
3154 of the required alignment if LSB tags are used. */
3156 union aligned_Lisp_Symbol
3158 struct Lisp_Symbol s
;
3160 unsigned char c
[(sizeof (struct Lisp_Symbol
) + (1 << GCTYPEBITS
) - 1)
3161 & -(1 << GCTYPEBITS
)];
3165 /* Each symbol_block is just under 1020 bytes long, since malloc
3166 really allocates in units of powers of two and uses 4 bytes for its
3169 #define SYMBOL_BLOCK_SIZE \
3170 ((1020 - sizeof (struct symbol_block *)) / sizeof (union aligned_Lisp_Symbol))
3174 /* Place `symbols' first, to preserve alignment. */
3175 union aligned_Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3176 struct symbol_block
*next
;
3179 /* Current symbol block and index of first unused Lisp_Symbol
3182 static struct symbol_block
*symbol_block
;
3183 static int symbol_block_index
;
3185 /* List of free symbols. */
3187 static struct Lisp_Symbol
*symbol_free_list
;
3190 /* Initialize symbol allocation. */
3195 symbol_block
= NULL
;
3196 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3197 symbol_free_list
= 0;
3201 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3202 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3203 Its value and function definition are void, and its property list is nil. */)
3206 register Lisp_Object val
;
3207 register struct Lisp_Symbol
*p
;
3209 CHECK_STRING (name
);
3211 /* eassert (!handling_signal); */
3215 if (symbol_free_list
)
3217 XSETSYMBOL (val
, symbol_free_list
);
3218 symbol_free_list
= symbol_free_list
->next
;
3222 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3224 struct symbol_block
*new;
3225 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3227 new->next
= symbol_block
;
3229 symbol_block_index
= 0;
3231 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
].s
);
3232 symbol_block_index
++;
3235 MALLOC_UNBLOCK_INPUT
;
3240 p
->redirect
= SYMBOL_PLAINVAL
;
3241 SET_SYMBOL_VAL (p
, Qunbound
);
3242 p
->function
= Qunbound
;
3245 p
->interned
= SYMBOL_UNINTERNED
;
3247 p
->declared_special
= 0;
3248 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3255 /***********************************************************************
3256 Marker (Misc) Allocation
3257 ***********************************************************************/
3259 /* Like union Lisp_Misc, but padded so that its size is a multiple of
3260 the required alignment when LSB tags are used. */
3262 union aligned_Lisp_Misc
3266 unsigned char c
[(sizeof (union Lisp_Misc
) + (1 << GCTYPEBITS
) - 1)
3267 & -(1 << GCTYPEBITS
)];
3271 /* Allocation of markers and other objects that share that structure.
3272 Works like allocation of conses. */
3274 #define MARKER_BLOCK_SIZE \
3275 ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc))
3279 /* Place `markers' first, to preserve alignment. */
3280 union aligned_Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3281 struct marker_block
*next
;
3284 static struct marker_block
*marker_block
;
3285 static int marker_block_index
;
3287 static union Lisp_Misc
*marker_free_list
;
3292 marker_block
= NULL
;
3293 marker_block_index
= MARKER_BLOCK_SIZE
;
3294 marker_free_list
= 0;
3297 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3300 allocate_misc (void)
3304 /* eassert (!handling_signal); */
3308 if (marker_free_list
)
3310 XSETMISC (val
, marker_free_list
);
3311 marker_free_list
= marker_free_list
->u_free
.chain
;
3315 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3317 struct marker_block
*new;
3318 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3320 new->next
= marker_block
;
3322 marker_block_index
= 0;
3323 total_free_markers
+= MARKER_BLOCK_SIZE
;
3325 XSETMISC (val
, &marker_block
->markers
[marker_block_index
].m
);
3326 marker_block_index
++;
3329 MALLOC_UNBLOCK_INPUT
;
3331 --total_free_markers
;
3332 consing_since_gc
+= sizeof (union Lisp_Misc
);
3333 misc_objects_consed
++;
3334 XMISCANY (val
)->gcmarkbit
= 0;
3338 /* Free a Lisp_Misc object */
3341 free_misc (Lisp_Object misc
)
3343 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3344 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3345 marker_free_list
= XMISC (misc
);
3347 total_free_markers
++;
3350 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3351 INTEGER. This is used to package C values to call record_unwind_protect.
3352 The unwind function can get the C values back using XSAVE_VALUE. */
3355 make_save_value (void *pointer
, ptrdiff_t integer
)
3357 register Lisp_Object val
;
3358 register struct Lisp_Save_Value
*p
;
3360 val
= allocate_misc ();
3361 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3362 p
= XSAVE_VALUE (val
);
3363 p
->pointer
= pointer
;
3364 p
->integer
= integer
;
3369 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3370 doc
: /* Return a newly allocated marker which does not point at any place. */)
3373 register Lisp_Object val
;
3374 register struct Lisp_Marker
*p
;
3376 val
= allocate_misc ();
3377 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3383 p
->insertion_type
= 0;
3387 /* Put MARKER back on the free list after using it temporarily. */
3390 free_marker (Lisp_Object marker
)
3392 unchain_marker (XMARKER (marker
));
3397 /* Return a newly created vector or string with specified arguments as
3398 elements. If all the arguments are characters that can fit
3399 in a string of events, make a string; otherwise, make a vector.
3401 Any number of arguments, even zero arguments, are allowed. */
3404 make_event_array (register int nargs
, Lisp_Object
*args
)
3408 for (i
= 0; i
< nargs
; i
++)
3409 /* The things that fit in a string
3410 are characters that are in 0...127,
3411 after discarding the meta bit and all the bits above it. */
3412 if (!INTEGERP (args
[i
])
3413 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3414 return Fvector (nargs
, args
);
3416 /* Since the loop exited, we know that all the things in it are
3417 characters, so we can make a string. */
3421 result
= Fmake_string (make_number (nargs
), make_number (0));
3422 for (i
= 0; i
< nargs
; i
++)
3424 SSET (result
, i
, XINT (args
[i
]));
3425 /* Move the meta bit to the right place for a string char. */
3426 if (XINT (args
[i
]) & CHAR_META
)
3427 SSET (result
, i
, SREF (result
, i
) | 0x80);
3436 /************************************************************************
3437 Memory Full Handling
3438 ************************************************************************/
3441 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3442 there may have been size_t overflow so that malloc was never
3443 called, or perhaps malloc was invoked successfully but the
3444 resulting pointer had problems fitting into a tagged EMACS_INT. In
3445 either case this counts as memory being full even though malloc did
3449 memory_full (size_t nbytes
)
3451 /* Do not go into hysterics merely because a large request failed. */
3452 int enough_free_memory
= 0;
3453 if (SPARE_MEMORY
< nbytes
)
3458 p
= malloc (SPARE_MEMORY
);
3462 enough_free_memory
= 1;
3464 MALLOC_UNBLOCK_INPUT
;
3467 if (! enough_free_memory
)
3473 memory_full_cons_threshold
= sizeof (struct cons_block
);
3475 /* The first time we get here, free the spare memory. */
3476 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3477 if (spare_memory
[i
])
3480 free (spare_memory
[i
]);
3481 else if (i
>= 1 && i
<= 4)
3482 lisp_align_free (spare_memory
[i
]);
3484 lisp_free (spare_memory
[i
]);
3485 spare_memory
[i
] = 0;
3488 /* Record the space now used. When it decreases substantially,
3489 we can refill the memory reserve. */
3490 #if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3491 bytes_used_when_full
= BYTES_USED
;
3495 /* This used to call error, but if we've run out of memory, we could
3496 get infinite recursion trying to build the string. */
3497 xsignal (Qnil
, Vmemory_signal_data
);
3500 /* If we released our reserve (due to running out of memory),
3501 and we have a fair amount free once again,
3502 try to set aside another reserve in case we run out once more.
3504 This is called when a relocatable block is freed in ralloc.c,
3505 and also directly from this file, in case we're not using ralloc.c. */
3508 refill_memory_reserve (void)
3510 #ifndef SYSTEM_MALLOC
3511 if (spare_memory
[0] == 0)
3512 spare_memory
[0] = (char *) malloc (SPARE_MEMORY
);
3513 if (spare_memory
[1] == 0)
3514 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3516 if (spare_memory
[2] == 0)
3517 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3519 if (spare_memory
[3] == 0)
3520 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3522 if (spare_memory
[4] == 0)
3523 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3525 if (spare_memory
[5] == 0)
3526 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3528 if (spare_memory
[6] == 0)
3529 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3531 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3532 Vmemory_full
= Qnil
;
3536 /************************************************************************
3538 ************************************************************************/
3540 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3542 /* Conservative C stack marking requires a method to identify possibly
3543 live Lisp objects given a pointer value. We do this by keeping
3544 track of blocks of Lisp data that are allocated in a red-black tree
3545 (see also the comment of mem_node which is the type of nodes in
3546 that tree). Function lisp_malloc adds information for an allocated
3547 block to the red-black tree with calls to mem_insert, and function
3548 lisp_free removes it with mem_delete. Functions live_string_p etc
3549 call mem_find to lookup information about a given pointer in the
3550 tree, and use that to determine if the pointer points to a Lisp
3553 /* Initialize this part of alloc.c. */
3558 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3559 mem_z
.parent
= NULL
;
3560 mem_z
.color
= MEM_BLACK
;
3561 mem_z
.start
= mem_z
.end
= NULL
;
3566 /* Value is a pointer to the mem_node containing START. Value is
3567 MEM_NIL if there is no node in the tree containing START. */
3569 static inline struct mem_node
*
3570 mem_find (void *start
)
3574 if (start
< min_heap_address
|| start
> max_heap_address
)
3577 /* Make the search always successful to speed up the loop below. */
3578 mem_z
.start
= start
;
3579 mem_z
.end
= (char *) start
+ 1;
3582 while (start
< p
->start
|| start
>= p
->end
)
3583 p
= start
< p
->start
? p
->left
: p
->right
;
3588 /* Insert a new node into the tree for a block of memory with start
3589 address START, end address END, and type TYPE. Value is a
3590 pointer to the node that was inserted. */
3592 static struct mem_node
*
3593 mem_insert (void *start
, void *end
, enum mem_type type
)
3595 struct mem_node
*c
, *parent
, *x
;
3597 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3598 min_heap_address
= start
;
3599 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3600 max_heap_address
= end
;
3602 /* See where in the tree a node for START belongs. In this
3603 particular application, it shouldn't happen that a node is already
3604 present. For debugging purposes, let's check that. */
3608 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3610 while (c
!= MEM_NIL
)
3612 if (start
>= c
->start
&& start
< c
->end
)
3615 c
= start
< c
->start
? c
->left
: c
->right
;
3618 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3620 while (c
!= MEM_NIL
)
3623 c
= start
< c
->start
? c
->left
: c
->right
;
3626 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3628 /* Create a new node. */
3629 #ifdef GC_MALLOC_CHECK
3630 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3634 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3640 x
->left
= x
->right
= MEM_NIL
;
3643 /* Insert it as child of PARENT or install it as root. */
3646 if (start
< parent
->start
)
3654 /* Re-establish red-black tree properties. */
3655 mem_insert_fixup (x
);
3661 /* Re-establish the red-black properties of the tree, and thereby
3662 balance the tree, after node X has been inserted; X is always red. */
3665 mem_insert_fixup (struct mem_node
*x
)
3667 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3669 /* X is red and its parent is red. This is a violation of
3670 red-black tree property #3. */
3672 if (x
->parent
== x
->parent
->parent
->left
)
3674 /* We're on the left side of our grandparent, and Y is our
3676 struct mem_node
*y
= x
->parent
->parent
->right
;
3678 if (y
->color
== MEM_RED
)
3680 /* Uncle and parent are red but should be black because
3681 X is red. Change the colors accordingly and proceed
3682 with the grandparent. */
3683 x
->parent
->color
= MEM_BLACK
;
3684 y
->color
= MEM_BLACK
;
3685 x
->parent
->parent
->color
= MEM_RED
;
3686 x
= x
->parent
->parent
;
3690 /* Parent and uncle have different colors; parent is
3691 red, uncle is black. */
3692 if (x
== x
->parent
->right
)
3695 mem_rotate_left (x
);
3698 x
->parent
->color
= MEM_BLACK
;
3699 x
->parent
->parent
->color
= MEM_RED
;
3700 mem_rotate_right (x
->parent
->parent
);
3705 /* This is the symmetrical case of above. */
3706 struct mem_node
*y
= x
->parent
->parent
->left
;
3708 if (y
->color
== MEM_RED
)
3710 x
->parent
->color
= MEM_BLACK
;
3711 y
->color
= MEM_BLACK
;
3712 x
->parent
->parent
->color
= MEM_RED
;
3713 x
= x
->parent
->parent
;
3717 if (x
== x
->parent
->left
)
3720 mem_rotate_right (x
);
3723 x
->parent
->color
= MEM_BLACK
;
3724 x
->parent
->parent
->color
= MEM_RED
;
3725 mem_rotate_left (x
->parent
->parent
);
3730 /* The root may have been changed to red due to the algorithm. Set
3731 it to black so that property #5 is satisfied. */
3732 mem_root
->color
= MEM_BLACK
;
3743 mem_rotate_left (struct mem_node
*x
)
3747 /* Turn y's left sub-tree into x's right sub-tree. */
3750 if (y
->left
!= MEM_NIL
)
3751 y
->left
->parent
= x
;
3753 /* Y's parent was x's parent. */
3755 y
->parent
= x
->parent
;
3757 /* Get the parent to point to y instead of x. */
3760 if (x
== x
->parent
->left
)
3761 x
->parent
->left
= y
;
3763 x
->parent
->right
= y
;
3768 /* Put x on y's left. */
3782 mem_rotate_right (struct mem_node
*x
)
3784 struct mem_node
*y
= x
->left
;
3787 if (y
->right
!= MEM_NIL
)
3788 y
->right
->parent
= x
;
3791 y
->parent
= x
->parent
;
3794 if (x
== x
->parent
->right
)
3795 x
->parent
->right
= y
;
3797 x
->parent
->left
= y
;
3808 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3811 mem_delete (struct mem_node
*z
)
3813 struct mem_node
*x
, *y
;
3815 if (!z
|| z
== MEM_NIL
)
3818 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3823 while (y
->left
!= MEM_NIL
)
3827 if (y
->left
!= MEM_NIL
)
3832 x
->parent
= y
->parent
;
3835 if (y
== y
->parent
->left
)
3836 y
->parent
->left
= x
;
3838 y
->parent
->right
= x
;
3845 z
->start
= y
->start
;
3850 if (y
->color
== MEM_BLACK
)
3851 mem_delete_fixup (x
);
3853 #ifdef GC_MALLOC_CHECK
3861 /* Re-establish the red-black properties of the tree, after a
3865 mem_delete_fixup (struct mem_node
*x
)
3867 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3869 if (x
== x
->parent
->left
)
3871 struct mem_node
*w
= x
->parent
->right
;
3873 if (w
->color
== MEM_RED
)
3875 w
->color
= MEM_BLACK
;
3876 x
->parent
->color
= MEM_RED
;
3877 mem_rotate_left (x
->parent
);
3878 w
= x
->parent
->right
;
3881 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3888 if (w
->right
->color
== MEM_BLACK
)
3890 w
->left
->color
= MEM_BLACK
;
3892 mem_rotate_right (w
);
3893 w
= x
->parent
->right
;
3895 w
->color
= x
->parent
->color
;
3896 x
->parent
->color
= MEM_BLACK
;
3897 w
->right
->color
= MEM_BLACK
;
3898 mem_rotate_left (x
->parent
);
3904 struct mem_node
*w
= x
->parent
->left
;
3906 if (w
->color
== MEM_RED
)
3908 w
->color
= MEM_BLACK
;
3909 x
->parent
->color
= MEM_RED
;
3910 mem_rotate_right (x
->parent
);
3911 w
= x
->parent
->left
;
3914 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3921 if (w
->left
->color
== MEM_BLACK
)
3923 w
->right
->color
= MEM_BLACK
;
3925 mem_rotate_left (w
);
3926 w
= x
->parent
->left
;
3929 w
->color
= x
->parent
->color
;
3930 x
->parent
->color
= MEM_BLACK
;
3931 w
->left
->color
= MEM_BLACK
;
3932 mem_rotate_right (x
->parent
);
3938 x
->color
= MEM_BLACK
;
3942 /* Value is non-zero if P is a pointer to a live Lisp string on
3943 the heap. M is a pointer to the mem_block for P. */
3946 live_string_p (struct mem_node
*m
, void *p
)
3948 if (m
->type
== MEM_TYPE_STRING
)
3950 struct string_block
*b
= (struct string_block
*) m
->start
;
3951 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3953 /* P must point to the start of a Lisp_String structure, and it
3954 must not be on the free-list. */
3956 && offset
% sizeof b
->strings
[0] == 0
3957 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3958 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3965 /* Value is non-zero if P is a pointer to a live Lisp cons on
3966 the heap. M is a pointer to the mem_block for P. */
3969 live_cons_p (struct mem_node
*m
, void *p
)
3971 if (m
->type
== MEM_TYPE_CONS
)
3973 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3974 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
3976 /* P must point to the start of a Lisp_Cons, not be
3977 one of the unused cells in the current cons block,
3978 and not be on the free-list. */
3980 && offset
% sizeof b
->conses
[0] == 0
3981 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3983 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3984 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3991 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3992 the heap. M is a pointer to the mem_block for P. */
3995 live_symbol_p (struct mem_node
*m
, void *p
)
3997 if (m
->type
== MEM_TYPE_SYMBOL
)
3999 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4000 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
4002 /* P must point to the start of a Lisp_Symbol, not be
4003 one of the unused cells in the current symbol block,
4004 and not be on the free-list. */
4006 && offset
% sizeof b
->symbols
[0] == 0
4007 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4008 && (b
!= symbol_block
4009 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4010 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
4017 /* Value is non-zero if P is a pointer to a live Lisp float on
4018 the heap. M is a pointer to the mem_block for P. */
4021 live_float_p (struct mem_node
*m
, void *p
)
4023 if (m
->type
== MEM_TYPE_FLOAT
)
4025 struct float_block
*b
= (struct float_block
*) m
->start
;
4026 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
4028 /* P must point to the start of a Lisp_Float and not be
4029 one of the unused cells in the current float block. */
4031 && offset
% sizeof b
->floats
[0] == 0
4032 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4033 && (b
!= float_block
4034 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4041 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4042 the heap. M is a pointer to the mem_block for P. */
4045 live_misc_p (struct mem_node
*m
, void *p
)
4047 if (m
->type
== MEM_TYPE_MISC
)
4049 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4050 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4052 /* P must point to the start of a Lisp_Misc, not be
4053 one of the unused cells in the current misc block,
4054 and not be on the free-list. */
4056 && offset
% sizeof b
->markers
[0] == 0
4057 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4058 && (b
!= marker_block
4059 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4060 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4067 /* Value is non-zero if P is a pointer to a live vector-like object.
4068 M is a pointer to the mem_block for P. */
4071 live_vector_p (struct mem_node
*m
, void *p
)
4073 return (p
== m
->start
&& m
->type
== MEM_TYPE_VECTORLIKE
);
4077 /* Value is non-zero if P is a pointer to a live buffer. M is a
4078 pointer to the mem_block for P. */
4081 live_buffer_p (struct mem_node
*m
, void *p
)
4083 /* P must point to the start of the block, and the buffer
4084 must not have been killed. */
4085 return (m
->type
== MEM_TYPE_BUFFER
4087 && !NILP (((struct buffer
*) p
)->BUFFER_INTERNAL_FIELD (name
)));
4090 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4094 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4096 /* Array of objects that are kept alive because the C stack contains
4097 a pattern that looks like a reference to them . */
4099 #define MAX_ZOMBIES 10
4100 static Lisp_Object zombies
[MAX_ZOMBIES
];
4102 /* Number of zombie objects. */
4104 static EMACS_INT nzombies
;
4106 /* Number of garbage collections. */
4108 static EMACS_INT ngcs
;
4110 /* Average percentage of zombies per collection. */
4112 static double avg_zombies
;
4114 /* Max. number of live and zombie objects. */
4116 static EMACS_INT max_live
, max_zombies
;
4118 /* Average number of live objects per GC. */
4120 static double avg_live
;
4122 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4123 doc
: /* Show information about live and zombie objects. */)
4126 Lisp_Object args
[8], zombie_list
= Qnil
;
4128 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4129 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4130 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4131 args
[1] = make_number (ngcs
);
4132 args
[2] = make_float (avg_live
);
4133 args
[3] = make_float (avg_zombies
);
4134 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4135 args
[5] = make_number (max_live
);
4136 args
[6] = make_number (max_zombies
);
4137 args
[7] = zombie_list
;
4138 return Fmessage (8, args
);
4141 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4144 /* Mark OBJ if we can prove it's a Lisp_Object. */
4147 mark_maybe_object (Lisp_Object obj
)
4155 po
= (void *) XPNTR (obj
);
4162 switch (XTYPE (obj
))
4165 mark_p
= (live_string_p (m
, po
)
4166 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4170 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4174 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4178 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4181 case Lisp_Vectorlike
:
4182 /* Note: can't check BUFFERP before we know it's a
4183 buffer because checking that dereferences the pointer
4184 PO which might point anywhere. */
4185 if (live_vector_p (m
, po
))
4186 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4187 else if (live_buffer_p (m
, po
))
4188 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4192 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4201 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4202 if (nzombies
< MAX_ZOMBIES
)
4203 zombies
[nzombies
] = obj
;
4212 /* If P points to Lisp data, mark that as live if it isn't already
4216 mark_maybe_pointer (void *p
)
4220 /* Quickly rule out some values which can't point to Lisp data. */
4223 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4225 2 /* We assume that Lisp data is aligned on even addresses. */
4233 Lisp_Object obj
= Qnil
;
4237 case MEM_TYPE_NON_LISP
:
4238 /* Nothing to do; not a pointer to Lisp memory. */
4241 case MEM_TYPE_BUFFER
:
4242 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4243 XSETVECTOR (obj
, p
);
4247 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4251 case MEM_TYPE_STRING
:
4252 if (live_string_p (m
, p
)
4253 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4254 XSETSTRING (obj
, p
);
4258 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4262 case MEM_TYPE_SYMBOL
:
4263 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4264 XSETSYMBOL (obj
, p
);
4267 case MEM_TYPE_FLOAT
:
4268 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4272 case MEM_TYPE_VECTORLIKE
:
4273 if (live_vector_p (m
, p
))
4276 XSETVECTOR (tem
, p
);
4277 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4292 /* Alignment of pointer values. Use offsetof, as it sometimes returns
4293 a smaller alignment than GCC's __alignof__ and mark_memory might
4294 miss objects if __alignof__ were used. */
4295 #define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
4297 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4298 not suffice, which is the typical case. A host where a Lisp_Object is
4299 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4300 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4301 suffice to widen it to to a Lisp_Object and check it that way. */
4302 #if defined USE_LSB_TAG || VAL_MAX < UINTPTR_MAX
4303 # if !defined USE_LSB_TAG && VAL_MAX < UINTPTR_MAX >> GCTYPEBITS
4304 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4305 nor mark_maybe_object can follow the pointers. This should not occur on
4306 any practical porting target. */
4307 # error "MSB type bits straddle pointer-word boundaries"
4309 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4310 pointer words that hold pointers ORed with type bits. */
4311 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4313 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4314 words that hold unmodified pointers. */
4315 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4318 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4319 or END+OFFSET..START. */
4322 mark_memory (void *start
, void *end
)
4327 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4331 /* Make START the pointer to the start of the memory region,
4332 if it isn't already. */
4340 /* Mark Lisp data pointed to. This is necessary because, in some
4341 situations, the C compiler optimizes Lisp objects away, so that
4342 only a pointer to them remains. Example:
4344 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4347 Lisp_Object obj = build_string ("test");
4348 struct Lisp_String *s = XSTRING (obj);
4349 Fgarbage_collect ();
4350 fprintf (stderr, "test `%s'\n", s->data);
4354 Here, `obj' isn't really used, and the compiler optimizes it
4355 away. The only reference to the life string is through the
4358 for (pp
= start
; (void *) pp
< end
; pp
++)
4359 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4361 void *p
= *(void **) ((char *) pp
+ i
);
4362 mark_maybe_pointer (p
);
4363 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4364 mark_maybe_object (widen_to_Lisp_Object (p
));
4368 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4369 the GCC system configuration. In gcc 3.2, the only systems for
4370 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4371 by others?) and ns32k-pc532-min. */
4373 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4375 static int setjmp_tested_p
, longjmps_done
;
4377 #define SETJMP_WILL_LIKELY_WORK "\
4379 Emacs garbage collector has been changed to use conservative stack\n\
4380 marking. Emacs has determined that the method it uses to do the\n\
4381 marking will likely work on your system, but this isn't sure.\n\
4383 If you are a system-programmer, or can get the help of a local wizard\n\
4384 who is, please take a look at the function mark_stack in alloc.c, and\n\
4385 verify that the methods used are appropriate for your system.\n\
4387 Please mail the result to <emacs-devel@gnu.org>.\n\
4390 #define SETJMP_WILL_NOT_WORK "\
4392 Emacs garbage collector has been changed to use conservative stack\n\
4393 marking. Emacs has determined that the default method it uses to do the\n\
4394 marking will not work on your system. We will need a system-dependent\n\
4395 solution for your system.\n\
4397 Please take a look at the function mark_stack in alloc.c, and\n\
4398 try to find a way to make it work on your system.\n\
4400 Note that you may get false negatives, depending on the compiler.\n\
4401 In particular, you need to use -O with GCC for this test.\n\
4403 Please mail the result to <emacs-devel@gnu.org>.\n\
4407 /* Perform a quick check if it looks like setjmp saves registers in a
4408 jmp_buf. Print a message to stderr saying so. When this test
4409 succeeds, this is _not_ a proof that setjmp is sufficient for
4410 conservative stack marking. Only the sources or a disassembly
4421 /* Arrange for X to be put in a register. */
4427 if (longjmps_done
== 1)
4429 /* Came here after the longjmp at the end of the function.
4431 If x == 1, the longjmp has restored the register to its
4432 value before the setjmp, and we can hope that setjmp
4433 saves all such registers in the jmp_buf, although that
4436 For other values of X, either something really strange is
4437 taking place, or the setjmp just didn't save the register. */
4440 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4443 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4450 if (longjmps_done
== 1)
4454 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4457 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4459 /* Abort if anything GCPRO'd doesn't survive the GC. */
4467 for (p
= gcprolist
; p
; p
= p
->next
)
4468 for (i
= 0; i
< p
->nvars
; ++i
)
4469 if (!survives_gc_p (p
->var
[i
]))
4470 /* FIXME: It's not necessarily a bug. It might just be that the
4471 GCPRO is unnecessary or should release the object sooner. */
4475 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4482 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4483 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4485 fprintf (stderr
, " %d = ", i
);
4486 debug_print (zombies
[i
]);
4490 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4493 /* Mark live Lisp objects on the C stack.
4495 There are several system-dependent problems to consider when
4496 porting this to new architectures:
4500 We have to mark Lisp objects in CPU registers that can hold local
4501 variables or are used to pass parameters.
4503 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4504 something that either saves relevant registers on the stack, or
4505 calls mark_maybe_object passing it each register's contents.
4507 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4508 implementation assumes that calling setjmp saves registers we need
4509 to see in a jmp_buf which itself lies on the stack. This doesn't
4510 have to be true! It must be verified for each system, possibly
4511 by taking a look at the source code of setjmp.
4513 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4514 can use it as a machine independent method to store all registers
4515 to the stack. In this case the macros described in the previous
4516 two paragraphs are not used.
4520 Architectures differ in the way their processor stack is organized.
4521 For example, the stack might look like this
4524 | Lisp_Object | size = 4
4526 | something else | size = 2
4528 | Lisp_Object | size = 4
4532 In such a case, not every Lisp_Object will be aligned equally. To
4533 find all Lisp_Object on the stack it won't be sufficient to walk
4534 the stack in steps of 4 bytes. Instead, two passes will be
4535 necessary, one starting at the start of the stack, and a second
4536 pass starting at the start of the stack + 2. Likewise, if the
4537 minimal alignment of Lisp_Objects on the stack is 1, four passes
4538 would be necessary, each one starting with one byte more offset
4539 from the stack start. */
4546 #ifdef HAVE___BUILTIN_UNWIND_INIT
4547 /* Force callee-saved registers and register windows onto the stack.
4548 This is the preferred method if available, obviating the need for
4549 machine dependent methods. */
4550 __builtin_unwind_init ();
4552 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4553 #ifndef GC_SAVE_REGISTERS_ON_STACK
4554 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4555 union aligned_jmpbuf
{
4559 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4561 /* This trick flushes the register windows so that all the state of
4562 the process is contained in the stack. */
4563 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4564 needed on ia64 too. See mach_dep.c, where it also says inline
4565 assembler doesn't work with relevant proprietary compilers. */
4567 #if defined (__sparc64__) && defined (__FreeBSD__)
4568 /* FreeBSD does not have a ta 3 handler. */
4575 /* Save registers that we need to see on the stack. We need to see
4576 registers used to hold register variables and registers used to
4578 #ifdef GC_SAVE_REGISTERS_ON_STACK
4579 GC_SAVE_REGISTERS_ON_STACK (end
);
4580 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4582 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4583 setjmp will definitely work, test it
4584 and print a message with the result
4586 if (!setjmp_tested_p
)
4588 setjmp_tested_p
= 1;
4591 #endif /* GC_SETJMP_WORKS */
4594 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4595 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4596 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4598 /* This assumes that the stack is a contiguous region in memory. If
4599 that's not the case, something has to be done here to iterate
4600 over the stack segments. */
4601 mark_memory (stack_base
, end
);
4603 /* Allow for marking a secondary stack, like the register stack on the
4605 #ifdef GC_MARK_SECONDARY_STACK
4606 GC_MARK_SECONDARY_STACK ();
4609 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4614 #endif /* GC_MARK_STACK != 0 */
4617 /* Determine whether it is safe to access memory at address P. */
4619 valid_pointer_p (void *p
)
4622 return w32_valid_pointer_p (p
, 16);
4626 /* Obviously, we cannot just access it (we would SEGV trying), so we
4627 trick the o/s to tell us whether p is a valid pointer.
4628 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4629 not validate p in that case. */
4633 int valid
= (emacs_write (fd
[1], (char *) p
, 16) == 16);
4634 emacs_close (fd
[1]);
4635 emacs_close (fd
[0]);
4643 /* Return 1 if OBJ is a valid lisp object.
4644 Return 0 if OBJ is NOT a valid lisp object.
4645 Return -1 if we cannot validate OBJ.
4646 This function can be quite slow,
4647 so it should only be used in code for manual debugging. */
4650 valid_lisp_object_p (Lisp_Object obj
)
4660 p
= (void *) XPNTR (obj
);
4661 if (PURE_POINTER_P (p
))
4665 return valid_pointer_p (p
);
4672 int valid
= valid_pointer_p (p
);
4684 case MEM_TYPE_NON_LISP
:
4687 case MEM_TYPE_BUFFER
:
4688 return live_buffer_p (m
, p
);
4691 return live_cons_p (m
, p
);
4693 case MEM_TYPE_STRING
:
4694 return live_string_p (m
, p
);
4697 return live_misc_p (m
, p
);
4699 case MEM_TYPE_SYMBOL
:
4700 return live_symbol_p (m
, p
);
4702 case MEM_TYPE_FLOAT
:
4703 return live_float_p (m
, p
);
4705 case MEM_TYPE_VECTORLIKE
:
4706 return live_vector_p (m
, p
);
4719 /***********************************************************************
4720 Pure Storage Management
4721 ***********************************************************************/
4723 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4724 pointer to it. TYPE is the Lisp type for which the memory is
4725 allocated. TYPE < 0 means it's not used for a Lisp object. */
4728 pure_alloc (size_t size
, int type
)
4732 size_t alignment
= (1 << GCTYPEBITS
);
4734 size_t alignment
= sizeof (EMACS_INT
);
4736 /* Give Lisp_Floats an extra alignment. */
4737 if (type
== Lisp_Float
)
4739 #if defined __GNUC__ && __GNUC__ >= 2
4740 alignment
= __alignof (struct Lisp_Float
);
4742 alignment
= sizeof (struct Lisp_Float
);
4750 /* Allocate space for a Lisp object from the beginning of the free
4751 space with taking account of alignment. */
4752 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4753 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4757 /* Allocate space for a non-Lisp object from the end of the free
4759 pure_bytes_used_non_lisp
+= size
;
4760 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4762 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4764 if (pure_bytes_used
<= pure_size
)
4767 /* Don't allocate a large amount here,
4768 because it might get mmap'd and then its address
4769 might not be usable. */
4770 purebeg
= (char *) xmalloc (10000);
4772 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4773 pure_bytes_used
= 0;
4774 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4779 /* Print a warning if PURESIZE is too small. */
4782 check_pure_size (void)
4784 if (pure_bytes_used_before_overflow
)
4785 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4787 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4791 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4792 the non-Lisp data pool of the pure storage, and return its start
4793 address. Return NULL if not found. */
4796 find_string_data_in_pure (const char *data
, ptrdiff_t nbytes
)
4799 ptrdiff_t skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4800 const unsigned char *p
;
4803 if (pure_bytes_used_non_lisp
<= nbytes
)
4806 /* Set up the Boyer-Moore table. */
4808 for (i
= 0; i
< 256; i
++)
4811 p
= (const unsigned char *) data
;
4813 bm_skip
[*p
++] = skip
;
4815 last_char_skip
= bm_skip
['\0'];
4817 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4818 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4820 /* See the comments in the function `boyer_moore' (search.c) for the
4821 use of `infinity'. */
4822 infinity
= pure_bytes_used_non_lisp
+ 1;
4823 bm_skip
['\0'] = infinity
;
4825 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4829 /* Check the last character (== '\0'). */
4832 start
+= bm_skip
[*(p
+ start
)];
4834 while (start
<= start_max
);
4836 if (start
< infinity
)
4837 /* Couldn't find the last character. */
4840 /* No less than `infinity' means we could find the last
4841 character at `p[start - infinity]'. */
4844 /* Check the remaining characters. */
4845 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4847 return non_lisp_beg
+ start
;
4849 start
+= last_char_skip
;
4851 while (start
<= start_max
);
4857 /* Return a string allocated in pure space. DATA is a buffer holding
4858 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4859 non-zero means make the result string multibyte.
4861 Must get an error if pure storage is full, since if it cannot hold
4862 a large string it may be able to hold conses that point to that
4863 string; then the string is not protected from gc. */
4866 make_pure_string (const char *data
,
4867 ptrdiff_t nchars
, ptrdiff_t nbytes
, int multibyte
)
4870 struct Lisp_String
*s
;
4872 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4873 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4874 if (s
->data
== NULL
)
4876 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4877 memcpy (s
->data
, data
, nbytes
);
4878 s
->data
[nbytes
] = '\0';
4881 s
->size_byte
= multibyte
? nbytes
: -1;
4882 s
->intervals
= NULL_INTERVAL
;
4883 XSETSTRING (string
, s
);
4887 /* Return a string a string allocated in pure space. Do not allocate
4888 the string data, just point to DATA. */
4891 make_pure_c_string (const char *data
)
4894 struct Lisp_String
*s
;
4895 ptrdiff_t nchars
= strlen (data
);
4897 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4900 s
->data
= (unsigned char *) data
;
4901 s
->intervals
= NULL_INTERVAL
;
4902 XSETSTRING (string
, s
);
4906 /* Return a cons allocated from pure space. Give it pure copies
4907 of CAR as car and CDR as cdr. */
4910 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4912 register Lisp_Object
new;
4913 struct Lisp_Cons
*p
;
4915 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4917 XSETCAR (new, Fpurecopy (car
));
4918 XSETCDR (new, Fpurecopy (cdr
));
4923 /* Value is a float object with value NUM allocated from pure space. */
4926 make_pure_float (double num
)
4928 register Lisp_Object
new;
4929 struct Lisp_Float
*p
;
4931 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4933 XFLOAT_INIT (new, num
);
4938 /* Return a vector with room for LEN Lisp_Objects allocated from
4942 make_pure_vector (ptrdiff_t len
)
4945 struct Lisp_Vector
*p
;
4946 size_t size
= (offsetof (struct Lisp_Vector
, contents
)
4947 + len
* sizeof (Lisp_Object
));
4949 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4950 XSETVECTOR (new, p
);
4951 XVECTOR (new)->header
.size
= len
;
4956 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4957 doc
: /* Make a copy of object OBJ in pure storage.
4958 Recursively copies contents of vectors and cons cells.
4959 Does not copy symbols. Copies strings without text properties. */)
4960 (register Lisp_Object obj
)
4962 if (NILP (Vpurify_flag
))
4965 if (PURE_POINTER_P (XPNTR (obj
)))
4968 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4970 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
4976 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
4977 else if (FLOATP (obj
))
4978 obj
= make_pure_float (XFLOAT_DATA (obj
));
4979 else if (STRINGP (obj
))
4980 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
4982 STRING_MULTIBYTE (obj
));
4983 else if (COMPILEDP (obj
) || VECTORP (obj
))
4985 register struct Lisp_Vector
*vec
;
4986 register ptrdiff_t i
;
4990 if (size
& PSEUDOVECTOR_FLAG
)
4991 size
&= PSEUDOVECTOR_SIZE_MASK
;
4992 vec
= XVECTOR (make_pure_vector (size
));
4993 for (i
= 0; i
< size
; i
++)
4994 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4995 if (COMPILEDP (obj
))
4997 XSETPVECTYPE (vec
, PVEC_COMPILED
);
4998 XSETCOMPILED (obj
, vec
);
5001 XSETVECTOR (obj
, vec
);
5003 else if (MARKERP (obj
))
5004 error ("Attempt to copy a marker to pure storage");
5006 /* Not purified, don't hash-cons. */
5009 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
5010 Fputhash (obj
, obj
, Vpurify_flag
);
5017 /***********************************************************************
5019 ***********************************************************************/
5021 /* Put an entry in staticvec, pointing at the variable with address
5025 staticpro (Lisp_Object
*varaddress
)
5027 staticvec
[staticidx
++] = varaddress
;
5028 if (staticidx
>= NSTATICS
)
5033 /***********************************************************************
5035 ***********************************************************************/
5037 /* Temporarily prevent garbage collection. */
5040 inhibit_garbage_collection (void)
5042 ptrdiff_t count
= SPECPDL_INDEX ();
5044 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5049 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5050 doc
: /* Reclaim storage for Lisp objects no longer needed.
5051 Garbage collection happens automatically if you cons more than
5052 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5053 `garbage-collect' normally returns a list with info on amount of space in use:
5054 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
5055 (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS
5056 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
5057 (USED-STRINGS . FREE-STRINGS))
5058 However, if there was overflow in pure space, `garbage-collect'
5059 returns nil, because real GC can't be done.
5060 See Info node `(elisp)Garbage Collection'. */)
5063 register struct specbinding
*bind
;
5064 char stack_top_variable
;
5067 Lisp_Object total
[8];
5068 ptrdiff_t count
= SPECPDL_INDEX ();
5069 EMACS_TIME t1
, t2
, t3
;
5074 /* Can't GC if pure storage overflowed because we can't determine
5075 if something is a pure object or not. */
5076 if (pure_bytes_used_before_overflow
)
5081 /* Don't keep undo information around forever.
5082 Do this early on, so it is no problem if the user quits. */
5084 register struct buffer
*nextb
= all_buffers
;
5088 /* If a buffer's undo list is Qt, that means that undo is
5089 turned off in that buffer. Calling truncate_undo_list on
5090 Qt tends to return NULL, which effectively turns undo back on.
5091 So don't call truncate_undo_list if undo_list is Qt. */
5092 if (! NILP (nextb
->BUFFER_INTERNAL_FIELD (name
)) && ! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5093 truncate_undo_list (nextb
);
5095 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5096 if (nextb
->base_buffer
== 0 && !NILP (nextb
->BUFFER_INTERNAL_FIELD (name
))
5097 && ! nextb
->text
->inhibit_shrinking
)
5099 /* If a buffer's gap size is more than 10% of the buffer
5100 size, or larger than 2000 bytes, then shrink it
5101 accordingly. Keep a minimum size of 20 bytes. */
5102 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
5104 if (nextb
->text
->gap_size
> size
)
5106 struct buffer
*save_current
= current_buffer
;
5107 current_buffer
= nextb
;
5108 make_gap (-(nextb
->text
->gap_size
- size
));
5109 current_buffer
= save_current
;
5113 nextb
= nextb
->header
.next
.buffer
;
5117 EMACS_GET_TIME (t1
);
5119 /* In case user calls debug_print during GC,
5120 don't let that cause a recursive GC. */
5121 consing_since_gc
= 0;
5123 /* Save what's currently displayed in the echo area. */
5124 message_p
= push_message ();
5125 record_unwind_protect (pop_message_unwind
, Qnil
);
5127 /* Save a copy of the contents of the stack, for debugging. */
5128 #if MAX_SAVE_STACK > 0
5129 if (NILP (Vpurify_flag
))
5132 ptrdiff_t stack_size
;
5133 if (&stack_top_variable
< stack_bottom
)
5135 stack
= &stack_top_variable
;
5136 stack_size
= stack_bottom
- &stack_top_variable
;
5140 stack
= stack_bottom
;
5141 stack_size
= &stack_top_variable
- stack_bottom
;
5143 if (stack_size
<= MAX_SAVE_STACK
)
5145 if (stack_copy_size
< stack_size
)
5147 stack_copy
= (char *) xrealloc (stack_copy
, stack_size
);
5148 stack_copy_size
= stack_size
;
5150 memcpy (stack_copy
, stack
, stack_size
);
5153 #endif /* MAX_SAVE_STACK > 0 */
5155 if (garbage_collection_messages
)
5156 message1_nolog ("Garbage collecting...");
5160 shrink_regexp_cache ();
5164 /* clear_marks (); */
5166 /* Mark all the special slots that serve as the roots of accessibility. */
5168 for (i
= 0; i
< staticidx
; i
++)
5169 mark_object (*staticvec
[i
]);
5171 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5173 mark_object (bind
->symbol
);
5174 mark_object (bind
->old_value
);
5182 extern void xg_mark_data (void);
5187 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5188 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5192 register struct gcpro
*tail
;
5193 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5194 for (i
= 0; i
< tail
->nvars
; i
++)
5195 mark_object (tail
->var
[i
]);
5199 struct catchtag
*catch;
5200 struct handler
*handler
;
5202 for (catch = catchlist
; catch; catch = catch->next
)
5204 mark_object (catch->tag
);
5205 mark_object (catch->val
);
5207 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5209 mark_object (handler
->handler
);
5210 mark_object (handler
->var
);
5216 #ifdef HAVE_WINDOW_SYSTEM
5217 mark_fringe_data ();
5220 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5224 /* Everything is now marked, except for the things that require special
5225 finalization, i.e. the undo_list.
5226 Look thru every buffer's undo list
5227 for elements that update markers that were not marked,
5230 register struct buffer
*nextb
= all_buffers
;
5234 /* If a buffer's undo list is Qt, that means that undo is
5235 turned off in that buffer. Calling truncate_undo_list on
5236 Qt tends to return NULL, which effectively turns undo back on.
5237 So don't call truncate_undo_list if undo_list is Qt. */
5238 if (! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5240 Lisp_Object tail
, prev
;
5241 tail
= nextb
->BUFFER_INTERNAL_FIELD (undo_list
);
5243 while (CONSP (tail
))
5245 if (CONSP (XCAR (tail
))
5246 && MARKERP (XCAR (XCAR (tail
)))
5247 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5250 nextb
->BUFFER_INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5254 XSETCDR (prev
, tail
);
5264 /* Now that we have stripped the elements that need not be in the
5265 undo_list any more, we can finally mark the list. */
5266 mark_object (nextb
->BUFFER_INTERNAL_FIELD (undo_list
));
5268 nextb
= nextb
->header
.next
.buffer
;
5274 /* Clear the mark bits that we set in certain root slots. */
5276 unmark_byte_stack ();
5277 VECTOR_UNMARK (&buffer_defaults
);
5278 VECTOR_UNMARK (&buffer_local_symbols
);
5280 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5288 /* clear_marks (); */
5291 consing_since_gc
= 0;
5292 if (gc_cons_threshold
< 10000)
5293 gc_cons_threshold
= 10000;
5295 gc_relative_threshold
= 0;
5296 if (FLOATP (Vgc_cons_percentage
))
5297 { /* Set gc_cons_combined_threshold. */
5300 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5301 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5302 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5303 tot
+= total_string_size
;
5304 tot
+= total_vector_size
* sizeof (Lisp_Object
);
5305 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5306 tot
+= total_intervals
* sizeof (struct interval
);
5307 tot
+= total_strings
* sizeof (struct Lisp_String
);
5309 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5312 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5313 gc_relative_threshold
= tot
;
5315 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5319 if (garbage_collection_messages
)
5321 if (message_p
|| minibuf_level
> 0)
5324 message1_nolog ("Garbage collecting...done");
5327 unbind_to (count
, Qnil
);
5329 total
[0] = Fcons (make_number (total_conses
),
5330 make_number (total_free_conses
));
5331 total
[1] = Fcons (make_number (total_symbols
),
5332 make_number (total_free_symbols
));
5333 total
[2] = Fcons (make_number (total_markers
),
5334 make_number (total_free_markers
));
5335 total
[3] = make_number (total_string_size
);
5336 total
[4] = make_number (total_vector_size
);
5337 total
[5] = Fcons (make_number (total_floats
),
5338 make_number (total_free_floats
));
5339 total
[6] = Fcons (make_number (total_intervals
),
5340 make_number (total_free_intervals
));
5341 total
[7] = Fcons (make_number (total_strings
),
5342 make_number (total_free_strings
));
5344 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5346 /* Compute average percentage of zombies. */
5349 for (i
= 0; i
< 7; ++i
)
5350 if (CONSP (total
[i
]))
5351 nlive
+= XFASTINT (XCAR (total
[i
]));
5353 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5354 max_live
= max (nlive
, max_live
);
5355 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5356 max_zombies
= max (nzombies
, max_zombies
);
5361 if (!NILP (Vpost_gc_hook
))
5363 ptrdiff_t gc_count
= inhibit_garbage_collection ();
5364 safe_run_hooks (Qpost_gc_hook
);
5365 unbind_to (gc_count
, Qnil
);
5368 /* Accumulate statistics. */
5369 EMACS_GET_TIME (t2
);
5370 EMACS_SUB_TIME (t3
, t2
, t1
);
5371 if (FLOATP (Vgc_elapsed
))
5372 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5374 EMACS_USECS (t3
) * 1.0e-6);
5377 return Flist (sizeof total
/ sizeof *total
, total
);
5381 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5382 only interesting objects referenced from glyphs are strings. */
5385 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5387 struct glyph_row
*row
= matrix
->rows
;
5388 struct glyph_row
*end
= row
+ matrix
->nrows
;
5390 for (; row
< end
; ++row
)
5394 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5396 struct glyph
*glyph
= row
->glyphs
[area
];
5397 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5399 for (; glyph
< end_glyph
; ++glyph
)
5400 if (STRINGP (glyph
->object
)
5401 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5402 mark_object (glyph
->object
);
5408 /* Mark Lisp faces in the face cache C. */
5411 mark_face_cache (struct face_cache
*c
)
5416 for (i
= 0; i
< c
->used
; ++i
)
5418 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5422 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5423 mark_object (face
->lface
[j
]);
5431 /* Mark reference to a Lisp_Object.
5432 If the object referred to has not been seen yet, recursively mark
5433 all the references contained in it. */
5435 #define LAST_MARKED_SIZE 500
5436 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5437 static int last_marked_index
;
5439 /* For debugging--call abort when we cdr down this many
5440 links of a list, in mark_object. In debugging,
5441 the call to abort will hit a breakpoint.
5442 Normally this is zero and the check never goes off. */
5443 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5446 mark_vectorlike (struct Lisp_Vector
*ptr
)
5448 ptrdiff_t size
= ptr
->header
.size
;
5451 eassert (!VECTOR_MARKED_P (ptr
));
5452 VECTOR_MARK (ptr
); /* Else mark it */
5453 if (size
& PSEUDOVECTOR_FLAG
)
5454 size
&= PSEUDOVECTOR_SIZE_MASK
;
5456 /* Note that this size is not the memory-footprint size, but only
5457 the number of Lisp_Object fields that we should trace.
5458 The distinction is used e.g. by Lisp_Process which places extra
5459 non-Lisp_Object fields at the end of the structure. */
5460 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5461 mark_object (ptr
->contents
[i
]);
5464 /* Like mark_vectorlike but optimized for char-tables (and
5465 sub-char-tables) assuming that the contents are mostly integers or
5469 mark_char_table (struct Lisp_Vector
*ptr
)
5471 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5474 eassert (!VECTOR_MARKED_P (ptr
));
5476 for (i
= 0; i
< size
; i
++)
5478 Lisp_Object val
= ptr
->contents
[i
];
5480 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5482 if (SUB_CHAR_TABLE_P (val
))
5484 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5485 mark_char_table (XVECTOR (val
));
5493 mark_object (Lisp_Object arg
)
5495 register Lisp_Object obj
= arg
;
5496 #ifdef GC_CHECK_MARKED_OBJECTS
5500 ptrdiff_t cdr_count
= 0;
5504 if (PURE_POINTER_P (XPNTR (obj
)))
5507 last_marked
[last_marked_index
++] = obj
;
5508 if (last_marked_index
== LAST_MARKED_SIZE
)
5509 last_marked_index
= 0;
5511 /* Perform some sanity checks on the objects marked here. Abort if
5512 we encounter an object we know is bogus. This increases GC time
5513 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5514 #ifdef GC_CHECK_MARKED_OBJECTS
5516 po
= (void *) XPNTR (obj
);
5518 /* Check that the object pointed to by PO is known to be a Lisp
5519 structure allocated from the heap. */
5520 #define CHECK_ALLOCATED() \
5522 m = mem_find (po); \
5527 /* Check that the object pointed to by PO is live, using predicate
5529 #define CHECK_LIVE(LIVEP) \
5531 if (!LIVEP (m, po)) \
5535 /* Check both of the above conditions. */
5536 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5538 CHECK_ALLOCATED (); \
5539 CHECK_LIVE (LIVEP); \
5542 #else /* not GC_CHECK_MARKED_OBJECTS */
5544 #define CHECK_LIVE(LIVEP) (void) 0
5545 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5547 #endif /* not GC_CHECK_MARKED_OBJECTS */
5549 switch (SWITCH_ENUM_CAST (XTYPE (obj
)))
5553 register struct Lisp_String
*ptr
= XSTRING (obj
);
5554 if (STRING_MARKED_P (ptr
))
5556 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5557 MARK_INTERVAL_TREE (ptr
->intervals
);
5559 #ifdef GC_CHECK_STRING_BYTES
5560 /* Check that the string size recorded in the string is the
5561 same as the one recorded in the sdata structure. */
5562 CHECK_STRING_BYTES (ptr
);
5563 #endif /* GC_CHECK_STRING_BYTES */
5567 case Lisp_Vectorlike
:
5568 if (VECTOR_MARKED_P (XVECTOR (obj
)))
5570 #ifdef GC_CHECK_MARKED_OBJECTS
5572 if (m
== MEM_NIL
&& !SUBRP (obj
)
5573 && po
!= &buffer_defaults
5574 && po
!= &buffer_local_symbols
)
5576 #endif /* GC_CHECK_MARKED_OBJECTS */
5580 #ifdef GC_CHECK_MARKED_OBJECTS
5581 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5584 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->header
.next
.buffer
)
5589 #endif /* GC_CHECK_MARKED_OBJECTS */
5592 else if (SUBRP (obj
))
5594 else if (COMPILEDP (obj
))
5595 /* We could treat this just like a vector, but it is better to
5596 save the COMPILED_CONSTANTS element for last and avoid
5599 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5600 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5603 CHECK_LIVE (live_vector_p
);
5604 VECTOR_MARK (ptr
); /* Else mark it */
5605 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5607 if (i
!= COMPILED_CONSTANTS
)
5608 mark_object (ptr
->contents
[i
]);
5610 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5613 else if (FRAMEP (obj
))
5615 register struct frame
*ptr
= XFRAME (obj
);
5616 mark_vectorlike (XVECTOR (obj
));
5617 mark_face_cache (ptr
->face_cache
);
5619 else if (WINDOWP (obj
))
5621 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5622 struct window
*w
= XWINDOW (obj
);
5623 mark_vectorlike (ptr
);
5624 /* Mark glyphs for leaf windows. Marking window matrices is
5625 sufficient because frame matrices use the same glyph
5627 if (NILP (w
->hchild
)
5629 && w
->current_matrix
)
5631 mark_glyph_matrix (w
->current_matrix
);
5632 mark_glyph_matrix (w
->desired_matrix
);
5635 else if (HASH_TABLE_P (obj
))
5637 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5638 mark_vectorlike ((struct Lisp_Vector
*)h
);
5639 /* If hash table is not weak, mark all keys and values.
5640 For weak tables, mark only the vector. */
5642 mark_object (h
->key_and_value
);
5644 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5646 else if (CHAR_TABLE_P (obj
))
5647 mark_char_table (XVECTOR (obj
));
5649 mark_vectorlike (XVECTOR (obj
));
5654 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5655 struct Lisp_Symbol
*ptrx
;
5659 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5661 mark_object (ptr
->function
);
5662 mark_object (ptr
->plist
);
5663 switch (ptr
->redirect
)
5665 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5666 case SYMBOL_VARALIAS
:
5669 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5673 case SYMBOL_LOCALIZED
:
5675 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5676 /* If the value is forwarded to a buffer or keyboard field,
5677 these are marked when we see the corresponding object.
5678 And if it's forwarded to a C variable, either it's not
5679 a Lisp_Object var, or it's staticpro'd already. */
5680 mark_object (blv
->where
);
5681 mark_object (blv
->valcell
);
5682 mark_object (blv
->defcell
);
5685 case SYMBOL_FORWARDED
:
5686 /* If the value is forwarded to a buffer or keyboard field,
5687 these are marked when we see the corresponding object.
5688 And if it's forwarded to a C variable, either it's not
5689 a Lisp_Object var, or it's staticpro'd already. */
5693 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5694 MARK_STRING (XSTRING (ptr
->xname
));
5695 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5700 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5701 XSETSYMBOL (obj
, ptrx
);
5708 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5709 if (XMISCANY (obj
)->gcmarkbit
)
5711 XMISCANY (obj
)->gcmarkbit
= 1;
5713 switch (XMISCTYPE (obj
))
5716 case Lisp_Misc_Marker
:
5717 /* DO NOT mark thru the marker's chain.
5718 The buffer's markers chain does not preserve markers from gc;
5719 instead, markers are removed from the chain when freed by gc. */
5722 case Lisp_Misc_Save_Value
:
5725 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5726 /* If DOGC is set, POINTER is the address of a memory
5727 area containing INTEGER potential Lisp_Objects. */
5730 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5732 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5733 mark_maybe_object (*p
);
5739 case Lisp_Misc_Overlay
:
5741 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5742 mark_object (ptr
->start
);
5743 mark_object (ptr
->end
);
5744 mark_object (ptr
->plist
);
5747 XSETMISC (obj
, ptr
->next
);
5760 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5761 if (CONS_MARKED_P (ptr
))
5763 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5765 /* If the cdr is nil, avoid recursion for the car. */
5766 if (EQ (ptr
->u
.cdr
, Qnil
))
5772 mark_object (ptr
->car
);
5775 if (cdr_count
== mark_object_loop_halt
)
5781 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5782 FLOAT_MARK (XFLOAT (obj
));
5793 #undef CHECK_ALLOCATED
5794 #undef CHECK_ALLOCATED_AND_LIVE
5797 /* Mark the pointers in a buffer structure. */
5800 mark_buffer (Lisp_Object buf
)
5802 register struct buffer
*buffer
= XBUFFER (buf
);
5803 register Lisp_Object
*ptr
, tmp
;
5804 Lisp_Object base_buffer
;
5806 eassert (!VECTOR_MARKED_P (buffer
));
5807 VECTOR_MARK (buffer
);
5809 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5811 /* For now, we just don't mark the undo_list. It's done later in
5812 a special way just before the sweep phase, and after stripping
5813 some of its elements that are not needed any more. */
5815 if (buffer
->overlays_before
)
5817 XSETMISC (tmp
, buffer
->overlays_before
);
5820 if (buffer
->overlays_after
)
5822 XSETMISC (tmp
, buffer
->overlays_after
);
5826 /* buffer-local Lisp variables start at `undo_list',
5827 tho only the ones from `name' on are GC'd normally. */
5828 for (ptr
= &buffer
->BUFFER_INTERNAL_FIELD (name
);
5829 ptr
<= &PER_BUFFER_VALUE (buffer
,
5830 PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER
));
5834 /* If this is an indirect buffer, mark its base buffer. */
5835 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5837 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5838 mark_buffer (base_buffer
);
5842 /* Mark the Lisp pointers in the terminal objects.
5843 Called by Fgarbage_collect. */
5846 mark_terminals (void)
5849 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5851 eassert (t
->name
!= NULL
);
5852 #ifdef HAVE_WINDOW_SYSTEM
5853 /* If a terminal object is reachable from a stacpro'ed object,
5854 it might have been marked already. Make sure the image cache
5856 mark_image_cache (t
->image_cache
);
5857 #endif /* HAVE_WINDOW_SYSTEM */
5858 if (!VECTOR_MARKED_P (t
))
5859 mark_vectorlike ((struct Lisp_Vector
*)t
);
5865 /* Value is non-zero if OBJ will survive the current GC because it's
5866 either marked or does not need to be marked to survive. */
5869 survives_gc_p (Lisp_Object obj
)
5873 switch (XTYPE (obj
))
5880 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5884 survives_p
= XMISCANY (obj
)->gcmarkbit
;
5888 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5891 case Lisp_Vectorlike
:
5892 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5896 survives_p
= CONS_MARKED_P (XCONS (obj
));
5900 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5907 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5912 /* Sweep: find all structures not marked, and free them. */
5917 /* Remove or mark entries in weak hash tables.
5918 This must be done before any object is unmarked. */
5919 sweep_weak_hash_tables ();
5922 #ifdef GC_CHECK_STRING_BYTES
5923 if (!noninteractive
)
5924 check_string_bytes (1);
5927 /* Put all unmarked conses on free list */
5929 register struct cons_block
*cblk
;
5930 struct cons_block
**cprev
= &cons_block
;
5931 register int lim
= cons_block_index
;
5932 EMACS_INT num_free
= 0, num_used
= 0;
5936 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5940 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
5942 /* Scan the mark bits an int at a time. */
5943 for (i
= 0; i
< ilim
; i
++)
5945 if (cblk
->gcmarkbits
[i
] == -1)
5947 /* Fast path - all cons cells for this int are marked. */
5948 cblk
->gcmarkbits
[i
] = 0;
5949 num_used
+= BITS_PER_INT
;
5953 /* Some cons cells for this int are not marked.
5954 Find which ones, and free them. */
5955 int start
, pos
, stop
;
5957 start
= i
* BITS_PER_INT
;
5959 if (stop
> BITS_PER_INT
)
5960 stop
= BITS_PER_INT
;
5963 for (pos
= start
; pos
< stop
; pos
++)
5965 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
5968 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
5969 cons_free_list
= &cblk
->conses
[pos
];
5971 cons_free_list
->car
= Vdead
;
5977 CONS_UNMARK (&cblk
->conses
[pos
]);
5983 lim
= CONS_BLOCK_SIZE
;
5984 /* If this block contains only free conses and we have already
5985 seen more than two blocks worth of free conses then deallocate
5987 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5989 *cprev
= cblk
->next
;
5990 /* Unhook from the free list. */
5991 cons_free_list
= cblk
->conses
[0].u
.chain
;
5992 lisp_align_free (cblk
);
5996 num_free
+= this_free
;
5997 cprev
= &cblk
->next
;
6000 total_conses
= num_used
;
6001 total_free_conses
= num_free
;
6004 /* Put all unmarked floats on free list */
6006 register struct float_block
*fblk
;
6007 struct float_block
**fprev
= &float_block
;
6008 register int lim
= float_block_index
;
6009 EMACS_INT num_free
= 0, num_used
= 0;
6011 float_free_list
= 0;
6013 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6017 for (i
= 0; i
< lim
; i
++)
6018 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6021 fblk
->floats
[i
].u
.chain
= float_free_list
;
6022 float_free_list
= &fblk
->floats
[i
];
6027 FLOAT_UNMARK (&fblk
->floats
[i
]);
6029 lim
= FLOAT_BLOCK_SIZE
;
6030 /* If this block contains only free floats and we have already
6031 seen more than two blocks worth of free floats then deallocate
6033 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6035 *fprev
= fblk
->next
;
6036 /* Unhook from the free list. */
6037 float_free_list
= fblk
->floats
[0].u
.chain
;
6038 lisp_align_free (fblk
);
6042 num_free
+= this_free
;
6043 fprev
= &fblk
->next
;
6046 total_floats
= num_used
;
6047 total_free_floats
= num_free
;
6050 /* Put all unmarked intervals on free list */
6052 register struct interval_block
*iblk
;
6053 struct interval_block
**iprev
= &interval_block
;
6054 register int lim
= interval_block_index
;
6055 EMACS_INT num_free
= 0, num_used
= 0;
6057 interval_free_list
= 0;
6059 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6064 for (i
= 0; i
< lim
; i
++)
6066 if (!iblk
->intervals
[i
].gcmarkbit
)
6068 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
6069 interval_free_list
= &iblk
->intervals
[i
];
6075 iblk
->intervals
[i
].gcmarkbit
= 0;
6078 lim
= INTERVAL_BLOCK_SIZE
;
6079 /* If this block contains only free intervals and we have already
6080 seen more than two blocks worth of free intervals then
6081 deallocate this block. */
6082 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6084 *iprev
= iblk
->next
;
6085 /* Unhook from the free list. */
6086 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6091 num_free
+= this_free
;
6092 iprev
= &iblk
->next
;
6095 total_intervals
= num_used
;
6096 total_free_intervals
= num_free
;
6099 /* Put all unmarked symbols on free list */
6101 register struct symbol_block
*sblk
;
6102 struct symbol_block
**sprev
= &symbol_block
;
6103 register int lim
= symbol_block_index
;
6104 EMACS_INT num_free
= 0, num_used
= 0;
6106 symbol_free_list
= NULL
;
6108 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6111 union aligned_Lisp_Symbol
*sym
= sblk
->symbols
;
6112 union aligned_Lisp_Symbol
*end
= sym
+ lim
;
6114 for (; sym
< end
; ++sym
)
6116 /* Check if the symbol was created during loadup. In such a case
6117 it might be pointed to by pure bytecode which we don't trace,
6118 so we conservatively assume that it is live. */
6119 int pure_p
= PURE_POINTER_P (XSTRING (sym
->s
.xname
));
6121 if (!sym
->s
.gcmarkbit
&& !pure_p
)
6123 if (sym
->s
.redirect
== SYMBOL_LOCALIZED
)
6124 xfree (SYMBOL_BLV (&sym
->s
));
6125 sym
->s
.next
= symbol_free_list
;
6126 symbol_free_list
= &sym
->s
;
6128 symbol_free_list
->function
= Vdead
;
6136 UNMARK_STRING (XSTRING (sym
->s
.xname
));
6137 sym
->s
.gcmarkbit
= 0;
6141 lim
= SYMBOL_BLOCK_SIZE
;
6142 /* If this block contains only free symbols and we have already
6143 seen more than two blocks worth of free symbols then deallocate
6145 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6147 *sprev
= sblk
->next
;
6148 /* Unhook from the free list. */
6149 symbol_free_list
= sblk
->symbols
[0].s
.next
;
6154 num_free
+= this_free
;
6155 sprev
= &sblk
->next
;
6158 total_symbols
= num_used
;
6159 total_free_symbols
= num_free
;
6162 /* Put all unmarked misc's on free list.
6163 For a marker, first unchain it from the buffer it points into. */
6165 register struct marker_block
*mblk
;
6166 struct marker_block
**mprev
= &marker_block
;
6167 register int lim
= marker_block_index
;
6168 EMACS_INT num_free
= 0, num_used
= 0;
6170 marker_free_list
= 0;
6172 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6177 for (i
= 0; i
< lim
; i
++)
6179 if (!mblk
->markers
[i
].m
.u_any
.gcmarkbit
)
6181 if (mblk
->markers
[i
].m
.u_any
.type
== Lisp_Misc_Marker
)
6182 unchain_marker (&mblk
->markers
[i
].m
.u_marker
);
6183 /* Set the type of the freed object to Lisp_Misc_Free.
6184 We could leave the type alone, since nobody checks it,
6185 but this might catch bugs faster. */
6186 mblk
->markers
[i
].m
.u_marker
.type
= Lisp_Misc_Free
;
6187 mblk
->markers
[i
].m
.u_free
.chain
= marker_free_list
;
6188 marker_free_list
= &mblk
->markers
[i
].m
;
6194 mblk
->markers
[i
].m
.u_any
.gcmarkbit
= 0;
6197 lim
= MARKER_BLOCK_SIZE
;
6198 /* If this block contains only free markers and we have already
6199 seen more than two blocks worth of free markers then deallocate
6201 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6203 *mprev
= mblk
->next
;
6204 /* Unhook from the free list. */
6205 marker_free_list
= mblk
->markers
[0].m
.u_free
.chain
;
6210 num_free
+= this_free
;
6211 mprev
= &mblk
->next
;
6215 total_markers
= num_used
;
6216 total_free_markers
= num_free
;
6219 /* Free all unmarked buffers */
6221 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6224 if (!VECTOR_MARKED_P (buffer
))
6227 prev
->header
.next
= buffer
->header
.next
;
6229 all_buffers
= buffer
->header
.next
.buffer
;
6230 next
= buffer
->header
.next
.buffer
;
6236 VECTOR_UNMARK (buffer
);
6237 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6238 prev
= buffer
, buffer
= buffer
->header
.next
.buffer
;
6242 /* Free all unmarked vectors */
6244 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6245 total_vector_size
= 0;
6248 if (!VECTOR_MARKED_P (vector
))
6251 prev
->header
.next
= vector
->header
.next
;
6253 all_vectors
= vector
->header
.next
.vector
;
6254 next
= vector
->header
.next
.vector
;
6261 VECTOR_UNMARK (vector
);
6262 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
6263 total_vector_size
+= PSEUDOVECTOR_SIZE_MASK
& vector
->header
.size
;
6265 total_vector_size
+= vector
->header
.size
;
6266 prev
= vector
, vector
= vector
->header
.next
.vector
;
6270 #ifdef GC_CHECK_STRING_BYTES
6271 if (!noninteractive
)
6272 check_string_bytes (1);
6279 /* Debugging aids. */
6281 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6282 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6283 This may be helpful in debugging Emacs's memory usage.
6284 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6289 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6294 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6295 doc
: /* Return a list of counters that measure how much consing there has been.
6296 Each of these counters increments for a certain kind of object.
6297 The counters wrap around from the largest positive integer to zero.
6298 Garbage collection does not decrease them.
6299 The elements of the value are as follows:
6300 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6301 All are in units of 1 = one object consed
6302 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6304 MISCS include overlays, markers, and some internal types.
6305 Frames, windows, buffers, and subprocesses count as vectors
6306 (but the contents of a buffer's text do not count here). */)
6309 Lisp_Object consed
[8];
6311 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6312 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6313 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6314 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6315 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6316 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6317 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6318 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6320 return Flist (8, consed
);
6323 /* Find at most FIND_MAX symbols which have OBJ as their value or
6324 function. This is used in gdbinit's `xwhichsymbols' command. */
6327 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6329 struct symbol_block
*sblk
;
6330 ptrdiff_t gc_count
= inhibit_garbage_collection ();
6331 Lisp_Object found
= Qnil
;
6335 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6337 union aligned_Lisp_Symbol
*aligned_sym
= sblk
->symbols
;
6340 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, aligned_sym
++)
6342 struct Lisp_Symbol
*sym
= &aligned_sym
->s
;
6346 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6349 XSETSYMBOL (tem
, sym
);
6350 val
= find_symbol_value (tem
);
6352 || EQ (sym
->function
, obj
)
6353 || (!NILP (sym
->function
)
6354 && COMPILEDP (sym
->function
)
6355 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6358 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6360 found
= Fcons (tem
, found
);
6361 if (--find_max
== 0)
6369 unbind_to (gc_count
, Qnil
);
6373 #ifdef ENABLE_CHECKING
6374 int suppress_checking
;
6377 die (const char *msg
, const char *file
, int line
)
6379 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6385 /* Initialization */
6388 init_alloc_once (void)
6390 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6392 pure_size
= PURESIZE
;
6393 pure_bytes_used
= 0;
6394 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6395 pure_bytes_used_before_overflow
= 0;
6397 /* Initialize the list of free aligned blocks. */
6400 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6402 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6406 ignore_warnings
= 1;
6407 #ifdef DOUG_LEA_MALLOC
6408 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6409 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6410 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6418 init_weak_hash_tables ();
6421 malloc_hysteresis
= 32;
6423 malloc_hysteresis
= 0;
6426 refill_memory_reserve ();
6428 ignore_warnings
= 0;
6430 byte_stack_list
= 0;
6432 consing_since_gc
= 0;
6433 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6434 gc_relative_threshold
= 0;
6441 byte_stack_list
= 0;
6443 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6444 setjmp_tested_p
= longjmps_done
= 0;
6447 Vgc_elapsed
= make_float (0.0);
6452 syms_of_alloc (void)
6454 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6455 doc
: /* Number of bytes of consing between garbage collections.
6456 Garbage collection can happen automatically once this many bytes have been
6457 allocated since the last garbage collection. All data types count.
6459 Garbage collection happens automatically only when `eval' is called.
6461 By binding this temporarily to a large number, you can effectively
6462 prevent garbage collection during a part of the program.
6463 See also `gc-cons-percentage'. */);
6465 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6466 doc
: /* Portion of the heap used for allocation.
6467 Garbage collection can happen automatically once this portion of the heap
6468 has been allocated since the last garbage collection.
6469 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6470 Vgc_cons_percentage
= make_float (0.1);
6472 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6473 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6475 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6476 doc
: /* Number of cons cells that have been consed so far. */);
6478 DEFVAR_INT ("floats-consed", floats_consed
,
6479 doc
: /* Number of floats that have been consed so far. */);
6481 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6482 doc
: /* Number of vector cells that have been consed so far. */);
6484 DEFVAR_INT ("symbols-consed", symbols_consed
,
6485 doc
: /* Number of symbols that have been consed so far. */);
6487 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6488 doc
: /* Number of string characters that have been consed so far. */);
6490 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6491 doc
: /* Number of miscellaneous objects that have been consed so far.
6492 These include markers and overlays, plus certain objects not visible
6495 DEFVAR_INT ("intervals-consed", intervals_consed
,
6496 doc
: /* Number of intervals that have been consed so far. */);
6498 DEFVAR_INT ("strings-consed", strings_consed
,
6499 doc
: /* Number of strings that have been consed so far. */);
6501 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6502 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6503 This means that certain objects should be allocated in shared (pure) space.
6504 It can also be set to a hash-table, in which case this table is used to
6505 do hash-consing of the objects allocated to pure space. */);
6507 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6508 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6509 garbage_collection_messages
= 0;
6511 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6512 doc
: /* Hook run after garbage collection has finished. */);
6513 Vpost_gc_hook
= Qnil
;
6514 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6516 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6517 doc
: /* Precomputed `signal' argument for memory-full error. */);
6518 /* We build this in advance because if we wait until we need it, we might
6519 not be able to allocate the memory to hold it. */
6521 = pure_cons (Qerror
,
6522 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil
));
6524 DEFVAR_LISP ("memory-full", Vmemory_full
,
6525 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6526 Vmemory_full
= Qnil
;
6528 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6529 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6531 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6532 doc
: /* Accumulated time elapsed in garbage collections.
6533 The time is in seconds as a floating point value. */);
6534 DEFVAR_INT ("gcs-done", gcs_done
,
6535 doc
: /* Accumulated number of garbage collections done. */);
6540 defsubr (&Smake_byte_code
);
6541 defsubr (&Smake_list
);
6542 defsubr (&Smake_vector
);
6543 defsubr (&Smake_string
);
6544 defsubr (&Smake_bool_vector
);
6545 defsubr (&Smake_symbol
);
6546 defsubr (&Smake_marker
);
6547 defsubr (&Spurecopy
);
6548 defsubr (&Sgarbage_collect
);
6549 defsubr (&Smemory_limit
);
6550 defsubr (&Smemory_use_counts
);
6552 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6553 defsubr (&Sgc_status
);