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_MALLOC_CHECK defined means perform validity checks of malloc'd
53 memory. Can do this only if using gmalloc.c. */
55 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
56 #undef GC_MALLOC_CHECK
61 extern POINTER_TYPE
*sbrk ();
70 #ifdef DOUG_LEA_MALLOC
74 /* Specify maximum number of areas to mmap. It would be nice to use a
75 value that explicitly means "no limit". */
77 #define MMAP_MAX_AREAS 100000000
79 #else /* not DOUG_LEA_MALLOC */
81 /* The following come from gmalloc.c. */
83 extern size_t _bytes_used
;
84 extern size_t __malloc_extra_blocks
;
86 #endif /* not DOUG_LEA_MALLOC */
88 #if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
91 /* When GTK uses the file chooser dialog, different backends can be loaded
92 dynamically. One such a backend is the Gnome VFS backend that gets loaded
93 if you run Gnome. That backend creates several threads and also allocates
96 Also, gconf and gsettings may create several threads.
98 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
99 functions below are called from malloc, there is a chance that one
100 of these threads preempts the Emacs main thread and the hook variables
101 end up in an inconsistent state. So we have a mutex to prevent that (note
102 that the backend handles concurrent access to malloc within its own threads
103 but Emacs code running in the main thread is not included in that control).
105 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
106 happens in one of the backend threads we will have two threads that tries
107 to run Emacs code at once, and the code is not prepared for that.
108 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
110 static pthread_mutex_t alloc_mutex
;
112 #define BLOCK_INPUT_ALLOC \
115 if (pthread_equal (pthread_self (), main_thread)) \
117 pthread_mutex_lock (&alloc_mutex); \
120 #define UNBLOCK_INPUT_ALLOC \
123 pthread_mutex_unlock (&alloc_mutex); \
124 if (pthread_equal (pthread_self (), main_thread)) \
129 #else /* ! defined HAVE_PTHREAD */
131 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
132 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
134 #endif /* ! defined HAVE_PTHREAD */
135 #endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
137 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
138 to a struct Lisp_String. */
140 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
141 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
142 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
144 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
145 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
146 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
148 /* Value is the number of bytes of S, a pointer to a struct Lisp_String.
149 Be careful during GC, because S->size contains the mark bit for
152 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
154 /* Global variables. */
155 struct emacs_globals globals
;
157 /* Number of bytes of consing done since the last gc. */
159 EMACS_INT consing_since_gc
;
161 /* Similar minimum, computed from Vgc_cons_percentage. */
163 EMACS_INT gc_relative_threshold
;
165 /* Minimum number of bytes of consing since GC before next GC,
166 when memory is full. */
168 EMACS_INT memory_full_cons_threshold
;
170 /* Nonzero during GC. */
174 /* Nonzero means abort if try to GC.
175 This is for code which is written on the assumption that
176 no GC will happen, so as to verify that assumption. */
180 /* Number of live and free conses etc. */
182 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_vector_size
;
183 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
184 static EMACS_INT total_free_floats
, total_floats
;
186 /* Points to memory space allocated as "spare", to be freed if we run
187 out of memory. We keep one large block, four cons-blocks, and
188 two string blocks. */
190 static char *spare_memory
[7];
192 /* Amount of spare memory to keep in large reserve block, or to see
193 whether this much is available when malloc fails on a larger request. */
195 #define SPARE_MEMORY (1 << 14)
197 /* Number of extra blocks malloc should get when it needs more core. */
199 static int malloc_hysteresis
;
201 /* Initialize it to a nonzero value to force it into data space
202 (rather than bss space). That way unexec will remap it into text
203 space (pure), on some systems. We have not implemented the
204 remapping on more recent systems because this is less important
205 nowadays than in the days of small memories and timesharing. */
207 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
208 #define PUREBEG (char *) pure
210 /* Pointer to the pure area, and its size. */
212 static char *purebeg
;
213 static ptrdiff_t pure_size
;
215 /* Number of bytes of pure storage used before pure storage overflowed.
216 If this is non-zero, this implies that an overflow occurred. */
218 static ptrdiff_t pure_bytes_used_before_overflow
;
220 /* Value is non-zero if P points into pure space. */
222 #define PURE_POINTER_P(P) \
223 ((uintptr_t) (P) - (uintptr_t) purebeg <= pure_size)
225 /* Index in pure at which next pure Lisp object will be allocated.. */
227 static EMACS_INT pure_bytes_used_lisp
;
229 /* Number of bytes allocated for non-Lisp objects in pure storage. */
231 static EMACS_INT pure_bytes_used_non_lisp
;
233 /* If nonzero, this is a warning delivered by malloc and not yet
236 const char *pending_malloc_warning
;
238 /* Maximum amount of C stack to save when a GC happens. */
240 #ifndef MAX_SAVE_STACK
241 #define MAX_SAVE_STACK 16000
244 /* Buffer in which we save a copy of the C stack at each GC. */
246 #if MAX_SAVE_STACK > 0
247 static char *stack_copy
;
248 static ptrdiff_t stack_copy_size
;
251 /* Non-zero means ignore malloc warnings. Set during initialization.
252 Currently not used. */
254 static int ignore_warnings
;
256 static Lisp_Object Qgc_cons_threshold
;
257 Lisp_Object Qchar_table_extra_slots
;
259 /* Hook run after GC has finished. */
261 static Lisp_Object Qpost_gc_hook
;
263 static void mark_buffer (Lisp_Object
);
264 static void mark_terminals (void);
265 static void gc_sweep (void);
266 static void mark_glyph_matrix (struct glyph_matrix
*);
267 static void mark_face_cache (struct face_cache
*);
269 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
270 static void refill_memory_reserve (void);
272 static struct Lisp_String
*allocate_string (void);
273 static void compact_small_strings (void);
274 static void free_large_strings (void);
275 static void sweep_strings (void);
276 static void free_misc (Lisp_Object
);
277 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
279 /* When scanning the C stack for live Lisp objects, Emacs keeps track
280 of what memory allocated via lisp_malloc is intended for what
281 purpose. This enumeration specifies the type of memory. */
292 /* We used to keep separate mem_types for subtypes of vectors such as
293 process, hash_table, frame, terminal, and window, but we never made
294 use of the distinction, so it only caused source-code complexity
295 and runtime slowdown. Minor but pointless. */
299 static POINTER_TYPE
*lisp_malloc (size_t, enum mem_type
);
302 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
304 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
305 #include <stdio.h> /* For fprintf. */
308 /* A unique object in pure space used to make some Lisp objects
309 on free lists recognizable in O(1). */
311 static Lisp_Object Vdead
;
312 #define DEADP(x) EQ (x, Vdead)
314 #ifdef GC_MALLOC_CHECK
316 enum mem_type allocated_mem_type
;
317 static int dont_register_blocks
;
319 #endif /* GC_MALLOC_CHECK */
321 /* A node in the red-black tree describing allocated memory containing
322 Lisp data. Each such block is recorded with its start and end
323 address when it is allocated, and removed from the tree when it
326 A red-black tree is a balanced binary tree with the following
329 1. Every node is either red or black.
330 2. Every leaf is black.
331 3. If a node is red, then both of its children are black.
332 4. Every simple path from a node to a descendant leaf contains
333 the same number of black nodes.
334 5. The root is always black.
336 When nodes are inserted into the tree, or deleted from the tree,
337 the tree is "fixed" so that these properties are always true.
339 A red-black tree with N internal nodes has height at most 2
340 log(N+1). Searches, insertions and deletions are done in O(log N).
341 Please see a text book about data structures for a detailed
342 description of red-black trees. Any book worth its salt should
347 /* Children of this node. These pointers are never NULL. When there
348 is no child, the value is MEM_NIL, which points to a dummy node. */
349 struct mem_node
*left
, *right
;
351 /* The parent of this node. In the root node, this is NULL. */
352 struct mem_node
*parent
;
354 /* Start and end of allocated region. */
358 enum {MEM_BLACK
, MEM_RED
} color
;
364 /* Base address of stack. Set in main. */
366 Lisp_Object
*stack_base
;
368 /* Root of the tree describing allocated Lisp memory. */
370 static struct mem_node
*mem_root
;
372 /* Lowest and highest known address in the heap. */
374 static void *min_heap_address
, *max_heap_address
;
376 /* Sentinel node of the tree. */
378 static struct mem_node mem_z
;
379 #define MEM_NIL &mem_z
381 static struct Lisp_Vector
*allocate_vectorlike (EMACS_INT
);
382 static void lisp_free (POINTER_TYPE
*);
383 static void mark_stack (void);
384 static int live_vector_p (struct mem_node
*, void *);
385 static int live_buffer_p (struct mem_node
*, void *);
386 static int live_string_p (struct mem_node
*, void *);
387 static int live_cons_p (struct mem_node
*, void *);
388 static int live_symbol_p (struct mem_node
*, void *);
389 static int live_float_p (struct mem_node
*, void *);
390 static int live_misc_p (struct mem_node
*, void *);
391 static void mark_maybe_object (Lisp_Object
);
392 static void mark_memory (void *, void *);
393 static void mem_init (void);
394 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
395 static void mem_insert_fixup (struct mem_node
*);
396 static void mem_rotate_left (struct mem_node
*);
397 static void mem_rotate_right (struct mem_node
*);
398 static void mem_delete (struct mem_node
*);
399 static void mem_delete_fixup (struct mem_node
*);
400 static inline struct mem_node
*mem_find (void *);
403 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
404 static void check_gcpros (void);
407 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
413 /* Recording what needs to be marked for gc. */
415 struct gcpro
*gcprolist
;
417 /* Addresses of staticpro'd variables. Initialize it to a nonzero
418 value; otherwise some compilers put it into BSS. */
420 #define NSTATICS 0x640
421 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
423 /* Index of next unused slot in staticvec. */
425 static int staticidx
= 0;
427 static POINTER_TYPE
*pure_alloc (size_t, int);
430 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
431 ALIGNMENT must be a power of 2. */
433 #define ALIGN(ptr, ALIGNMENT) \
434 ((POINTER_TYPE *) ((((uintptr_t) (ptr)) + (ALIGNMENT) - 1) \
435 & ~((ALIGNMENT) - 1)))
439 /************************************************************************
441 ************************************************************************/
443 /* Function malloc calls this if it finds we are near exhausting storage. */
446 malloc_warning (const char *str
)
448 pending_malloc_warning
= str
;
452 /* Display an already-pending malloc warning. */
455 display_malloc_warning (void)
457 call3 (intern ("display-warning"),
459 build_string (pending_malloc_warning
),
460 intern ("emergency"));
461 pending_malloc_warning
= 0;
464 /* Called if we can't allocate relocatable space for a buffer. */
467 buffer_memory_full (EMACS_INT nbytes
)
469 /* If buffers use the relocating allocator, no need to free
470 spare_memory, because we may have plenty of malloc space left
471 that we could get, and if we don't, the malloc that fails will
472 itself cause spare_memory to be freed. If buffers don't use the
473 relocating allocator, treat this like any other failing
477 memory_full (nbytes
);
480 /* This used to call error, but if we've run out of memory, we could
481 get infinite recursion trying to build the string. */
482 xsignal (Qnil
, Vmemory_signal_data
);
486 #ifndef XMALLOC_OVERRUN_CHECK
487 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
490 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
493 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
494 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
495 block size in little-endian order. The trailer consists of
496 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
498 The header is used to detect whether this block has been allocated
499 through these functions, as some low-level libc functions may
500 bypass the malloc hooks. */
502 #define XMALLOC_OVERRUN_CHECK_SIZE 16
503 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
504 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
506 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
507 hold a size_t value and (2) the header size is a multiple of the
508 alignment that Emacs needs for C types and for USE_LSB_TAG. */
509 #define XMALLOC_BASE_ALIGNMENT \
512 union { long double d; intmax_t i; void *p; } u; \
517 /* A common multiple of the positive integers A and B. Ideally this
518 would be the least common multiple, but there's no way to do that
519 as a constant expression in C, so do the best that we can easily do. */
520 # define COMMON_MULTIPLE(a, b) \
521 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
522 # define XMALLOC_HEADER_ALIGNMENT \
523 COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
525 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
527 #define XMALLOC_OVERRUN_SIZE_SIZE \
528 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
529 + XMALLOC_HEADER_ALIGNMENT - 1) \
530 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
531 - XMALLOC_OVERRUN_CHECK_SIZE)
533 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
534 { '\x9a', '\x9b', '\xae', '\xaf',
535 '\xbf', '\xbe', '\xce', '\xcf',
536 '\xea', '\xeb', '\xec', '\xed',
537 '\xdf', '\xde', '\x9c', '\x9d' };
539 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
540 { '\xaa', '\xab', '\xac', '\xad',
541 '\xba', '\xbb', '\xbc', '\xbd',
542 '\xca', '\xcb', '\xcc', '\xcd',
543 '\xda', '\xdb', '\xdc', '\xdd' };
545 /* Insert and extract the block size in the header. */
548 xmalloc_put_size (unsigned char *ptr
, size_t size
)
551 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
553 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
559 xmalloc_get_size (unsigned char *ptr
)
563 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
564 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
573 /* The call depth in overrun_check functions. For example, this might happen:
575 overrun_check_malloc()
576 -> malloc -> (via hook)_-> emacs_blocked_malloc
577 -> overrun_check_malloc
578 call malloc (hooks are NULL, so real malloc is called).
579 malloc returns 10000.
580 add overhead, return 10016.
581 <- (back in overrun_check_malloc)
582 add overhead again, return 10032
583 xmalloc returns 10032.
588 overrun_check_free(10032)
590 free(10016) <- crash, because 10000 is the original pointer. */
592 static ptrdiff_t check_depth
;
594 /* Like malloc, but wraps allocated block with header and trailer. */
596 static POINTER_TYPE
*
597 overrun_check_malloc (size_t size
)
599 register unsigned char *val
;
600 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
601 if (SIZE_MAX
- overhead
< size
)
604 val
= (unsigned char *) malloc (size
+ overhead
);
605 if (val
&& check_depth
== 1)
607 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
608 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
609 xmalloc_put_size (val
, size
);
610 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
611 XMALLOC_OVERRUN_CHECK_SIZE
);
614 return (POINTER_TYPE
*)val
;
618 /* Like realloc, but checks old block for overrun, and wraps new block
619 with header and trailer. */
621 static POINTER_TYPE
*
622 overrun_check_realloc (POINTER_TYPE
*block
, size_t size
)
624 register unsigned char *val
= (unsigned char *) block
;
625 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
626 if (SIZE_MAX
- overhead
< size
)
631 && memcmp (xmalloc_overrun_check_header
,
632 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
633 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
635 size_t osize
= xmalloc_get_size (val
);
636 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
637 XMALLOC_OVERRUN_CHECK_SIZE
))
639 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
640 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
641 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
644 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
646 if (val
&& check_depth
== 1)
648 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
649 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
650 xmalloc_put_size (val
, size
);
651 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
652 XMALLOC_OVERRUN_CHECK_SIZE
);
655 return (POINTER_TYPE
*)val
;
658 /* Like free, but checks block for overrun. */
661 overrun_check_free (POINTER_TYPE
*block
)
663 unsigned char *val
= (unsigned char *) block
;
668 && memcmp (xmalloc_overrun_check_header
,
669 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
670 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
672 size_t osize
= xmalloc_get_size (val
);
673 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
674 XMALLOC_OVERRUN_CHECK_SIZE
))
676 #ifdef XMALLOC_CLEAR_FREE_MEMORY
677 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
678 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
680 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
681 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
682 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
693 #define malloc overrun_check_malloc
694 #define realloc overrun_check_realloc
695 #define free overrun_check_free
699 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
700 there's no need to block input around malloc. */
701 #define MALLOC_BLOCK_INPUT ((void)0)
702 #define MALLOC_UNBLOCK_INPUT ((void)0)
704 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
705 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
708 /* Like malloc but check for no memory and block interrupt input.. */
711 xmalloc (size_t size
)
713 register POINTER_TYPE
*val
;
716 val
= (POINTER_TYPE
*) malloc (size
);
717 MALLOC_UNBLOCK_INPUT
;
725 /* Like realloc but check for no memory and block interrupt input.. */
728 xrealloc (POINTER_TYPE
*block
, size_t size
)
730 register POINTER_TYPE
*val
;
733 /* We must call malloc explicitly when BLOCK is 0, since some
734 reallocs don't do this. */
736 val
= (POINTER_TYPE
*) malloc (size
);
738 val
= (POINTER_TYPE
*) realloc (block
, size
);
739 MALLOC_UNBLOCK_INPUT
;
747 /* Like free but block interrupt input. */
750 xfree (POINTER_TYPE
*block
)
756 MALLOC_UNBLOCK_INPUT
;
757 /* We don't call refill_memory_reserve here
758 because that duplicates doing so in emacs_blocked_free
759 and the criterion should go there. */
763 /* Other parts of Emacs pass large int values to allocator functions
764 expecting ptrdiff_t. This is portable in practice, but check it to
766 verify (INT_MAX
<= PTRDIFF_MAX
);
769 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
770 Signal an error on memory exhaustion, and block interrupt input. */
773 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
775 xassert (0 <= nitems
&& 0 < item_size
);
776 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
777 memory_full (SIZE_MAX
);
778 return xmalloc (nitems
* item_size
);
782 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
783 Signal an error on memory exhaustion, and block interrupt input. */
786 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
788 xassert (0 <= nitems
&& 0 < item_size
);
789 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
790 memory_full (SIZE_MAX
);
791 return xrealloc (pa
, nitems
* item_size
);
795 /* Grow PA, which points to an array of *NITEMS items, and return the
796 location of the reallocated array, updating *NITEMS to reflect its
797 new size. The new array will contain at least NITEMS_INCR_MIN more
798 items, but will not contain more than NITEMS_MAX items total.
799 ITEM_SIZE is the size of each item, in bytes.
801 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
802 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
805 If PA is null, then allocate a new array instead of reallocating
806 the old one. Thus, to grow an array A without saving its old
807 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
810 Block interrupt input as needed. If memory exhaustion occurs, set
811 *NITEMS to zero if PA is null, and signal an error (i.e., do not
815 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
816 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
818 /* The approximate size to use for initial small allocation
819 requests. This is the largest "small" request for the GNU C
821 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
823 /* If the array is tiny, grow it to about (but no greater than)
824 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
825 ptrdiff_t n
= *nitems
;
826 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
827 ptrdiff_t half_again
= n
>> 1;
828 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
830 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
831 NITEMS_MAX, and what the C language can represent safely. */
832 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
833 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
834 ? nitems_max
: C_language_max
);
835 ptrdiff_t nitems_incr_max
= n_max
- n
;
836 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
838 xassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
841 if (nitems_incr_max
< incr
)
842 memory_full (SIZE_MAX
);
844 pa
= xrealloc (pa
, n
* item_size
);
850 /* Like strdup, but uses xmalloc. */
853 xstrdup (const char *s
)
855 size_t len
= strlen (s
) + 1;
856 char *p
= (char *) xmalloc (len
);
862 /* Unwind for SAFE_ALLOCA */
865 safe_alloca_unwind (Lisp_Object arg
)
867 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
877 /* Like malloc but used for allocating Lisp data. NBYTES is the
878 number of bytes to allocate, TYPE describes the intended use of the
879 allocated memory block (for strings, for conses, ...). */
882 static void *lisp_malloc_loser
;
885 static POINTER_TYPE
*
886 lisp_malloc (size_t nbytes
, enum mem_type type
)
892 #ifdef GC_MALLOC_CHECK
893 allocated_mem_type
= type
;
896 val
= (void *) malloc (nbytes
);
899 /* If the memory just allocated cannot be addressed thru a Lisp
900 object's pointer, and it needs to be,
901 that's equivalent to running out of memory. */
902 if (val
&& type
!= MEM_TYPE_NON_LISP
)
905 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
906 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
908 lisp_malloc_loser
= val
;
915 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
916 if (val
&& type
!= MEM_TYPE_NON_LISP
)
917 mem_insert (val
, (char *) val
+ nbytes
, type
);
920 MALLOC_UNBLOCK_INPUT
;
922 memory_full (nbytes
);
926 /* Free BLOCK. This must be called to free memory allocated with a
927 call to lisp_malloc. */
930 lisp_free (POINTER_TYPE
*block
)
934 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
935 mem_delete (mem_find (block
));
937 MALLOC_UNBLOCK_INPUT
;
940 /***** Allocation of aligned blocks of memory to store Lisp data. *****/
942 /* The entry point is lisp_align_malloc which returns blocks of at most
943 BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
945 /* Use posix_memalloc if the system has it and we're using the system's
946 malloc (because our gmalloc.c routines don't have posix_memalign although
947 its memalloc could be used). */
948 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
949 #define USE_POSIX_MEMALIGN 1
952 /* BLOCK_ALIGN has to be a power of 2. */
953 #define BLOCK_ALIGN (1 << 10)
955 /* Padding to leave at the end of a malloc'd block. This is to give
956 malloc a chance to minimize the amount of memory wasted to alignment.
957 It should be tuned to the particular malloc library used.
958 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
959 posix_memalign on the other hand would ideally prefer a value of 4
960 because otherwise, there's 1020 bytes wasted between each ablocks.
961 In Emacs, testing shows that those 1020 can most of the time be
962 efficiently used by malloc to place other objects, so a value of 0 can
963 still preferable unless you have a lot of aligned blocks and virtually
965 #define BLOCK_PADDING 0
966 #define BLOCK_BYTES \
967 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
969 /* Internal data structures and constants. */
971 #define ABLOCKS_SIZE 16
973 /* An aligned block of memory. */
978 char payload
[BLOCK_BYTES
];
979 struct ablock
*next_free
;
981 /* `abase' is the aligned base of the ablocks. */
982 /* It is overloaded to hold the virtual `busy' field that counts
983 the number of used ablock in the parent ablocks.
984 The first ablock has the `busy' field, the others have the `abase'
985 field. To tell the difference, we assume that pointers will have
986 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
987 is used to tell whether the real base of the parent ablocks is `abase'
988 (if not, the word before the first ablock holds a pointer to the
990 struct ablocks
*abase
;
991 /* The padding of all but the last ablock is unused. The padding of
992 the last ablock in an ablocks is not allocated. */
994 char padding
[BLOCK_PADDING
];
998 /* A bunch of consecutive aligned blocks. */
1001 struct ablock blocks
[ABLOCKS_SIZE
];
1004 /* Size of the block requested from malloc or memalign. */
1005 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1007 #define ABLOCK_ABASE(block) \
1008 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1009 ? (struct ablocks *)(block) \
1012 /* Virtual `busy' field. */
1013 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1015 /* Pointer to the (not necessarily aligned) malloc block. */
1016 #ifdef USE_POSIX_MEMALIGN
1017 #define ABLOCKS_BASE(abase) (abase)
1019 #define ABLOCKS_BASE(abase) \
1020 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
1023 /* The list of free ablock. */
1024 static struct ablock
*free_ablock
;
1026 /* Allocate an aligned block of nbytes.
1027 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1028 smaller or equal to BLOCK_BYTES. */
1029 static POINTER_TYPE
*
1030 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1033 struct ablocks
*abase
;
1035 eassert (nbytes
<= BLOCK_BYTES
);
1039 #ifdef GC_MALLOC_CHECK
1040 allocated_mem_type
= type
;
1046 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1048 #ifdef DOUG_LEA_MALLOC
1049 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1050 because mapped region contents are not preserved in
1052 mallopt (M_MMAP_MAX
, 0);
1055 #ifdef USE_POSIX_MEMALIGN
1057 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1063 base
= malloc (ABLOCKS_BYTES
);
1064 abase
= ALIGN (base
, BLOCK_ALIGN
);
1069 MALLOC_UNBLOCK_INPUT
;
1070 memory_full (ABLOCKS_BYTES
);
1073 aligned
= (base
== abase
);
1075 ((void**)abase
)[-1] = base
;
1077 #ifdef DOUG_LEA_MALLOC
1078 /* Back to a reasonable maximum of mmap'ed areas. */
1079 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1083 /* If the memory just allocated cannot be addressed thru a Lisp
1084 object's pointer, and it needs to be, that's equivalent to
1085 running out of memory. */
1086 if (type
!= MEM_TYPE_NON_LISP
)
1089 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1090 XSETCONS (tem
, end
);
1091 if ((char *) XCONS (tem
) != end
)
1093 lisp_malloc_loser
= base
;
1095 MALLOC_UNBLOCK_INPUT
;
1096 memory_full (SIZE_MAX
);
1101 /* Initialize the blocks and put them on the free list.
1102 If `base' was not properly aligned, we can't use the last block. */
1103 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1105 abase
->blocks
[i
].abase
= abase
;
1106 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1107 free_ablock
= &abase
->blocks
[i
];
1109 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1111 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1112 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1113 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1114 eassert (ABLOCKS_BASE (abase
) == base
);
1115 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1118 abase
= ABLOCK_ABASE (free_ablock
);
1119 ABLOCKS_BUSY (abase
) =
1120 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1122 free_ablock
= free_ablock
->x
.next_free
;
1124 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1125 if (type
!= MEM_TYPE_NON_LISP
)
1126 mem_insert (val
, (char *) val
+ nbytes
, type
);
1129 MALLOC_UNBLOCK_INPUT
;
1131 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1136 lisp_align_free (POINTER_TYPE
*block
)
1138 struct ablock
*ablock
= block
;
1139 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1142 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1143 mem_delete (mem_find (block
));
1145 /* Put on free list. */
1146 ablock
->x
.next_free
= free_ablock
;
1147 free_ablock
= ablock
;
1148 /* Update busy count. */
1149 ABLOCKS_BUSY (abase
)
1150 = (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1152 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1153 { /* All the blocks are free. */
1154 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1155 struct ablock
**tem
= &free_ablock
;
1156 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1160 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1163 *tem
= (*tem
)->x
.next_free
;
1166 tem
= &(*tem
)->x
.next_free
;
1168 eassert ((aligned
& 1) == aligned
);
1169 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1170 #ifdef USE_POSIX_MEMALIGN
1171 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1173 free (ABLOCKS_BASE (abase
));
1175 MALLOC_UNBLOCK_INPUT
;
1178 /* Return a new buffer structure allocated from the heap with
1179 a call to lisp_malloc. */
1182 allocate_buffer (void)
1185 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1187 XSETPVECTYPESIZE (b
, PVEC_BUFFER
,
1188 ((sizeof (struct buffer
) + sizeof (EMACS_INT
) - 1)
1189 / sizeof (EMACS_INT
)));
1194 #ifndef SYSTEM_MALLOC
1196 /* Arranging to disable input signals while we're in malloc.
1198 This only works with GNU malloc. To help out systems which can't
1199 use GNU malloc, all the calls to malloc, realloc, and free
1200 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1201 pair; unfortunately, we have no idea what C library functions
1202 might call malloc, so we can't really protect them unless you're
1203 using GNU malloc. Fortunately, most of the major operating systems
1204 can use GNU malloc. */
1207 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1208 there's no need to block input around malloc. */
1210 #ifndef DOUG_LEA_MALLOC
1211 extern void * (*__malloc_hook
) (size_t, const void *);
1212 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1213 extern void (*__free_hook
) (void *, const void *);
1214 /* Else declared in malloc.h, perhaps with an extra arg. */
1215 #endif /* DOUG_LEA_MALLOC */
1216 static void * (*old_malloc_hook
) (size_t, const void *);
1217 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1218 static void (*old_free_hook
) (void*, const void*);
1220 #ifdef DOUG_LEA_MALLOC
1221 # define BYTES_USED (mallinfo ().uordblks)
1223 # define BYTES_USED _bytes_used
1226 static size_t bytes_used_when_reconsidered
;
1228 /* Value of _bytes_used, when spare_memory was freed. */
1230 static size_t bytes_used_when_full
;
1232 /* This function is used as the hook for free to call. */
1235 emacs_blocked_free (void *ptr
, const void *ptr2
)
1239 #ifdef GC_MALLOC_CHECK
1245 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1248 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1253 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1257 #endif /* GC_MALLOC_CHECK */
1259 __free_hook
= old_free_hook
;
1262 /* If we released our reserve (due to running out of memory),
1263 and we have a fair amount free once again,
1264 try to set aside another reserve in case we run out once more. */
1265 if (! NILP (Vmemory_full
)
1266 /* Verify there is enough space that even with the malloc
1267 hysteresis this call won't run out again.
1268 The code here is correct as long as SPARE_MEMORY
1269 is substantially larger than the block size malloc uses. */
1270 && (bytes_used_when_full
1271 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1272 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1273 refill_memory_reserve ();
1275 __free_hook
= emacs_blocked_free
;
1276 UNBLOCK_INPUT_ALLOC
;
1280 /* This function is the malloc hook that Emacs uses. */
1283 emacs_blocked_malloc (size_t size
, const void *ptr
)
1288 __malloc_hook
= old_malloc_hook
;
1289 #ifdef DOUG_LEA_MALLOC
1290 /* Segfaults on my system. --lorentey */
1291 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1293 __malloc_extra_blocks
= malloc_hysteresis
;
1296 value
= (void *) malloc (size
);
1298 #ifdef GC_MALLOC_CHECK
1300 struct mem_node
*m
= mem_find (value
);
1303 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1305 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1306 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1311 if (!dont_register_blocks
)
1313 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1314 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1317 #endif /* GC_MALLOC_CHECK */
1319 __malloc_hook
= emacs_blocked_malloc
;
1320 UNBLOCK_INPUT_ALLOC
;
1322 /* fprintf (stderr, "%p malloc\n", value); */
1327 /* This function is the realloc hook that Emacs uses. */
1330 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1335 __realloc_hook
= old_realloc_hook
;
1337 #ifdef GC_MALLOC_CHECK
1340 struct mem_node
*m
= mem_find (ptr
);
1341 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1344 "Realloc of %p which wasn't allocated with malloc\n",
1352 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1354 /* Prevent malloc from registering blocks. */
1355 dont_register_blocks
= 1;
1356 #endif /* GC_MALLOC_CHECK */
1358 value
= (void *) realloc (ptr
, size
);
1360 #ifdef GC_MALLOC_CHECK
1361 dont_register_blocks
= 0;
1364 struct mem_node
*m
= mem_find (value
);
1367 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1371 /* Can't handle zero size regions in the red-black tree. */
1372 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1375 /* fprintf (stderr, "%p <- realloc\n", value); */
1376 #endif /* GC_MALLOC_CHECK */
1378 __realloc_hook
= emacs_blocked_realloc
;
1379 UNBLOCK_INPUT_ALLOC
;
1386 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1387 normal malloc. Some thread implementations need this as they call
1388 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1389 calls malloc because it is the first call, and we have an endless loop. */
1392 reset_malloc_hooks (void)
1394 __free_hook
= old_free_hook
;
1395 __malloc_hook
= old_malloc_hook
;
1396 __realloc_hook
= old_realloc_hook
;
1398 #endif /* HAVE_PTHREAD */
1401 /* Called from main to set up malloc to use our hooks. */
1404 uninterrupt_malloc (void)
1407 #ifdef DOUG_LEA_MALLOC
1408 pthread_mutexattr_t attr
;
1410 /* GLIBC has a faster way to do this, but let's keep it portable.
1411 This is according to the Single UNIX Specification. */
1412 pthread_mutexattr_init (&attr
);
1413 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1414 pthread_mutex_init (&alloc_mutex
, &attr
);
1415 #else /* !DOUG_LEA_MALLOC */
1416 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1417 and the bundled gmalloc.c doesn't require it. */
1418 pthread_mutex_init (&alloc_mutex
, NULL
);
1419 #endif /* !DOUG_LEA_MALLOC */
1420 #endif /* HAVE_PTHREAD */
1422 if (__free_hook
!= emacs_blocked_free
)
1423 old_free_hook
= __free_hook
;
1424 __free_hook
= emacs_blocked_free
;
1426 if (__malloc_hook
!= emacs_blocked_malloc
)
1427 old_malloc_hook
= __malloc_hook
;
1428 __malloc_hook
= emacs_blocked_malloc
;
1430 if (__realloc_hook
!= emacs_blocked_realloc
)
1431 old_realloc_hook
= __realloc_hook
;
1432 __realloc_hook
= emacs_blocked_realloc
;
1435 #endif /* not SYNC_INPUT */
1436 #endif /* not SYSTEM_MALLOC */
1440 /***********************************************************************
1442 ***********************************************************************/
1444 /* Number of intervals allocated in an interval_block structure.
1445 The 1020 is 1024 minus malloc overhead. */
1447 #define INTERVAL_BLOCK_SIZE \
1448 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1450 /* Intervals are allocated in chunks in form of an interval_block
1453 struct interval_block
1455 /* Place `intervals' first, to preserve alignment. */
1456 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1457 struct interval_block
*next
;
1460 /* Current interval block. Its `next' pointer points to older
1463 static struct interval_block
*interval_block
;
1465 /* Index in interval_block above of the next unused interval
1468 static int interval_block_index
;
1470 /* Number of free and live intervals. */
1472 static EMACS_INT total_free_intervals
, total_intervals
;
1474 /* List of free intervals. */
1476 static INTERVAL interval_free_list
;
1479 /* Initialize interval allocation. */
1482 init_intervals (void)
1484 interval_block
= NULL
;
1485 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1486 interval_free_list
= 0;
1490 /* Return a new interval. */
1493 make_interval (void)
1497 /* eassert (!handling_signal); */
1501 if (interval_free_list
)
1503 val
= interval_free_list
;
1504 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1508 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1510 register struct interval_block
*newi
;
1512 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1515 newi
->next
= interval_block
;
1516 interval_block
= newi
;
1517 interval_block_index
= 0;
1519 val
= &interval_block
->intervals
[interval_block_index
++];
1522 MALLOC_UNBLOCK_INPUT
;
1524 consing_since_gc
+= sizeof (struct interval
);
1526 RESET_INTERVAL (val
);
1532 /* Mark Lisp objects in interval I. */
1535 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1537 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1539 mark_object (i
->plist
);
1543 /* Mark the interval tree rooted in TREE. Don't call this directly;
1544 use the macro MARK_INTERVAL_TREE instead. */
1547 mark_interval_tree (register INTERVAL tree
)
1549 /* No need to test if this tree has been marked already; this
1550 function is always called through the MARK_INTERVAL_TREE macro,
1551 which takes care of that. */
1553 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1557 /* Mark the interval tree rooted in I. */
1559 #define MARK_INTERVAL_TREE(i) \
1561 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1562 mark_interval_tree (i); \
1566 #define UNMARK_BALANCE_INTERVALS(i) \
1568 if (! NULL_INTERVAL_P (i)) \
1569 (i) = balance_intervals (i); \
1573 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1574 can't create number objects in macros. */
1577 make_number (EMACS_INT n
)
1581 obj
.s
.type
= Lisp_Int
;
1586 /* Convert the pointer-sized word P to EMACS_INT while preserving its
1587 type and ptr fields. */
1589 widen_to_Lisp_Object (void *p
)
1591 intptr_t i
= (intptr_t) p
;
1592 #ifdef USE_LISP_UNION_TYPE
1601 /***********************************************************************
1603 ***********************************************************************/
1605 /* Lisp_Strings are allocated in string_block structures. When a new
1606 string_block is allocated, all the Lisp_Strings it contains are
1607 added to a free-list string_free_list. When a new Lisp_String is
1608 needed, it is taken from that list. During the sweep phase of GC,
1609 string_blocks that are entirely free are freed, except two which
1612 String data is allocated from sblock structures. Strings larger
1613 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1614 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1616 Sblocks consist internally of sdata structures, one for each
1617 Lisp_String. The sdata structure points to the Lisp_String it
1618 belongs to. The Lisp_String points back to the `u.data' member of
1619 its sdata structure.
1621 When a Lisp_String is freed during GC, it is put back on
1622 string_free_list, and its `data' member and its sdata's `string'
1623 pointer is set to null. The size of the string is recorded in the
1624 `u.nbytes' member of the sdata. So, sdata structures that are no
1625 longer used, can be easily recognized, and it's easy to compact the
1626 sblocks of small strings which we do in compact_small_strings. */
1628 /* Size in bytes of an sblock structure used for small strings. This
1629 is 8192 minus malloc overhead. */
1631 #define SBLOCK_SIZE 8188
1633 /* Strings larger than this are considered large strings. String data
1634 for large strings is allocated from individual sblocks. */
1636 #define LARGE_STRING_BYTES 1024
1638 /* Structure describing string memory sub-allocated from an sblock.
1639 This is where the contents of Lisp strings are stored. */
1643 /* Back-pointer to the string this sdata belongs to. If null, this
1644 structure is free, and the NBYTES member of the union below
1645 contains the string's byte size (the same value that STRING_BYTES
1646 would return if STRING were non-null). If non-null, STRING_BYTES
1647 (STRING) is the size of the data, and DATA contains the string's
1649 struct Lisp_String
*string
;
1651 #ifdef GC_CHECK_STRING_BYTES
1654 unsigned char data
[1];
1656 #define SDATA_NBYTES(S) (S)->nbytes
1657 #define SDATA_DATA(S) (S)->data
1658 #define SDATA_SELECTOR(member) member
1660 #else /* not GC_CHECK_STRING_BYTES */
1664 /* When STRING is non-null. */
1665 unsigned char data
[1];
1667 /* When STRING is null. */
1671 #define SDATA_NBYTES(S) (S)->u.nbytes
1672 #define SDATA_DATA(S) (S)->u.data
1673 #define SDATA_SELECTOR(member) u.member
1675 #endif /* not GC_CHECK_STRING_BYTES */
1677 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1681 /* Structure describing a block of memory which is sub-allocated to
1682 obtain string data memory for strings. Blocks for small strings
1683 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1684 as large as needed. */
1689 struct sblock
*next
;
1691 /* Pointer to the next free sdata block. This points past the end
1692 of the sblock if there isn't any space left in this block. */
1693 struct sdata
*next_free
;
1695 /* Start of data. */
1696 struct sdata first_data
;
1699 /* Number of Lisp strings in a string_block structure. The 1020 is
1700 1024 minus malloc overhead. */
1702 #define STRING_BLOCK_SIZE \
1703 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1705 /* Structure describing a block from which Lisp_String structures
1710 /* Place `strings' first, to preserve alignment. */
1711 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1712 struct string_block
*next
;
1715 /* Head and tail of the list of sblock structures holding Lisp string
1716 data. We always allocate from current_sblock. The NEXT pointers
1717 in the sblock structures go from oldest_sblock to current_sblock. */
1719 static struct sblock
*oldest_sblock
, *current_sblock
;
1721 /* List of sblocks for large strings. */
1723 static struct sblock
*large_sblocks
;
1725 /* List of string_block structures. */
1727 static struct string_block
*string_blocks
;
1729 /* Free-list of Lisp_Strings. */
1731 static struct Lisp_String
*string_free_list
;
1733 /* Number of live and free Lisp_Strings. */
1735 static EMACS_INT total_strings
, total_free_strings
;
1737 /* Number of bytes used by live strings. */
1739 static EMACS_INT total_string_size
;
1741 /* Given a pointer to a Lisp_String S which is on the free-list
1742 string_free_list, return a pointer to its successor in the
1745 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1747 /* Return a pointer to the sdata structure belonging to Lisp string S.
1748 S must be live, i.e. S->data must not be null. S->data is actually
1749 a pointer to the `u.data' member of its sdata structure; the
1750 structure starts at a constant offset in front of that. */
1752 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1755 #ifdef GC_CHECK_STRING_OVERRUN
1757 /* We check for overrun in string data blocks by appending a small
1758 "cookie" after each allocated string data block, and check for the
1759 presence of this cookie during GC. */
1761 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1762 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1763 { '\xde', '\xad', '\xbe', '\xef' };
1766 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1769 /* Value is the size of an sdata structure large enough to hold NBYTES
1770 bytes of string data. The value returned includes a terminating
1771 NUL byte, the size of the sdata structure, and padding. */
1773 #ifdef GC_CHECK_STRING_BYTES
1775 #define SDATA_SIZE(NBYTES) \
1776 ((SDATA_DATA_OFFSET \
1778 + sizeof (EMACS_INT) - 1) \
1779 & ~(sizeof (EMACS_INT) - 1))
1781 #else /* not GC_CHECK_STRING_BYTES */
1783 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1784 less than the size of that member. The 'max' is not needed when
1785 SDATA_DATA_OFFSET is a multiple of sizeof (EMACS_INT), because then the
1786 alignment code reserves enough space. */
1788 #define SDATA_SIZE(NBYTES) \
1789 ((SDATA_DATA_OFFSET \
1790 + (SDATA_DATA_OFFSET % sizeof (EMACS_INT) == 0 \
1792 : max (NBYTES, sizeof (EMACS_INT) - 1)) \
1794 + sizeof (EMACS_INT) - 1) \
1795 & ~(sizeof (EMACS_INT) - 1))
1797 #endif /* not GC_CHECK_STRING_BYTES */
1799 /* Extra bytes to allocate for each string. */
1801 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1803 /* Exact bound on the number of bytes in a string, not counting the
1804 terminating null. A string cannot contain more bytes than
1805 STRING_BYTES_BOUND, nor can it be so long that the size_t
1806 arithmetic in allocate_string_data would overflow while it is
1807 calculating a value to be passed to malloc. */
1808 #define STRING_BYTES_MAX \
1809 min (STRING_BYTES_BOUND, \
1810 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \
1812 - offsetof (struct sblock, first_data) \
1813 - SDATA_DATA_OFFSET) \
1814 & ~(sizeof (EMACS_INT) - 1)))
1816 /* Initialize string allocation. Called from init_alloc_once. */
1821 total_strings
= total_free_strings
= total_string_size
= 0;
1822 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1823 string_blocks
= NULL
;
1824 string_free_list
= NULL
;
1825 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1826 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1830 #ifdef GC_CHECK_STRING_BYTES
1832 static int check_string_bytes_count
;
1834 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1837 /* Like GC_STRING_BYTES, but with debugging check. */
1840 string_bytes (struct Lisp_String
*s
)
1843 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1845 if (!PURE_POINTER_P (s
)
1847 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1852 /* Check validity of Lisp strings' string_bytes member in B. */
1855 check_sblock (struct sblock
*b
)
1857 struct sdata
*from
, *end
, *from_end
;
1861 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1863 /* Compute the next FROM here because copying below may
1864 overwrite data we need to compute it. */
1867 /* Check that the string size recorded in the string is the
1868 same as the one recorded in the sdata structure. */
1870 CHECK_STRING_BYTES (from
->string
);
1873 nbytes
= GC_STRING_BYTES (from
->string
);
1875 nbytes
= SDATA_NBYTES (from
);
1877 nbytes
= SDATA_SIZE (nbytes
);
1878 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1883 /* Check validity of Lisp strings' string_bytes member. ALL_P
1884 non-zero means check all strings, otherwise check only most
1885 recently allocated strings. Used for hunting a bug. */
1888 check_string_bytes (int all_p
)
1894 for (b
= large_sblocks
; b
; b
= b
->next
)
1896 struct Lisp_String
*s
= b
->first_data
.string
;
1898 CHECK_STRING_BYTES (s
);
1901 for (b
= oldest_sblock
; b
; b
= b
->next
)
1905 check_sblock (current_sblock
);
1908 #endif /* GC_CHECK_STRING_BYTES */
1910 #ifdef GC_CHECK_STRING_FREE_LIST
1912 /* Walk through the string free list looking for bogus next pointers.
1913 This may catch buffer overrun from a previous string. */
1916 check_string_free_list (void)
1918 struct Lisp_String
*s
;
1920 /* Pop a Lisp_String off the free-list. */
1921 s
= string_free_list
;
1924 if ((uintptr_t) s
< 1024)
1926 s
= NEXT_FREE_LISP_STRING (s
);
1930 #define check_string_free_list()
1933 /* Return a new Lisp_String. */
1935 static struct Lisp_String
*
1936 allocate_string (void)
1938 struct Lisp_String
*s
;
1940 /* eassert (!handling_signal); */
1944 /* If the free-list is empty, allocate a new string_block, and
1945 add all the Lisp_Strings in it to the free-list. */
1946 if (string_free_list
== NULL
)
1948 struct string_block
*b
;
1951 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1952 memset (b
, 0, sizeof *b
);
1953 b
->next
= string_blocks
;
1956 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1959 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1960 string_free_list
= s
;
1963 total_free_strings
+= STRING_BLOCK_SIZE
;
1966 check_string_free_list ();
1968 /* Pop a Lisp_String off the free-list. */
1969 s
= string_free_list
;
1970 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1972 MALLOC_UNBLOCK_INPUT
;
1974 /* Probably not strictly necessary, but play it safe. */
1975 memset (s
, 0, sizeof *s
);
1977 --total_free_strings
;
1980 consing_since_gc
+= sizeof *s
;
1982 #ifdef GC_CHECK_STRING_BYTES
1983 if (!noninteractive
)
1985 if (++check_string_bytes_count
== 200)
1987 check_string_bytes_count
= 0;
1988 check_string_bytes (1);
1991 check_string_bytes (0);
1993 #endif /* GC_CHECK_STRING_BYTES */
1999 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
2000 plus a NUL byte at the end. Allocate an sdata structure for S, and
2001 set S->data to its `u.data' member. Store a NUL byte at the end of
2002 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
2003 S->data if it was initially non-null. */
2006 allocate_string_data (struct Lisp_String
*s
,
2007 EMACS_INT nchars
, EMACS_INT nbytes
)
2009 struct sdata
*data
, *old_data
;
2011 EMACS_INT needed
, old_nbytes
;
2013 if (STRING_BYTES_MAX
< nbytes
)
2016 /* Determine the number of bytes needed to store NBYTES bytes
2018 needed
= SDATA_SIZE (nbytes
);
2019 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
2020 old_nbytes
= GC_STRING_BYTES (s
);
2024 if (nbytes
> LARGE_STRING_BYTES
)
2026 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
2028 #ifdef DOUG_LEA_MALLOC
2029 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2030 because mapped region contents are not preserved in
2033 In case you think of allowing it in a dumped Emacs at the
2034 cost of not being able to re-dump, there's another reason:
2035 mmap'ed data typically have an address towards the top of the
2036 address space, which won't fit into an EMACS_INT (at least on
2037 32-bit systems with the current tagging scheme). --fx */
2038 mallopt (M_MMAP_MAX
, 0);
2041 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
2043 #ifdef DOUG_LEA_MALLOC
2044 /* Back to a reasonable maximum of mmap'ed areas. */
2045 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2048 b
->next_free
= &b
->first_data
;
2049 b
->first_data
.string
= NULL
;
2050 b
->next
= large_sblocks
;
2053 else if (current_sblock
== NULL
2054 || (((char *) current_sblock
+ SBLOCK_SIZE
2055 - (char *) current_sblock
->next_free
)
2056 < (needed
+ GC_STRING_EXTRA
)))
2058 /* Not enough room in the current sblock. */
2059 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2060 b
->next_free
= &b
->first_data
;
2061 b
->first_data
.string
= NULL
;
2065 current_sblock
->next
= b
;
2073 data
= b
->next_free
;
2074 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2076 MALLOC_UNBLOCK_INPUT
;
2079 s
->data
= SDATA_DATA (data
);
2080 #ifdef GC_CHECK_STRING_BYTES
2081 SDATA_NBYTES (data
) = nbytes
;
2084 s
->size_byte
= nbytes
;
2085 s
->data
[nbytes
] = '\0';
2086 #ifdef GC_CHECK_STRING_OVERRUN
2087 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2088 GC_STRING_OVERRUN_COOKIE_SIZE
);
2091 /* If S had already data assigned, mark that as free by setting its
2092 string back-pointer to null, and recording the size of the data
2096 SDATA_NBYTES (old_data
) = old_nbytes
;
2097 old_data
->string
= NULL
;
2100 consing_since_gc
+= needed
;
2104 /* Sweep and compact strings. */
2107 sweep_strings (void)
2109 struct string_block
*b
, *next
;
2110 struct string_block
*live_blocks
= NULL
;
2112 string_free_list
= NULL
;
2113 total_strings
= total_free_strings
= 0;
2114 total_string_size
= 0;
2116 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2117 for (b
= string_blocks
; b
; b
= next
)
2120 struct Lisp_String
*free_list_before
= string_free_list
;
2124 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2126 struct Lisp_String
*s
= b
->strings
+ i
;
2130 /* String was not on free-list before. */
2131 if (STRING_MARKED_P (s
))
2133 /* String is live; unmark it and its intervals. */
2136 if (!NULL_INTERVAL_P (s
->intervals
))
2137 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2140 total_string_size
+= STRING_BYTES (s
);
2144 /* String is dead. Put it on the free-list. */
2145 struct sdata
*data
= SDATA_OF_STRING (s
);
2147 /* Save the size of S in its sdata so that we know
2148 how large that is. Reset the sdata's string
2149 back-pointer so that we know it's free. */
2150 #ifdef GC_CHECK_STRING_BYTES
2151 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2154 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2156 data
->string
= NULL
;
2158 /* Reset the strings's `data' member so that we
2162 /* Put the string on the free-list. */
2163 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2164 string_free_list
= s
;
2170 /* S was on the free-list before. Put it there again. */
2171 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2172 string_free_list
= s
;
2177 /* Free blocks that contain free Lisp_Strings only, except
2178 the first two of them. */
2179 if (nfree
== STRING_BLOCK_SIZE
2180 && total_free_strings
> STRING_BLOCK_SIZE
)
2183 string_free_list
= free_list_before
;
2187 total_free_strings
+= nfree
;
2188 b
->next
= live_blocks
;
2193 check_string_free_list ();
2195 string_blocks
= live_blocks
;
2196 free_large_strings ();
2197 compact_small_strings ();
2199 check_string_free_list ();
2203 /* Free dead large strings. */
2206 free_large_strings (void)
2208 struct sblock
*b
, *next
;
2209 struct sblock
*live_blocks
= NULL
;
2211 for (b
= large_sblocks
; b
; b
= next
)
2215 if (b
->first_data
.string
== NULL
)
2219 b
->next
= live_blocks
;
2224 large_sblocks
= live_blocks
;
2228 /* Compact data of small strings. Free sblocks that don't contain
2229 data of live strings after compaction. */
2232 compact_small_strings (void)
2234 struct sblock
*b
, *tb
, *next
;
2235 struct sdata
*from
, *to
, *end
, *tb_end
;
2236 struct sdata
*to_end
, *from_end
;
2238 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2239 to, and TB_END is the end of TB. */
2241 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2242 to
= &tb
->first_data
;
2244 /* Step through the blocks from the oldest to the youngest. We
2245 expect that old blocks will stabilize over time, so that less
2246 copying will happen this way. */
2247 for (b
= oldest_sblock
; b
; b
= b
->next
)
2250 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2252 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2254 /* Compute the next FROM here because copying below may
2255 overwrite data we need to compute it. */
2258 #ifdef GC_CHECK_STRING_BYTES
2259 /* Check that the string size recorded in the string is the
2260 same as the one recorded in the sdata structure. */
2262 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2264 #endif /* GC_CHECK_STRING_BYTES */
2267 nbytes
= GC_STRING_BYTES (from
->string
);
2269 nbytes
= SDATA_NBYTES (from
);
2271 if (nbytes
> LARGE_STRING_BYTES
)
2274 nbytes
= SDATA_SIZE (nbytes
);
2275 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2277 #ifdef GC_CHECK_STRING_OVERRUN
2278 if (memcmp (string_overrun_cookie
,
2279 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2280 GC_STRING_OVERRUN_COOKIE_SIZE
))
2284 /* FROM->string non-null means it's alive. Copy its data. */
2287 /* If TB is full, proceed with the next sblock. */
2288 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2289 if (to_end
> tb_end
)
2293 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2294 to
= &tb
->first_data
;
2295 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2298 /* Copy, and update the string's `data' pointer. */
2301 xassert (tb
!= b
|| to
< from
);
2302 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2303 to
->string
->data
= SDATA_DATA (to
);
2306 /* Advance past the sdata we copied to. */
2312 /* The rest of the sblocks following TB don't contain live data, so
2313 we can free them. */
2314 for (b
= tb
->next
; b
; b
= next
)
2322 current_sblock
= tb
;
2326 string_overflow (void)
2328 error ("Maximum string size exceeded");
2331 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2332 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2333 LENGTH must be an integer.
2334 INIT must be an integer that represents a character. */)
2335 (Lisp_Object length
, Lisp_Object init
)
2337 register Lisp_Object val
;
2338 register unsigned char *p
, *end
;
2342 CHECK_NATNUM (length
);
2343 CHECK_CHARACTER (init
);
2345 c
= XFASTINT (init
);
2346 if (ASCII_CHAR_P (c
))
2348 nbytes
= XINT (length
);
2349 val
= make_uninit_string (nbytes
);
2351 end
= p
+ SCHARS (val
);
2357 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2358 int len
= CHAR_STRING (c
, str
);
2359 EMACS_INT string_len
= XINT (length
);
2361 if (string_len
> STRING_BYTES_MAX
/ len
)
2363 nbytes
= len
* string_len
;
2364 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2369 memcpy (p
, str
, len
);
2379 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2380 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2381 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2382 (Lisp_Object length
, Lisp_Object init
)
2384 register Lisp_Object val
;
2385 struct Lisp_Bool_Vector
*p
;
2386 EMACS_INT length_in_chars
, length_in_elts
;
2389 CHECK_NATNUM (length
);
2391 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2393 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2394 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2395 / BOOL_VECTOR_BITS_PER_CHAR
);
2397 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2398 slot `size' of the struct Lisp_Bool_Vector. */
2399 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2401 /* No Lisp_Object to trace in there. */
2402 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0);
2404 p
= XBOOL_VECTOR (val
);
2405 p
->size
= XFASTINT (length
);
2407 if (length_in_chars
)
2409 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2411 /* Clear any extraneous bits in the last byte. */
2412 p
->data
[length_in_chars
- 1]
2413 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2420 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2421 of characters from the contents. This string may be unibyte or
2422 multibyte, depending on the contents. */
2425 make_string (const char *contents
, EMACS_INT nbytes
)
2427 register Lisp_Object val
;
2428 EMACS_INT nchars
, multibyte_nbytes
;
2430 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2431 &nchars
, &multibyte_nbytes
);
2432 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2433 /* CONTENTS contains no multibyte sequences or contains an invalid
2434 multibyte sequence. We must make unibyte string. */
2435 val
= make_unibyte_string (contents
, nbytes
);
2437 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2442 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2445 make_unibyte_string (const char *contents
, EMACS_INT length
)
2447 register Lisp_Object val
;
2448 val
= make_uninit_string (length
);
2449 memcpy (SDATA (val
), contents
, length
);
2454 /* Make a multibyte string from NCHARS characters occupying NBYTES
2455 bytes at CONTENTS. */
2458 make_multibyte_string (const char *contents
,
2459 EMACS_INT nchars
, EMACS_INT nbytes
)
2461 register Lisp_Object val
;
2462 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2463 memcpy (SDATA (val
), contents
, nbytes
);
2468 /* Make a string from NCHARS characters occupying NBYTES bytes at
2469 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2472 make_string_from_bytes (const char *contents
,
2473 EMACS_INT nchars
, EMACS_INT nbytes
)
2475 register Lisp_Object val
;
2476 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2477 memcpy (SDATA (val
), contents
, nbytes
);
2478 if (SBYTES (val
) == SCHARS (val
))
2479 STRING_SET_UNIBYTE (val
);
2484 /* Make a string from NCHARS characters occupying NBYTES bytes at
2485 CONTENTS. The argument MULTIBYTE controls whether to label the
2486 string as multibyte. If NCHARS is negative, it counts the number of
2487 characters by itself. */
2490 make_specified_string (const char *contents
,
2491 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
2493 register Lisp_Object val
;
2498 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2503 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2504 memcpy (SDATA (val
), contents
, nbytes
);
2506 STRING_SET_UNIBYTE (val
);
2511 /* Make a string from the data at STR, treating it as multibyte if the
2515 build_string (const char *str
)
2517 return make_string (str
, strlen (str
));
2521 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2522 occupying LENGTH bytes. */
2525 make_uninit_string (EMACS_INT length
)
2530 return empty_unibyte_string
;
2531 val
= make_uninit_multibyte_string (length
, length
);
2532 STRING_SET_UNIBYTE (val
);
2537 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2538 which occupy NBYTES bytes. */
2541 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2544 struct Lisp_String
*s
;
2549 return empty_multibyte_string
;
2551 s
= allocate_string ();
2552 allocate_string_data (s
, nchars
, nbytes
);
2553 XSETSTRING (string
, s
);
2554 string_chars_consed
+= nbytes
;
2560 /***********************************************************************
2562 ***********************************************************************/
2564 /* We store float cells inside of float_blocks, allocating a new
2565 float_block with malloc whenever necessary. Float cells reclaimed
2566 by GC are put on a free list to be reallocated before allocating
2567 any new float cells from the latest float_block. */
2569 #define FLOAT_BLOCK_SIZE \
2570 (((BLOCK_BYTES - sizeof (struct float_block *) \
2571 /* The compiler might add padding at the end. */ \
2572 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2573 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2575 #define GETMARKBIT(block,n) \
2576 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2577 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2580 #define SETMARKBIT(block,n) \
2581 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2582 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2584 #define UNSETMARKBIT(block,n) \
2585 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2586 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2588 #define FLOAT_BLOCK(fptr) \
2589 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2591 #define FLOAT_INDEX(fptr) \
2592 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2596 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2597 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2598 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2599 struct float_block
*next
;
2602 #define FLOAT_MARKED_P(fptr) \
2603 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2605 #define FLOAT_MARK(fptr) \
2606 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2608 #define FLOAT_UNMARK(fptr) \
2609 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2611 /* Current float_block. */
2613 static struct float_block
*float_block
;
2615 /* Index of first unused Lisp_Float in the current float_block. */
2617 static int float_block_index
;
2619 /* Free-list of Lisp_Floats. */
2621 static struct Lisp_Float
*float_free_list
;
2624 /* Initialize float allocation. */
2630 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2631 float_free_list
= 0;
2635 /* Return a new float object with value FLOAT_VALUE. */
2638 make_float (double float_value
)
2640 register Lisp_Object val
;
2642 /* eassert (!handling_signal); */
2646 if (float_free_list
)
2648 /* We use the data field for chaining the free list
2649 so that we won't use the same field that has the mark bit. */
2650 XSETFLOAT (val
, float_free_list
);
2651 float_free_list
= float_free_list
->u
.chain
;
2655 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2657 register struct float_block
*new;
2659 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2661 new->next
= float_block
;
2662 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2664 float_block_index
= 0;
2666 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2667 float_block_index
++;
2670 MALLOC_UNBLOCK_INPUT
;
2672 XFLOAT_INIT (val
, float_value
);
2673 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2674 consing_since_gc
+= sizeof (struct Lisp_Float
);
2681 /***********************************************************************
2683 ***********************************************************************/
2685 /* We store cons cells inside of cons_blocks, allocating a new
2686 cons_block with malloc whenever necessary. Cons cells reclaimed by
2687 GC are put on a free list to be reallocated before allocating
2688 any new cons cells from the latest cons_block. */
2690 #define CONS_BLOCK_SIZE \
2691 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2692 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2694 #define CONS_BLOCK(fptr) \
2695 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2697 #define CONS_INDEX(fptr) \
2698 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2702 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2703 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2704 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2705 struct cons_block
*next
;
2708 #define CONS_MARKED_P(fptr) \
2709 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2711 #define CONS_MARK(fptr) \
2712 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2714 #define CONS_UNMARK(fptr) \
2715 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2717 /* Current cons_block. */
2719 static struct cons_block
*cons_block
;
2721 /* Index of first unused Lisp_Cons in the current block. */
2723 static int cons_block_index
;
2725 /* Free-list of Lisp_Cons structures. */
2727 static struct Lisp_Cons
*cons_free_list
;
2730 /* Initialize cons allocation. */
2736 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2741 /* Explicitly free a cons cell by putting it on the free-list. */
2744 free_cons (struct Lisp_Cons
*ptr
)
2746 ptr
->u
.chain
= cons_free_list
;
2750 cons_free_list
= ptr
;
2753 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2754 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2755 (Lisp_Object car
, Lisp_Object cdr
)
2757 register Lisp_Object val
;
2759 /* eassert (!handling_signal); */
2765 /* We use the cdr for chaining the free list
2766 so that we won't use the same field that has the mark bit. */
2767 XSETCONS (val
, cons_free_list
);
2768 cons_free_list
= cons_free_list
->u
.chain
;
2772 if (cons_block_index
== CONS_BLOCK_SIZE
)
2774 register struct cons_block
*new;
2775 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2777 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2778 new->next
= cons_block
;
2780 cons_block_index
= 0;
2782 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2786 MALLOC_UNBLOCK_INPUT
;
2790 eassert (!CONS_MARKED_P (XCONS (val
)));
2791 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2792 cons_cells_consed
++;
2796 #ifdef GC_CHECK_CONS_LIST
2797 /* Get an error now if there's any junk in the cons free list. */
2799 check_cons_list (void)
2801 struct Lisp_Cons
*tail
= cons_free_list
;
2804 tail
= tail
->u
.chain
;
2808 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2811 list1 (Lisp_Object arg1
)
2813 return Fcons (arg1
, Qnil
);
2817 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2819 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2824 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2826 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2831 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2833 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2838 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2840 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2841 Fcons (arg5
, Qnil
)))));
2845 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2846 doc
: /* Return a newly created list with specified arguments as elements.
2847 Any number of arguments, even zero arguments, are allowed.
2848 usage: (list &rest OBJECTS) */)
2849 (ptrdiff_t nargs
, Lisp_Object
*args
)
2851 register Lisp_Object val
;
2857 val
= Fcons (args
[nargs
], val
);
2863 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2864 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2865 (register Lisp_Object length
, Lisp_Object init
)
2867 register Lisp_Object val
;
2868 register EMACS_INT size
;
2870 CHECK_NATNUM (length
);
2871 size
= XFASTINT (length
);
2876 val
= Fcons (init
, val
);
2881 val
= Fcons (init
, val
);
2886 val
= Fcons (init
, val
);
2891 val
= Fcons (init
, val
);
2896 val
= Fcons (init
, val
);
2911 /***********************************************************************
2913 ***********************************************************************/
2915 /* Singly-linked list of all vectors. */
2917 static struct Lisp_Vector
*all_vectors
;
2919 /* Handy constants for vectorlike objects. */
2922 header_size
= offsetof (struct Lisp_Vector
, contents
),
2923 word_size
= sizeof (Lisp_Object
)
2926 /* Value is a pointer to a newly allocated Lisp_Vector structure
2927 with room for LEN Lisp_Objects. */
2929 static struct Lisp_Vector
*
2930 allocate_vectorlike (EMACS_INT len
)
2932 struct Lisp_Vector
*p
;
2937 #ifdef DOUG_LEA_MALLOC
2938 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2939 because mapped region contents are not preserved in
2941 mallopt (M_MMAP_MAX
, 0);
2944 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2945 /* eassert (!handling_signal); */
2947 nbytes
= header_size
+ len
* word_size
;
2948 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
2950 #ifdef DOUG_LEA_MALLOC
2951 /* Back to a reasonable maximum of mmap'ed areas. */
2952 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2955 consing_since_gc
+= nbytes
;
2956 vector_cells_consed
+= len
;
2958 p
->header
.next
.vector
= all_vectors
;
2961 MALLOC_UNBLOCK_INPUT
;
2967 /* Allocate a vector with LEN slots. */
2969 struct Lisp_Vector
*
2970 allocate_vector (EMACS_INT len
)
2972 struct Lisp_Vector
*v
;
2973 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2975 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2976 memory_full (SIZE_MAX
);
2977 v
= allocate_vectorlike (len
);
2978 v
->header
.size
= len
;
2983 /* Allocate other vector-like structures. */
2985 struct Lisp_Vector
*
2986 allocate_pseudovector (int memlen
, int lisplen
, EMACS_INT tag
)
2988 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2991 /* Only the first lisplen slots will be traced normally by the GC. */
2992 for (i
= 0; i
< lisplen
; ++i
)
2993 v
->contents
[i
] = Qnil
;
2995 XSETPVECTYPESIZE (v
, tag
, lisplen
);
2999 struct Lisp_Hash_Table
*
3000 allocate_hash_table (void)
3002 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
3007 allocate_window (void)
3009 return ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3014 allocate_terminal (void)
3016 struct terminal
*t
= ALLOCATE_PSEUDOVECTOR (struct terminal
,
3017 next_terminal
, PVEC_TERMINAL
);
3018 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3019 memset (&t
->next_terminal
, 0,
3020 (char*) (t
+ 1) - (char*) &t
->next_terminal
);
3026 allocate_frame (void)
3028 struct frame
*f
= ALLOCATE_PSEUDOVECTOR (struct frame
,
3029 face_cache
, PVEC_FRAME
);
3030 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3031 memset (&f
->face_cache
, 0,
3032 (char *) (f
+ 1) - (char *) &f
->face_cache
);
3037 struct Lisp_Process
*
3038 allocate_process (void)
3040 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3044 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3045 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3046 See also the function `vector'. */)
3047 (register Lisp_Object length
, Lisp_Object init
)
3050 register EMACS_INT sizei
;
3051 register EMACS_INT i
;
3052 register struct Lisp_Vector
*p
;
3054 CHECK_NATNUM (length
);
3055 sizei
= XFASTINT (length
);
3057 p
= allocate_vector (sizei
);
3058 for (i
= 0; i
< sizei
; i
++)
3059 p
->contents
[i
] = init
;
3061 XSETVECTOR (vector
, p
);
3066 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3067 doc
: /* Return a newly created vector with specified arguments as elements.
3068 Any number of arguments, even zero arguments, are allowed.
3069 usage: (vector &rest OBJECTS) */)
3070 (ptrdiff_t nargs
, Lisp_Object
*args
)
3072 register Lisp_Object len
, val
;
3074 register struct Lisp_Vector
*p
;
3076 XSETFASTINT (len
, nargs
);
3077 val
= Fmake_vector (len
, Qnil
);
3079 for (i
= 0; i
< nargs
; i
++)
3080 p
->contents
[i
] = args
[i
];
3085 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3086 doc
: /* Create a byte-code object with specified arguments as elements.
3087 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3088 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3089 and (optional) INTERACTIVE-SPEC.
3090 The first four arguments are required; at most six have any
3092 The ARGLIST can be either like the one of `lambda', in which case the arguments
3093 will be dynamically bound before executing the byte code, or it can be an
3094 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3095 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3096 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3097 argument to catch the left-over arguments. If such an integer is used, the
3098 arguments will not be dynamically bound but will be instead pushed on the
3099 stack before executing the byte-code.
3100 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3101 (ptrdiff_t nargs
, Lisp_Object
*args
)
3103 register Lisp_Object len
, val
;
3105 register struct Lisp_Vector
*p
;
3107 XSETFASTINT (len
, nargs
);
3108 if (!NILP (Vpurify_flag
))
3109 val
= make_pure_vector (nargs
);
3111 val
= Fmake_vector (len
, Qnil
);
3113 if (nargs
> 1 && STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3114 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3115 earlier because they produced a raw 8-bit string for byte-code
3116 and now such a byte-code string is loaded as multibyte while
3117 raw 8-bit characters converted to multibyte form. Thus, now we
3118 must convert them back to the original unibyte form. */
3119 args
[1] = Fstring_as_unibyte (args
[1]);
3122 for (i
= 0; i
< nargs
; i
++)
3124 if (!NILP (Vpurify_flag
))
3125 args
[i
] = Fpurecopy (args
[i
]);
3126 p
->contents
[i
] = args
[i
];
3128 XSETPVECTYPE (p
, PVEC_COMPILED
);
3129 XSETCOMPILED (val
, p
);
3135 /***********************************************************************
3137 ***********************************************************************/
3139 /* Each symbol_block is just under 1020 bytes long, since malloc
3140 really allocates in units of powers of two and uses 4 bytes for its
3143 #define SYMBOL_BLOCK_SIZE \
3144 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3148 /* Place `symbols' first, to preserve alignment. */
3149 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3150 struct symbol_block
*next
;
3153 /* Current symbol block and index of first unused Lisp_Symbol
3156 static struct symbol_block
*symbol_block
;
3157 static int symbol_block_index
;
3159 /* List of free symbols. */
3161 static struct Lisp_Symbol
*symbol_free_list
;
3164 /* Initialize symbol allocation. */
3169 symbol_block
= NULL
;
3170 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3171 symbol_free_list
= 0;
3175 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3176 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3177 Its value and function definition are void, and its property list is nil. */)
3180 register Lisp_Object val
;
3181 register struct Lisp_Symbol
*p
;
3183 CHECK_STRING (name
);
3185 /* eassert (!handling_signal); */
3189 if (symbol_free_list
)
3191 XSETSYMBOL (val
, symbol_free_list
);
3192 symbol_free_list
= symbol_free_list
->next
;
3196 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3198 struct symbol_block
*new;
3199 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3201 new->next
= symbol_block
;
3203 symbol_block_index
= 0;
3205 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3206 symbol_block_index
++;
3209 MALLOC_UNBLOCK_INPUT
;
3214 p
->redirect
= SYMBOL_PLAINVAL
;
3215 SET_SYMBOL_VAL (p
, Qunbound
);
3216 p
->function
= Qunbound
;
3219 p
->interned
= SYMBOL_UNINTERNED
;
3221 p
->declared_special
= 0;
3222 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3229 /***********************************************************************
3230 Marker (Misc) Allocation
3231 ***********************************************************************/
3233 /* Allocation of markers and other objects that share that structure.
3234 Works like allocation of conses. */
3236 #define MARKER_BLOCK_SIZE \
3237 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3241 /* Place `markers' first, to preserve alignment. */
3242 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3243 struct marker_block
*next
;
3246 static struct marker_block
*marker_block
;
3247 static int marker_block_index
;
3249 static union Lisp_Misc
*marker_free_list
;
3254 marker_block
= NULL
;
3255 marker_block_index
= MARKER_BLOCK_SIZE
;
3256 marker_free_list
= 0;
3259 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3262 allocate_misc (void)
3266 /* eassert (!handling_signal); */
3270 if (marker_free_list
)
3272 XSETMISC (val
, marker_free_list
);
3273 marker_free_list
= marker_free_list
->u_free
.chain
;
3277 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3279 struct marker_block
*new;
3280 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3282 new->next
= marker_block
;
3284 marker_block_index
= 0;
3285 total_free_markers
+= MARKER_BLOCK_SIZE
;
3287 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3288 marker_block_index
++;
3291 MALLOC_UNBLOCK_INPUT
;
3293 --total_free_markers
;
3294 consing_since_gc
+= sizeof (union Lisp_Misc
);
3295 misc_objects_consed
++;
3296 XMISCANY (val
)->gcmarkbit
= 0;
3300 /* Free a Lisp_Misc object */
3303 free_misc (Lisp_Object misc
)
3305 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3306 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3307 marker_free_list
= XMISC (misc
);
3309 total_free_markers
++;
3312 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3313 INTEGER. This is used to package C values to call record_unwind_protect.
3314 The unwind function can get the C values back using XSAVE_VALUE. */
3317 make_save_value (void *pointer
, ptrdiff_t integer
)
3319 register Lisp_Object val
;
3320 register struct Lisp_Save_Value
*p
;
3322 val
= allocate_misc ();
3323 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3324 p
= XSAVE_VALUE (val
);
3325 p
->pointer
= pointer
;
3326 p
->integer
= integer
;
3331 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3332 doc
: /* Return a newly allocated marker which does not point at any place. */)
3335 register Lisp_Object val
;
3336 register struct Lisp_Marker
*p
;
3338 val
= allocate_misc ();
3339 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3345 p
->insertion_type
= 0;
3349 /* Put MARKER back on the free list after using it temporarily. */
3352 free_marker (Lisp_Object marker
)
3354 unchain_marker (XMARKER (marker
));
3359 /* Return a newly created vector or string with specified arguments as
3360 elements. If all the arguments are characters that can fit
3361 in a string of events, make a string; otherwise, make a vector.
3363 Any number of arguments, even zero arguments, are allowed. */
3366 make_event_array (register int nargs
, Lisp_Object
*args
)
3370 for (i
= 0; i
< nargs
; i
++)
3371 /* The things that fit in a string
3372 are characters that are in 0...127,
3373 after discarding the meta bit and all the bits above it. */
3374 if (!INTEGERP (args
[i
])
3375 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3376 return Fvector (nargs
, args
);
3378 /* Since the loop exited, we know that all the things in it are
3379 characters, so we can make a string. */
3383 result
= Fmake_string (make_number (nargs
), make_number (0));
3384 for (i
= 0; i
< nargs
; i
++)
3386 SSET (result
, i
, XINT (args
[i
]));
3387 /* Move the meta bit to the right place for a string char. */
3388 if (XINT (args
[i
]) & CHAR_META
)
3389 SSET (result
, i
, SREF (result
, i
) | 0x80);
3398 /************************************************************************
3399 Memory Full Handling
3400 ************************************************************************/
3403 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3404 there may have been size_t overflow so that malloc was never
3405 called, or perhaps malloc was invoked successfully but the
3406 resulting pointer had problems fitting into a tagged EMACS_INT. In
3407 either case this counts as memory being full even though malloc did
3411 memory_full (size_t nbytes
)
3413 /* Do not go into hysterics merely because a large request failed. */
3414 int enough_free_memory
= 0;
3415 if (SPARE_MEMORY
< nbytes
)
3420 p
= malloc (SPARE_MEMORY
);
3424 enough_free_memory
= 1;
3426 MALLOC_UNBLOCK_INPUT
;
3429 if (! enough_free_memory
)
3435 memory_full_cons_threshold
= sizeof (struct cons_block
);
3437 /* The first time we get here, free the spare memory. */
3438 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3439 if (spare_memory
[i
])
3442 free (spare_memory
[i
]);
3443 else if (i
>= 1 && i
<= 4)
3444 lisp_align_free (spare_memory
[i
]);
3446 lisp_free (spare_memory
[i
]);
3447 spare_memory
[i
] = 0;
3450 /* Record the space now used. When it decreases substantially,
3451 we can refill the memory reserve. */
3452 #if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3453 bytes_used_when_full
= BYTES_USED
;
3457 /* This used to call error, but if we've run out of memory, we could
3458 get infinite recursion trying to build the string. */
3459 xsignal (Qnil
, Vmemory_signal_data
);
3462 /* If we released our reserve (due to running out of memory),
3463 and we have a fair amount free once again,
3464 try to set aside another reserve in case we run out once more.
3466 This is called when a relocatable block is freed in ralloc.c,
3467 and also directly from this file, in case we're not using ralloc.c. */
3470 refill_memory_reserve (void)
3472 #ifndef SYSTEM_MALLOC
3473 if (spare_memory
[0] == 0)
3474 spare_memory
[0] = (char *) malloc (SPARE_MEMORY
);
3475 if (spare_memory
[1] == 0)
3476 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3478 if (spare_memory
[2] == 0)
3479 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3481 if (spare_memory
[3] == 0)
3482 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3484 if (spare_memory
[4] == 0)
3485 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3487 if (spare_memory
[5] == 0)
3488 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3490 if (spare_memory
[6] == 0)
3491 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3493 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3494 Vmemory_full
= Qnil
;
3498 /************************************************************************
3500 ************************************************************************/
3502 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3504 /* Conservative C stack marking requires a method to identify possibly
3505 live Lisp objects given a pointer value. We do this by keeping
3506 track of blocks of Lisp data that are allocated in a red-black tree
3507 (see also the comment of mem_node which is the type of nodes in
3508 that tree). Function lisp_malloc adds information for an allocated
3509 block to the red-black tree with calls to mem_insert, and function
3510 lisp_free removes it with mem_delete. Functions live_string_p etc
3511 call mem_find to lookup information about a given pointer in the
3512 tree, and use that to determine if the pointer points to a Lisp
3515 /* Initialize this part of alloc.c. */
3520 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3521 mem_z
.parent
= NULL
;
3522 mem_z
.color
= MEM_BLACK
;
3523 mem_z
.start
= mem_z
.end
= NULL
;
3528 /* Value is a pointer to the mem_node containing START. Value is
3529 MEM_NIL if there is no node in the tree containing START. */
3531 static inline struct mem_node
*
3532 mem_find (void *start
)
3536 if (start
< min_heap_address
|| start
> max_heap_address
)
3539 /* Make the search always successful to speed up the loop below. */
3540 mem_z
.start
= start
;
3541 mem_z
.end
= (char *) start
+ 1;
3544 while (start
< p
->start
|| start
>= p
->end
)
3545 p
= start
< p
->start
? p
->left
: p
->right
;
3550 /* Insert a new node into the tree for a block of memory with start
3551 address START, end address END, and type TYPE. Value is a
3552 pointer to the node that was inserted. */
3554 static struct mem_node
*
3555 mem_insert (void *start
, void *end
, enum mem_type type
)
3557 struct mem_node
*c
, *parent
, *x
;
3559 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3560 min_heap_address
= start
;
3561 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3562 max_heap_address
= end
;
3564 /* See where in the tree a node for START belongs. In this
3565 particular application, it shouldn't happen that a node is already
3566 present. For debugging purposes, let's check that. */
3570 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3572 while (c
!= MEM_NIL
)
3574 if (start
>= c
->start
&& start
< c
->end
)
3577 c
= start
< c
->start
? c
->left
: c
->right
;
3580 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3582 while (c
!= MEM_NIL
)
3585 c
= start
< c
->start
? c
->left
: c
->right
;
3588 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3590 /* Create a new node. */
3591 #ifdef GC_MALLOC_CHECK
3592 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3596 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3602 x
->left
= x
->right
= MEM_NIL
;
3605 /* Insert it as child of PARENT or install it as root. */
3608 if (start
< parent
->start
)
3616 /* Re-establish red-black tree properties. */
3617 mem_insert_fixup (x
);
3623 /* Re-establish the red-black properties of the tree, and thereby
3624 balance the tree, after node X has been inserted; X is always red. */
3627 mem_insert_fixup (struct mem_node
*x
)
3629 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3631 /* X is red and its parent is red. This is a violation of
3632 red-black tree property #3. */
3634 if (x
->parent
== x
->parent
->parent
->left
)
3636 /* We're on the left side of our grandparent, and Y is our
3638 struct mem_node
*y
= x
->parent
->parent
->right
;
3640 if (y
->color
== MEM_RED
)
3642 /* Uncle and parent are red but should be black because
3643 X is red. Change the colors accordingly and proceed
3644 with the grandparent. */
3645 x
->parent
->color
= MEM_BLACK
;
3646 y
->color
= MEM_BLACK
;
3647 x
->parent
->parent
->color
= MEM_RED
;
3648 x
= x
->parent
->parent
;
3652 /* Parent and uncle have different colors; parent is
3653 red, uncle is black. */
3654 if (x
== x
->parent
->right
)
3657 mem_rotate_left (x
);
3660 x
->parent
->color
= MEM_BLACK
;
3661 x
->parent
->parent
->color
= MEM_RED
;
3662 mem_rotate_right (x
->parent
->parent
);
3667 /* This is the symmetrical case of above. */
3668 struct mem_node
*y
= x
->parent
->parent
->left
;
3670 if (y
->color
== MEM_RED
)
3672 x
->parent
->color
= MEM_BLACK
;
3673 y
->color
= MEM_BLACK
;
3674 x
->parent
->parent
->color
= MEM_RED
;
3675 x
= x
->parent
->parent
;
3679 if (x
== x
->parent
->left
)
3682 mem_rotate_right (x
);
3685 x
->parent
->color
= MEM_BLACK
;
3686 x
->parent
->parent
->color
= MEM_RED
;
3687 mem_rotate_left (x
->parent
->parent
);
3692 /* The root may have been changed to red due to the algorithm. Set
3693 it to black so that property #5 is satisfied. */
3694 mem_root
->color
= MEM_BLACK
;
3705 mem_rotate_left (struct mem_node
*x
)
3709 /* Turn y's left sub-tree into x's right sub-tree. */
3712 if (y
->left
!= MEM_NIL
)
3713 y
->left
->parent
= x
;
3715 /* Y's parent was x's parent. */
3717 y
->parent
= x
->parent
;
3719 /* Get the parent to point to y instead of x. */
3722 if (x
== x
->parent
->left
)
3723 x
->parent
->left
= y
;
3725 x
->parent
->right
= y
;
3730 /* Put x on y's left. */
3744 mem_rotate_right (struct mem_node
*x
)
3746 struct mem_node
*y
= x
->left
;
3749 if (y
->right
!= MEM_NIL
)
3750 y
->right
->parent
= x
;
3753 y
->parent
= x
->parent
;
3756 if (x
== x
->parent
->right
)
3757 x
->parent
->right
= y
;
3759 x
->parent
->left
= y
;
3770 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3773 mem_delete (struct mem_node
*z
)
3775 struct mem_node
*x
, *y
;
3777 if (!z
|| z
== MEM_NIL
)
3780 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3785 while (y
->left
!= MEM_NIL
)
3789 if (y
->left
!= MEM_NIL
)
3794 x
->parent
= y
->parent
;
3797 if (y
== y
->parent
->left
)
3798 y
->parent
->left
= x
;
3800 y
->parent
->right
= x
;
3807 z
->start
= y
->start
;
3812 if (y
->color
== MEM_BLACK
)
3813 mem_delete_fixup (x
);
3815 #ifdef GC_MALLOC_CHECK
3823 /* Re-establish the red-black properties of the tree, after a
3827 mem_delete_fixup (struct mem_node
*x
)
3829 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3831 if (x
== x
->parent
->left
)
3833 struct mem_node
*w
= x
->parent
->right
;
3835 if (w
->color
== MEM_RED
)
3837 w
->color
= MEM_BLACK
;
3838 x
->parent
->color
= MEM_RED
;
3839 mem_rotate_left (x
->parent
);
3840 w
= x
->parent
->right
;
3843 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3850 if (w
->right
->color
== MEM_BLACK
)
3852 w
->left
->color
= MEM_BLACK
;
3854 mem_rotate_right (w
);
3855 w
= x
->parent
->right
;
3857 w
->color
= x
->parent
->color
;
3858 x
->parent
->color
= MEM_BLACK
;
3859 w
->right
->color
= MEM_BLACK
;
3860 mem_rotate_left (x
->parent
);
3866 struct mem_node
*w
= x
->parent
->left
;
3868 if (w
->color
== MEM_RED
)
3870 w
->color
= MEM_BLACK
;
3871 x
->parent
->color
= MEM_RED
;
3872 mem_rotate_right (x
->parent
);
3873 w
= x
->parent
->left
;
3876 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3883 if (w
->left
->color
== MEM_BLACK
)
3885 w
->right
->color
= MEM_BLACK
;
3887 mem_rotate_left (w
);
3888 w
= x
->parent
->left
;
3891 w
->color
= x
->parent
->color
;
3892 x
->parent
->color
= MEM_BLACK
;
3893 w
->left
->color
= MEM_BLACK
;
3894 mem_rotate_right (x
->parent
);
3900 x
->color
= MEM_BLACK
;
3904 /* Value is non-zero if P is a pointer to a live Lisp string on
3905 the heap. M is a pointer to the mem_block for P. */
3908 live_string_p (struct mem_node
*m
, void *p
)
3910 if (m
->type
== MEM_TYPE_STRING
)
3912 struct string_block
*b
= (struct string_block
*) m
->start
;
3913 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3915 /* P must point to the start of a Lisp_String structure, and it
3916 must not be on the free-list. */
3918 && offset
% sizeof b
->strings
[0] == 0
3919 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3920 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3927 /* Value is non-zero if P is a pointer to a live Lisp cons on
3928 the heap. M is a pointer to the mem_block for P. */
3931 live_cons_p (struct mem_node
*m
, void *p
)
3933 if (m
->type
== MEM_TYPE_CONS
)
3935 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3936 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
3938 /* P must point to the start of a Lisp_Cons, not be
3939 one of the unused cells in the current cons block,
3940 and not be on the free-list. */
3942 && offset
% sizeof b
->conses
[0] == 0
3943 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3945 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3946 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3953 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3954 the heap. M is a pointer to the mem_block for P. */
3957 live_symbol_p (struct mem_node
*m
, void *p
)
3959 if (m
->type
== MEM_TYPE_SYMBOL
)
3961 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3962 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
3964 /* P must point to the start of a Lisp_Symbol, not be
3965 one of the unused cells in the current symbol block,
3966 and not be on the free-list. */
3968 && offset
% sizeof b
->symbols
[0] == 0
3969 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3970 && (b
!= symbol_block
3971 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3972 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3979 /* Value is non-zero if P is a pointer to a live Lisp float on
3980 the heap. M is a pointer to the mem_block for P. */
3983 live_float_p (struct mem_node
*m
, void *p
)
3985 if (m
->type
== MEM_TYPE_FLOAT
)
3987 struct float_block
*b
= (struct float_block
*) m
->start
;
3988 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
3990 /* P must point to the start of a Lisp_Float and not be
3991 one of the unused cells in the current float block. */
3993 && offset
% sizeof b
->floats
[0] == 0
3994 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3995 && (b
!= float_block
3996 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4003 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4004 the heap. M is a pointer to the mem_block for P. */
4007 live_misc_p (struct mem_node
*m
, void *p
)
4009 if (m
->type
== MEM_TYPE_MISC
)
4011 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4012 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4014 /* P must point to the start of a Lisp_Misc, not be
4015 one of the unused cells in the current misc block,
4016 and not be on the free-list. */
4018 && offset
% sizeof b
->markers
[0] == 0
4019 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4020 && (b
!= marker_block
4021 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4022 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4029 /* Value is non-zero if P is a pointer to a live vector-like object.
4030 M is a pointer to the mem_block for P. */
4033 live_vector_p (struct mem_node
*m
, void *p
)
4035 return (p
== m
->start
&& m
->type
== MEM_TYPE_VECTORLIKE
);
4039 /* Value is non-zero if P is a pointer to a live buffer. M is a
4040 pointer to the mem_block for P. */
4043 live_buffer_p (struct mem_node
*m
, void *p
)
4045 /* P must point to the start of the block, and the buffer
4046 must not have been killed. */
4047 return (m
->type
== MEM_TYPE_BUFFER
4049 && !NILP (((struct buffer
*) p
)->BUFFER_INTERNAL_FIELD (name
)));
4052 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4056 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4058 /* Array of objects that are kept alive because the C stack contains
4059 a pattern that looks like a reference to them . */
4061 #define MAX_ZOMBIES 10
4062 static Lisp_Object zombies
[MAX_ZOMBIES
];
4064 /* Number of zombie objects. */
4066 static EMACS_INT nzombies
;
4068 /* Number of garbage collections. */
4070 static EMACS_INT ngcs
;
4072 /* Average percentage of zombies per collection. */
4074 static double avg_zombies
;
4076 /* Max. number of live and zombie objects. */
4078 static EMACS_INT max_live
, max_zombies
;
4080 /* Average number of live objects per GC. */
4082 static double avg_live
;
4084 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4085 doc
: /* Show information about live and zombie objects. */)
4088 Lisp_Object args
[8], zombie_list
= Qnil
;
4090 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4091 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4092 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4093 args
[1] = make_number (ngcs
);
4094 args
[2] = make_float (avg_live
);
4095 args
[3] = make_float (avg_zombies
);
4096 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4097 args
[5] = make_number (max_live
);
4098 args
[6] = make_number (max_zombies
);
4099 args
[7] = zombie_list
;
4100 return Fmessage (8, args
);
4103 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4106 /* Mark OBJ if we can prove it's a Lisp_Object. */
4109 mark_maybe_object (Lisp_Object obj
)
4117 po
= (void *) XPNTR (obj
);
4124 switch (XTYPE (obj
))
4127 mark_p
= (live_string_p (m
, po
)
4128 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4132 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4136 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4140 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4143 case Lisp_Vectorlike
:
4144 /* Note: can't check BUFFERP before we know it's a
4145 buffer because checking that dereferences the pointer
4146 PO which might point anywhere. */
4147 if (live_vector_p (m
, po
))
4148 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4149 else if (live_buffer_p (m
, po
))
4150 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4154 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4163 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4164 if (nzombies
< MAX_ZOMBIES
)
4165 zombies
[nzombies
] = obj
;
4174 /* If P points to Lisp data, mark that as live if it isn't already
4178 mark_maybe_pointer (void *p
)
4182 /* Quickly rule out some values which can't point to Lisp data. */
4185 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4187 2 /* We assume that Lisp data is aligned on even addresses. */
4195 Lisp_Object obj
= Qnil
;
4199 case MEM_TYPE_NON_LISP
:
4200 /* Nothing to do; not a pointer to Lisp memory. */
4203 case MEM_TYPE_BUFFER
:
4204 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4205 XSETVECTOR (obj
, p
);
4209 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4213 case MEM_TYPE_STRING
:
4214 if (live_string_p (m
, p
)
4215 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4216 XSETSTRING (obj
, p
);
4220 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4224 case MEM_TYPE_SYMBOL
:
4225 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4226 XSETSYMBOL (obj
, p
);
4229 case MEM_TYPE_FLOAT
:
4230 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4234 case MEM_TYPE_VECTORLIKE
:
4235 if (live_vector_p (m
, p
))
4238 XSETVECTOR (tem
, p
);
4239 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4254 /* Alignment of pointer values. Use offsetof, as it sometimes returns
4255 a smaller alignment than GCC's __alignof__ and mark_memory might
4256 miss objects if __alignof__ were used. */
4257 #define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
4259 /* Define POINTERS_MIGHT_HIDE_IN_OBJECTS to 1 if marking via C pointers does
4260 not suffice, which is the typical case. A host where a Lisp_Object is
4261 wider than a pointer might allocate a Lisp_Object in non-adjacent halves.
4262 If USE_LSB_TAG, the bottom half is not a valid pointer, but it should
4263 suffice to widen it to to a Lisp_Object and check it that way. */
4264 #if defined USE_LSB_TAG || UINTPTR_MAX >> VALBITS != 0
4265 # if !defined USE_LSB_TAG && UINTPTR_MAX >> VALBITS >> GCTYPEBITS != 0
4266 /* If tag bits straddle pointer-word boundaries, neither mark_maybe_pointer
4267 nor mark_maybe_object can follow the pointers. This should not occur on
4268 any practical porting target. */
4269 # error "MSB type bits straddle pointer-word boundaries"
4271 /* Marking via C pointers does not suffice, because Lisp_Objects contain
4272 pointer words that hold pointers ORed with type bits. */
4273 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 1
4275 /* Marking via C pointers suffices, because Lisp_Objects contain pointer
4276 words that hold unmodified pointers. */
4277 # define POINTERS_MIGHT_HIDE_IN_OBJECTS 0
4280 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4281 or END+OFFSET..START. */
4284 mark_memory (void *start
, void *end
)
4289 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4293 /* Make START the pointer to the start of the memory region,
4294 if it isn't already. */
4302 /* Mark Lisp data pointed to. This is necessary because, in some
4303 situations, the C compiler optimizes Lisp objects away, so that
4304 only a pointer to them remains. Example:
4306 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4309 Lisp_Object obj = build_string ("test");
4310 struct Lisp_String *s = XSTRING (obj);
4311 Fgarbage_collect ();
4312 fprintf (stderr, "test `%s'\n", s->data);
4316 Here, `obj' isn't really used, and the compiler optimizes it
4317 away. The only reference to the life string is through the
4320 for (pp
= start
; (void *) pp
< end
; pp
++)
4321 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4323 void *p
= *(void **) ((char *) pp
+ i
);
4324 mark_maybe_pointer (p
);
4325 if (POINTERS_MIGHT_HIDE_IN_OBJECTS
)
4326 mark_maybe_object (widen_to_Lisp_Object (p
));
4330 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4331 the GCC system configuration. In gcc 3.2, the only systems for
4332 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4333 by others?) and ns32k-pc532-min. */
4335 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4337 static int setjmp_tested_p
, longjmps_done
;
4339 #define SETJMP_WILL_LIKELY_WORK "\
4341 Emacs garbage collector has been changed to use conservative stack\n\
4342 marking. Emacs has determined that the method it uses to do the\n\
4343 marking will likely work on your system, but this isn't sure.\n\
4345 If you are a system-programmer, or can get the help of a local wizard\n\
4346 who is, please take a look at the function mark_stack in alloc.c, and\n\
4347 verify that the methods used are appropriate for your system.\n\
4349 Please mail the result to <emacs-devel@gnu.org>.\n\
4352 #define SETJMP_WILL_NOT_WORK "\
4354 Emacs garbage collector has been changed to use conservative stack\n\
4355 marking. Emacs has determined that the default method it uses to do the\n\
4356 marking will not work on your system. We will need a system-dependent\n\
4357 solution for your system.\n\
4359 Please take a look at the function mark_stack in alloc.c, and\n\
4360 try to find a way to make it work on your system.\n\
4362 Note that you may get false negatives, depending on the compiler.\n\
4363 In particular, you need to use -O with GCC for this test.\n\
4365 Please mail the result to <emacs-devel@gnu.org>.\n\
4369 /* Perform a quick check if it looks like setjmp saves registers in a
4370 jmp_buf. Print a message to stderr saying so. When this test
4371 succeeds, this is _not_ a proof that setjmp is sufficient for
4372 conservative stack marking. Only the sources or a disassembly
4383 /* Arrange for X to be put in a register. */
4389 if (longjmps_done
== 1)
4391 /* Came here after the longjmp at the end of the function.
4393 If x == 1, the longjmp has restored the register to its
4394 value before the setjmp, and we can hope that setjmp
4395 saves all such registers in the jmp_buf, although that
4398 For other values of X, either something really strange is
4399 taking place, or the setjmp just didn't save the register. */
4402 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4405 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4412 if (longjmps_done
== 1)
4416 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4419 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4421 /* Abort if anything GCPRO'd doesn't survive the GC. */
4429 for (p
= gcprolist
; p
; p
= p
->next
)
4430 for (i
= 0; i
< p
->nvars
; ++i
)
4431 if (!survives_gc_p (p
->var
[i
]))
4432 /* FIXME: It's not necessarily a bug. It might just be that the
4433 GCPRO is unnecessary or should release the object sooner. */
4437 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4444 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4445 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4447 fprintf (stderr
, " %d = ", i
);
4448 debug_print (zombies
[i
]);
4452 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4455 /* Mark live Lisp objects on the C stack.
4457 There are several system-dependent problems to consider when
4458 porting this to new architectures:
4462 We have to mark Lisp objects in CPU registers that can hold local
4463 variables or are used to pass parameters.
4465 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4466 something that either saves relevant registers on the stack, or
4467 calls mark_maybe_object passing it each register's contents.
4469 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4470 implementation assumes that calling setjmp saves registers we need
4471 to see in a jmp_buf which itself lies on the stack. This doesn't
4472 have to be true! It must be verified for each system, possibly
4473 by taking a look at the source code of setjmp.
4475 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4476 can use it as a machine independent method to store all registers
4477 to the stack. In this case the macros described in the previous
4478 two paragraphs are not used.
4482 Architectures differ in the way their processor stack is organized.
4483 For example, the stack might look like this
4486 | Lisp_Object | size = 4
4488 | something else | size = 2
4490 | Lisp_Object | size = 4
4494 In such a case, not every Lisp_Object will be aligned equally. To
4495 find all Lisp_Object on the stack it won't be sufficient to walk
4496 the stack in steps of 4 bytes. Instead, two passes will be
4497 necessary, one starting at the start of the stack, and a second
4498 pass starting at the start of the stack + 2. Likewise, if the
4499 minimal alignment of Lisp_Objects on the stack is 1, four passes
4500 would be necessary, each one starting with one byte more offset
4501 from the stack start. */
4508 #ifdef HAVE___BUILTIN_UNWIND_INIT
4509 /* Force callee-saved registers and register windows onto the stack.
4510 This is the preferred method if available, obviating the need for
4511 machine dependent methods. */
4512 __builtin_unwind_init ();
4514 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4515 #ifndef GC_SAVE_REGISTERS_ON_STACK
4516 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4517 union aligned_jmpbuf
{
4521 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4523 /* This trick flushes the register windows so that all the state of
4524 the process is contained in the stack. */
4525 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4526 needed on ia64 too. See mach_dep.c, where it also says inline
4527 assembler doesn't work with relevant proprietary compilers. */
4529 #if defined (__sparc64__) && defined (__FreeBSD__)
4530 /* FreeBSD does not have a ta 3 handler. */
4537 /* Save registers that we need to see on the stack. We need to see
4538 registers used to hold register variables and registers used to
4540 #ifdef GC_SAVE_REGISTERS_ON_STACK
4541 GC_SAVE_REGISTERS_ON_STACK (end
);
4542 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4544 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4545 setjmp will definitely work, test it
4546 and print a message with the result
4548 if (!setjmp_tested_p
)
4550 setjmp_tested_p
= 1;
4553 #endif /* GC_SETJMP_WORKS */
4556 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4557 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4558 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4560 /* This assumes that the stack is a contiguous region in memory. If
4561 that's not the case, something has to be done here to iterate
4562 over the stack segments. */
4563 mark_memory (stack_base
, end
);
4565 /* Allow for marking a secondary stack, like the register stack on the
4567 #ifdef GC_MARK_SECONDARY_STACK
4568 GC_MARK_SECONDARY_STACK ();
4571 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4576 #endif /* GC_MARK_STACK != 0 */
4579 /* Determine whether it is safe to access memory at address P. */
4581 valid_pointer_p (void *p
)
4584 return w32_valid_pointer_p (p
, 16);
4588 /* Obviously, we cannot just access it (we would SEGV trying), so we
4589 trick the o/s to tell us whether p is a valid pointer.
4590 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4591 not validate p in that case. */
4595 int valid
= (emacs_write (fd
[1], (char *) p
, 16) == 16);
4596 emacs_close (fd
[1]);
4597 emacs_close (fd
[0]);
4605 /* Return 1 if OBJ is a valid lisp object.
4606 Return 0 if OBJ is NOT a valid lisp object.
4607 Return -1 if we cannot validate OBJ.
4608 This function can be quite slow,
4609 so it should only be used in code for manual debugging. */
4612 valid_lisp_object_p (Lisp_Object obj
)
4622 p
= (void *) XPNTR (obj
);
4623 if (PURE_POINTER_P (p
))
4627 return valid_pointer_p (p
);
4634 int valid
= valid_pointer_p (p
);
4646 case MEM_TYPE_NON_LISP
:
4649 case MEM_TYPE_BUFFER
:
4650 return live_buffer_p (m
, p
);
4653 return live_cons_p (m
, p
);
4655 case MEM_TYPE_STRING
:
4656 return live_string_p (m
, p
);
4659 return live_misc_p (m
, p
);
4661 case MEM_TYPE_SYMBOL
:
4662 return live_symbol_p (m
, p
);
4664 case MEM_TYPE_FLOAT
:
4665 return live_float_p (m
, p
);
4667 case MEM_TYPE_VECTORLIKE
:
4668 return live_vector_p (m
, p
);
4681 /***********************************************************************
4682 Pure Storage Management
4683 ***********************************************************************/
4685 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4686 pointer to it. TYPE is the Lisp type for which the memory is
4687 allocated. TYPE < 0 means it's not used for a Lisp object. */
4689 static POINTER_TYPE
*
4690 pure_alloc (size_t size
, int type
)
4692 POINTER_TYPE
*result
;
4694 size_t alignment
= (1 << GCTYPEBITS
);
4696 size_t alignment
= sizeof (EMACS_INT
);
4698 /* Give Lisp_Floats an extra alignment. */
4699 if (type
== Lisp_Float
)
4701 #if defined __GNUC__ && __GNUC__ >= 2
4702 alignment
= __alignof (struct Lisp_Float
);
4704 alignment
= sizeof (struct Lisp_Float
);
4712 /* Allocate space for a Lisp object from the beginning of the free
4713 space with taking account of alignment. */
4714 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4715 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4719 /* Allocate space for a non-Lisp object from the end of the free
4721 pure_bytes_used_non_lisp
+= size
;
4722 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4724 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4726 if (pure_bytes_used
<= pure_size
)
4729 /* Don't allocate a large amount here,
4730 because it might get mmap'd and then its address
4731 might not be usable. */
4732 purebeg
= (char *) xmalloc (10000);
4734 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4735 pure_bytes_used
= 0;
4736 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4741 /* Print a warning if PURESIZE is too small. */
4744 check_pure_size (void)
4746 if (pure_bytes_used_before_overflow
)
4747 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4749 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4753 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4754 the non-Lisp data pool of the pure storage, and return its start
4755 address. Return NULL if not found. */
4758 find_string_data_in_pure (const char *data
, EMACS_INT nbytes
)
4761 EMACS_INT skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4762 const unsigned char *p
;
4765 if (pure_bytes_used_non_lisp
< nbytes
+ 1)
4768 /* Set up the Boyer-Moore table. */
4770 for (i
= 0; i
< 256; i
++)
4773 p
= (const unsigned char *) data
;
4775 bm_skip
[*p
++] = skip
;
4777 last_char_skip
= bm_skip
['\0'];
4779 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4780 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4782 /* See the comments in the function `boyer_moore' (search.c) for the
4783 use of `infinity'. */
4784 infinity
= pure_bytes_used_non_lisp
+ 1;
4785 bm_skip
['\0'] = infinity
;
4787 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4791 /* Check the last character (== '\0'). */
4794 start
+= bm_skip
[*(p
+ start
)];
4796 while (start
<= start_max
);
4798 if (start
< infinity
)
4799 /* Couldn't find the last character. */
4802 /* No less than `infinity' means we could find the last
4803 character at `p[start - infinity]'. */
4806 /* Check the remaining characters. */
4807 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4809 return non_lisp_beg
+ start
;
4811 start
+= last_char_skip
;
4813 while (start
<= start_max
);
4819 /* Return a string allocated in pure space. DATA is a buffer holding
4820 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4821 non-zero means make the result string multibyte.
4823 Must get an error if pure storage is full, since if it cannot hold
4824 a large string it may be able to hold conses that point to that
4825 string; then the string is not protected from gc. */
4828 make_pure_string (const char *data
,
4829 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
4832 struct Lisp_String
*s
;
4834 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4835 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4836 if (s
->data
== NULL
)
4838 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4839 memcpy (s
->data
, data
, nbytes
);
4840 s
->data
[nbytes
] = '\0';
4843 s
->size_byte
= multibyte
? nbytes
: -1;
4844 s
->intervals
= NULL_INTERVAL
;
4845 XSETSTRING (string
, s
);
4849 /* Return a string a string allocated in pure space. Do not allocate
4850 the string data, just point to DATA. */
4853 make_pure_c_string (const char *data
)
4856 struct Lisp_String
*s
;
4857 EMACS_INT nchars
= strlen (data
);
4859 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4862 s
->data
= (unsigned char *) data
;
4863 s
->intervals
= NULL_INTERVAL
;
4864 XSETSTRING (string
, s
);
4868 /* Return a cons allocated from pure space. Give it pure copies
4869 of CAR as car and CDR as cdr. */
4872 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4874 register Lisp_Object
new;
4875 struct Lisp_Cons
*p
;
4877 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4879 XSETCAR (new, Fpurecopy (car
));
4880 XSETCDR (new, Fpurecopy (cdr
));
4885 /* Value is a float object with value NUM allocated from pure space. */
4888 make_pure_float (double num
)
4890 register Lisp_Object
new;
4891 struct Lisp_Float
*p
;
4893 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4895 XFLOAT_INIT (new, num
);
4900 /* Return a vector with room for LEN Lisp_Objects allocated from
4904 make_pure_vector (EMACS_INT len
)
4907 struct Lisp_Vector
*p
;
4908 size_t size
= (offsetof (struct Lisp_Vector
, contents
)
4909 + len
* sizeof (Lisp_Object
));
4911 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4912 XSETVECTOR (new, p
);
4913 XVECTOR (new)->header
.size
= len
;
4918 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4919 doc
: /* Make a copy of object OBJ in pure storage.
4920 Recursively copies contents of vectors and cons cells.
4921 Does not copy symbols. Copies strings without text properties. */)
4922 (register Lisp_Object obj
)
4924 if (NILP (Vpurify_flag
))
4927 if (PURE_POINTER_P (XPNTR (obj
)))
4930 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4932 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
4938 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
4939 else if (FLOATP (obj
))
4940 obj
= make_pure_float (XFLOAT_DATA (obj
));
4941 else if (STRINGP (obj
))
4942 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
4944 STRING_MULTIBYTE (obj
));
4945 else if (COMPILEDP (obj
) || VECTORP (obj
))
4947 register struct Lisp_Vector
*vec
;
4948 register EMACS_INT i
;
4952 if (size
& PSEUDOVECTOR_FLAG
)
4953 size
&= PSEUDOVECTOR_SIZE_MASK
;
4954 vec
= XVECTOR (make_pure_vector (size
));
4955 for (i
= 0; i
< size
; i
++)
4956 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4957 if (COMPILEDP (obj
))
4959 XSETPVECTYPE (vec
, PVEC_COMPILED
);
4960 XSETCOMPILED (obj
, vec
);
4963 XSETVECTOR (obj
, vec
);
4965 else if (MARKERP (obj
))
4966 error ("Attempt to copy a marker to pure storage");
4968 /* Not purified, don't hash-cons. */
4971 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4972 Fputhash (obj
, obj
, Vpurify_flag
);
4979 /***********************************************************************
4981 ***********************************************************************/
4983 /* Put an entry in staticvec, pointing at the variable with address
4987 staticpro (Lisp_Object
*varaddress
)
4989 staticvec
[staticidx
++] = varaddress
;
4990 if (staticidx
>= NSTATICS
)
4995 /***********************************************************************
4997 ***********************************************************************/
4999 /* Temporarily prevent garbage collection. */
5002 inhibit_garbage_collection (void)
5004 int count
= SPECPDL_INDEX ();
5006 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
5011 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5012 doc
: /* Reclaim storage for Lisp objects no longer needed.
5013 Garbage collection happens automatically if you cons more than
5014 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5015 `garbage-collect' normally returns a list with info on amount of space in use:
5016 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
5017 (USED-MISCS . FREE-MISCS) USED-STRING-CHARS USED-VECTOR-SLOTS
5018 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
5019 (USED-STRINGS . FREE-STRINGS))
5020 However, if there was overflow in pure space, `garbage-collect'
5021 returns nil, because real GC can't be done.
5022 See Info node `(elisp)Garbage Collection'. */)
5025 register struct specbinding
*bind
;
5026 char stack_top_variable
;
5029 Lisp_Object total
[8];
5030 int count
= SPECPDL_INDEX ();
5031 EMACS_TIME t1
, t2
, t3
;
5036 /* Can't GC if pure storage overflowed because we can't determine
5037 if something is a pure object or not. */
5038 if (pure_bytes_used_before_overflow
)
5043 /* Don't keep undo information around forever.
5044 Do this early on, so it is no problem if the user quits. */
5046 register struct buffer
*nextb
= all_buffers
;
5050 /* If a buffer's undo list is Qt, that means that undo is
5051 turned off in that buffer. Calling truncate_undo_list on
5052 Qt tends to return NULL, which effectively turns undo back on.
5053 So don't call truncate_undo_list if undo_list is Qt. */
5054 if (! NILP (nextb
->BUFFER_INTERNAL_FIELD (name
)) && ! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5055 truncate_undo_list (nextb
);
5057 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5058 if (nextb
->base_buffer
== 0 && !NILP (nextb
->BUFFER_INTERNAL_FIELD (name
))
5059 && ! nextb
->text
->inhibit_shrinking
)
5061 /* If a buffer's gap size is more than 10% of the buffer
5062 size, or larger than 2000 bytes, then shrink it
5063 accordingly. Keep a minimum size of 20 bytes. */
5064 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
5066 if (nextb
->text
->gap_size
> size
)
5068 struct buffer
*save_current
= current_buffer
;
5069 current_buffer
= nextb
;
5070 make_gap (-(nextb
->text
->gap_size
- size
));
5071 current_buffer
= save_current
;
5075 nextb
= nextb
->header
.next
.buffer
;
5079 EMACS_GET_TIME (t1
);
5081 /* In case user calls debug_print during GC,
5082 don't let that cause a recursive GC. */
5083 consing_since_gc
= 0;
5085 /* Save what's currently displayed in the echo area. */
5086 message_p
= push_message ();
5087 record_unwind_protect (pop_message_unwind
, Qnil
);
5089 /* Save a copy of the contents of the stack, for debugging. */
5090 #if MAX_SAVE_STACK > 0
5091 if (NILP (Vpurify_flag
))
5094 ptrdiff_t stack_size
;
5095 if (&stack_top_variable
< stack_bottom
)
5097 stack
= &stack_top_variable
;
5098 stack_size
= stack_bottom
- &stack_top_variable
;
5102 stack
= stack_bottom
;
5103 stack_size
= &stack_top_variable
- stack_bottom
;
5105 if (stack_size
<= MAX_SAVE_STACK
)
5107 if (stack_copy_size
< stack_size
)
5109 stack_copy
= (char *) xrealloc (stack_copy
, stack_size
);
5110 stack_copy_size
= stack_size
;
5112 memcpy (stack_copy
, stack
, stack_size
);
5115 #endif /* MAX_SAVE_STACK > 0 */
5117 if (garbage_collection_messages
)
5118 message1_nolog ("Garbage collecting...");
5122 shrink_regexp_cache ();
5126 /* clear_marks (); */
5128 /* Mark all the special slots that serve as the roots of accessibility. */
5130 for (i
= 0; i
< staticidx
; i
++)
5131 mark_object (*staticvec
[i
]);
5133 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5135 mark_object (bind
->symbol
);
5136 mark_object (bind
->old_value
);
5144 extern void xg_mark_data (void);
5149 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5150 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5154 register struct gcpro
*tail
;
5155 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5156 for (i
= 0; i
< tail
->nvars
; i
++)
5157 mark_object (tail
->var
[i
]);
5161 struct catchtag
*catch;
5162 struct handler
*handler
;
5164 for (catch = catchlist
; catch; catch = catch->next
)
5166 mark_object (catch->tag
);
5167 mark_object (catch->val
);
5169 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5171 mark_object (handler
->handler
);
5172 mark_object (handler
->var
);
5178 #ifdef HAVE_WINDOW_SYSTEM
5179 mark_fringe_data ();
5182 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5186 /* Everything is now marked, except for the things that require special
5187 finalization, i.e. the undo_list.
5188 Look thru every buffer's undo list
5189 for elements that update markers that were not marked,
5192 register struct buffer
*nextb
= all_buffers
;
5196 /* If a buffer's undo list is Qt, that means that undo is
5197 turned off in that buffer. Calling truncate_undo_list on
5198 Qt tends to return NULL, which effectively turns undo back on.
5199 So don't call truncate_undo_list if undo_list is Qt. */
5200 if (! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5202 Lisp_Object tail
, prev
;
5203 tail
= nextb
->BUFFER_INTERNAL_FIELD (undo_list
);
5205 while (CONSP (tail
))
5207 if (CONSP (XCAR (tail
))
5208 && MARKERP (XCAR (XCAR (tail
)))
5209 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5212 nextb
->BUFFER_INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5216 XSETCDR (prev
, tail
);
5226 /* Now that we have stripped the elements that need not be in the
5227 undo_list any more, we can finally mark the list. */
5228 mark_object (nextb
->BUFFER_INTERNAL_FIELD (undo_list
));
5230 nextb
= nextb
->header
.next
.buffer
;
5236 /* Clear the mark bits that we set in certain root slots. */
5238 unmark_byte_stack ();
5239 VECTOR_UNMARK (&buffer_defaults
);
5240 VECTOR_UNMARK (&buffer_local_symbols
);
5242 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5250 /* clear_marks (); */
5253 consing_since_gc
= 0;
5254 if (gc_cons_threshold
< 10000)
5255 gc_cons_threshold
= 10000;
5257 gc_relative_threshold
= 0;
5258 if (FLOATP (Vgc_cons_percentage
))
5259 { /* Set gc_cons_combined_threshold. */
5262 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5263 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5264 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5265 tot
+= total_string_size
;
5266 tot
+= total_vector_size
* sizeof (Lisp_Object
);
5267 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5268 tot
+= total_intervals
* sizeof (struct interval
);
5269 tot
+= total_strings
* sizeof (struct Lisp_String
);
5271 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5274 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5275 gc_relative_threshold
= tot
;
5277 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5281 if (garbage_collection_messages
)
5283 if (message_p
|| minibuf_level
> 0)
5286 message1_nolog ("Garbage collecting...done");
5289 unbind_to (count
, Qnil
);
5291 total
[0] = Fcons (make_number (total_conses
),
5292 make_number (total_free_conses
));
5293 total
[1] = Fcons (make_number (total_symbols
),
5294 make_number (total_free_symbols
));
5295 total
[2] = Fcons (make_number (total_markers
),
5296 make_number (total_free_markers
));
5297 total
[3] = make_number (total_string_size
);
5298 total
[4] = make_number (total_vector_size
);
5299 total
[5] = Fcons (make_number (total_floats
),
5300 make_number (total_free_floats
));
5301 total
[6] = Fcons (make_number (total_intervals
),
5302 make_number (total_free_intervals
));
5303 total
[7] = Fcons (make_number (total_strings
),
5304 make_number (total_free_strings
));
5306 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5308 /* Compute average percentage of zombies. */
5311 for (i
= 0; i
< 7; ++i
)
5312 if (CONSP (total
[i
]))
5313 nlive
+= XFASTINT (XCAR (total
[i
]));
5315 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5316 max_live
= max (nlive
, max_live
);
5317 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5318 max_zombies
= max (nzombies
, max_zombies
);
5323 if (!NILP (Vpost_gc_hook
))
5325 int gc_count
= inhibit_garbage_collection ();
5326 safe_run_hooks (Qpost_gc_hook
);
5327 unbind_to (gc_count
, Qnil
);
5330 /* Accumulate statistics. */
5331 EMACS_GET_TIME (t2
);
5332 EMACS_SUB_TIME (t3
, t2
, t1
);
5333 if (FLOATP (Vgc_elapsed
))
5334 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5336 EMACS_USECS (t3
) * 1.0e-6);
5339 return Flist (sizeof total
/ sizeof *total
, total
);
5343 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5344 only interesting objects referenced from glyphs are strings. */
5347 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5349 struct glyph_row
*row
= matrix
->rows
;
5350 struct glyph_row
*end
= row
+ matrix
->nrows
;
5352 for (; row
< end
; ++row
)
5356 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5358 struct glyph
*glyph
= row
->glyphs
[area
];
5359 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5361 for (; glyph
< end_glyph
; ++glyph
)
5362 if (STRINGP (glyph
->object
)
5363 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5364 mark_object (glyph
->object
);
5370 /* Mark Lisp faces in the face cache C. */
5373 mark_face_cache (struct face_cache
*c
)
5378 for (i
= 0; i
< c
->used
; ++i
)
5380 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5384 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5385 mark_object (face
->lface
[j
]);
5393 /* Mark reference to a Lisp_Object.
5394 If the object referred to has not been seen yet, recursively mark
5395 all the references contained in it. */
5397 #define LAST_MARKED_SIZE 500
5398 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5399 static int last_marked_index
;
5401 /* For debugging--call abort when we cdr down this many
5402 links of a list, in mark_object. In debugging,
5403 the call to abort will hit a breakpoint.
5404 Normally this is zero and the check never goes off. */
5405 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5408 mark_vectorlike (struct Lisp_Vector
*ptr
)
5410 EMACS_INT size
= ptr
->header
.size
;
5413 eassert (!VECTOR_MARKED_P (ptr
));
5414 VECTOR_MARK (ptr
); /* Else mark it */
5415 if (size
& PSEUDOVECTOR_FLAG
)
5416 size
&= PSEUDOVECTOR_SIZE_MASK
;
5418 /* Note that this size is not the memory-footprint size, but only
5419 the number of Lisp_Object fields that we should trace.
5420 The distinction is used e.g. by Lisp_Process which places extra
5421 non-Lisp_Object fields at the end of the structure. */
5422 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5423 mark_object (ptr
->contents
[i
]);
5426 /* Like mark_vectorlike but optimized for char-tables (and
5427 sub-char-tables) assuming that the contents are mostly integers or
5431 mark_char_table (struct Lisp_Vector
*ptr
)
5433 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5436 eassert (!VECTOR_MARKED_P (ptr
));
5438 for (i
= 0; i
< size
; i
++)
5440 Lisp_Object val
= ptr
->contents
[i
];
5442 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5444 if (SUB_CHAR_TABLE_P (val
))
5446 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5447 mark_char_table (XVECTOR (val
));
5455 mark_object (Lisp_Object arg
)
5457 register Lisp_Object obj
= arg
;
5458 #ifdef GC_CHECK_MARKED_OBJECTS
5462 ptrdiff_t cdr_count
= 0;
5466 if (PURE_POINTER_P (XPNTR (obj
)))
5469 last_marked
[last_marked_index
++] = obj
;
5470 if (last_marked_index
== LAST_MARKED_SIZE
)
5471 last_marked_index
= 0;
5473 /* Perform some sanity checks on the objects marked here. Abort if
5474 we encounter an object we know is bogus. This increases GC time
5475 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5476 #ifdef GC_CHECK_MARKED_OBJECTS
5478 po
= (void *) XPNTR (obj
);
5480 /* Check that the object pointed to by PO is known to be a Lisp
5481 structure allocated from the heap. */
5482 #define CHECK_ALLOCATED() \
5484 m = mem_find (po); \
5489 /* Check that the object pointed to by PO is live, using predicate
5491 #define CHECK_LIVE(LIVEP) \
5493 if (!LIVEP (m, po)) \
5497 /* Check both of the above conditions. */
5498 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5500 CHECK_ALLOCATED (); \
5501 CHECK_LIVE (LIVEP); \
5504 #else /* not GC_CHECK_MARKED_OBJECTS */
5506 #define CHECK_LIVE(LIVEP) (void) 0
5507 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5509 #endif /* not GC_CHECK_MARKED_OBJECTS */
5511 switch (SWITCH_ENUM_CAST (XTYPE (obj
)))
5515 register struct Lisp_String
*ptr
= XSTRING (obj
);
5516 if (STRING_MARKED_P (ptr
))
5518 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5519 MARK_INTERVAL_TREE (ptr
->intervals
);
5521 #ifdef GC_CHECK_STRING_BYTES
5522 /* Check that the string size recorded in the string is the
5523 same as the one recorded in the sdata structure. */
5524 CHECK_STRING_BYTES (ptr
);
5525 #endif /* GC_CHECK_STRING_BYTES */
5529 case Lisp_Vectorlike
:
5530 if (VECTOR_MARKED_P (XVECTOR (obj
)))
5532 #ifdef GC_CHECK_MARKED_OBJECTS
5534 if (m
== MEM_NIL
&& !SUBRP (obj
)
5535 && po
!= &buffer_defaults
5536 && po
!= &buffer_local_symbols
)
5538 #endif /* GC_CHECK_MARKED_OBJECTS */
5542 #ifdef GC_CHECK_MARKED_OBJECTS
5543 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5546 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->header
.next
.buffer
)
5551 #endif /* GC_CHECK_MARKED_OBJECTS */
5554 else if (SUBRP (obj
))
5556 else if (COMPILEDP (obj
))
5557 /* We could treat this just like a vector, but it is better to
5558 save the COMPILED_CONSTANTS element for last and avoid
5561 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5562 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5565 CHECK_LIVE (live_vector_p
);
5566 VECTOR_MARK (ptr
); /* Else mark it */
5567 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5569 if (i
!= COMPILED_CONSTANTS
)
5570 mark_object (ptr
->contents
[i
]);
5572 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5575 else if (FRAMEP (obj
))
5577 register struct frame
*ptr
= XFRAME (obj
);
5578 mark_vectorlike (XVECTOR (obj
));
5579 mark_face_cache (ptr
->face_cache
);
5581 else if (WINDOWP (obj
))
5583 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5584 struct window
*w
= XWINDOW (obj
);
5585 mark_vectorlike (ptr
);
5586 /* Mark glyphs for leaf windows. Marking window matrices is
5587 sufficient because frame matrices use the same glyph
5589 if (NILP (w
->hchild
)
5591 && w
->current_matrix
)
5593 mark_glyph_matrix (w
->current_matrix
);
5594 mark_glyph_matrix (w
->desired_matrix
);
5597 else if (HASH_TABLE_P (obj
))
5599 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5600 mark_vectorlike ((struct Lisp_Vector
*)h
);
5601 /* If hash table is not weak, mark all keys and values.
5602 For weak tables, mark only the vector. */
5604 mark_object (h
->key_and_value
);
5606 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5608 else if (CHAR_TABLE_P (obj
))
5609 mark_char_table (XVECTOR (obj
));
5611 mark_vectorlike (XVECTOR (obj
));
5616 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5617 struct Lisp_Symbol
*ptrx
;
5621 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5623 mark_object (ptr
->function
);
5624 mark_object (ptr
->plist
);
5625 switch (ptr
->redirect
)
5627 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5628 case SYMBOL_VARALIAS
:
5631 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5635 case SYMBOL_LOCALIZED
:
5637 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5638 /* If the value is forwarded to a buffer or keyboard field,
5639 these are marked when we see the corresponding object.
5640 And if it's forwarded to a C variable, either it's not
5641 a Lisp_Object var, or it's staticpro'd already. */
5642 mark_object (blv
->where
);
5643 mark_object (blv
->valcell
);
5644 mark_object (blv
->defcell
);
5647 case SYMBOL_FORWARDED
:
5648 /* If the value is forwarded to a buffer or keyboard field,
5649 these are marked when we see the corresponding object.
5650 And if it's forwarded to a C variable, either it's not
5651 a Lisp_Object var, or it's staticpro'd already. */
5655 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5656 MARK_STRING (XSTRING (ptr
->xname
));
5657 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5662 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5663 XSETSYMBOL (obj
, ptrx
);
5670 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5671 if (XMISCANY (obj
)->gcmarkbit
)
5673 XMISCANY (obj
)->gcmarkbit
= 1;
5675 switch (XMISCTYPE (obj
))
5678 case Lisp_Misc_Marker
:
5679 /* DO NOT mark thru the marker's chain.
5680 The buffer's markers chain does not preserve markers from gc;
5681 instead, markers are removed from the chain when freed by gc. */
5684 case Lisp_Misc_Save_Value
:
5687 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5688 /* If DOGC is set, POINTER is the address of a memory
5689 area containing INTEGER potential Lisp_Objects. */
5692 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5694 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5695 mark_maybe_object (*p
);
5701 case Lisp_Misc_Overlay
:
5703 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5704 mark_object (ptr
->start
);
5705 mark_object (ptr
->end
);
5706 mark_object (ptr
->plist
);
5709 XSETMISC (obj
, ptr
->next
);
5722 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5723 if (CONS_MARKED_P (ptr
))
5725 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5727 /* If the cdr is nil, avoid recursion for the car. */
5728 if (EQ (ptr
->u
.cdr
, Qnil
))
5734 mark_object (ptr
->car
);
5737 if (cdr_count
== mark_object_loop_halt
)
5743 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5744 FLOAT_MARK (XFLOAT (obj
));
5755 #undef CHECK_ALLOCATED
5756 #undef CHECK_ALLOCATED_AND_LIVE
5759 /* Mark the pointers in a buffer structure. */
5762 mark_buffer (Lisp_Object buf
)
5764 register struct buffer
*buffer
= XBUFFER (buf
);
5765 register Lisp_Object
*ptr
, tmp
;
5766 Lisp_Object base_buffer
;
5768 eassert (!VECTOR_MARKED_P (buffer
));
5769 VECTOR_MARK (buffer
);
5771 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5773 /* For now, we just don't mark the undo_list. It's done later in
5774 a special way just before the sweep phase, and after stripping
5775 some of its elements that are not needed any more. */
5777 if (buffer
->overlays_before
)
5779 XSETMISC (tmp
, buffer
->overlays_before
);
5782 if (buffer
->overlays_after
)
5784 XSETMISC (tmp
, buffer
->overlays_after
);
5788 /* buffer-local Lisp variables start at `undo_list',
5789 tho only the ones from `name' on are GC'd normally. */
5790 for (ptr
= &buffer
->BUFFER_INTERNAL_FIELD (name
);
5791 ptr
<= &PER_BUFFER_VALUE (buffer
,
5792 PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER
));
5796 /* If this is an indirect buffer, mark its base buffer. */
5797 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5799 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5800 mark_buffer (base_buffer
);
5804 /* Mark the Lisp pointers in the terminal objects.
5805 Called by the Fgarbage_collector. */
5808 mark_terminals (void)
5811 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5813 eassert (t
->name
!= NULL
);
5814 #ifdef HAVE_WINDOW_SYSTEM
5815 /* If a terminal object is reachable from a stacpro'ed object,
5816 it might have been marked already. Make sure the image cache
5818 mark_image_cache (t
->image_cache
);
5819 #endif /* HAVE_WINDOW_SYSTEM */
5820 if (!VECTOR_MARKED_P (t
))
5821 mark_vectorlike ((struct Lisp_Vector
*)t
);
5827 /* Value is non-zero if OBJ will survive the current GC because it's
5828 either marked or does not need to be marked to survive. */
5831 survives_gc_p (Lisp_Object obj
)
5835 switch (XTYPE (obj
))
5842 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5846 survives_p
= XMISCANY (obj
)->gcmarkbit
;
5850 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5853 case Lisp_Vectorlike
:
5854 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5858 survives_p
= CONS_MARKED_P (XCONS (obj
));
5862 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5869 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5874 /* Sweep: find all structures not marked, and free them. */
5879 /* Remove or mark entries in weak hash tables.
5880 This must be done before any object is unmarked. */
5881 sweep_weak_hash_tables ();
5884 #ifdef GC_CHECK_STRING_BYTES
5885 if (!noninteractive
)
5886 check_string_bytes (1);
5889 /* Put all unmarked conses on free list */
5891 register struct cons_block
*cblk
;
5892 struct cons_block
**cprev
= &cons_block
;
5893 register int lim
= cons_block_index
;
5894 EMACS_INT num_free
= 0, num_used
= 0;
5898 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5902 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
5904 /* Scan the mark bits an int at a time. */
5905 for (i
= 0; i
< ilim
; i
++)
5907 if (cblk
->gcmarkbits
[i
] == -1)
5909 /* Fast path - all cons cells for this int are marked. */
5910 cblk
->gcmarkbits
[i
] = 0;
5911 num_used
+= BITS_PER_INT
;
5915 /* Some cons cells for this int are not marked.
5916 Find which ones, and free them. */
5917 int start
, pos
, stop
;
5919 start
= i
* BITS_PER_INT
;
5921 if (stop
> BITS_PER_INT
)
5922 stop
= BITS_PER_INT
;
5925 for (pos
= start
; pos
< stop
; pos
++)
5927 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
5930 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
5931 cons_free_list
= &cblk
->conses
[pos
];
5933 cons_free_list
->car
= Vdead
;
5939 CONS_UNMARK (&cblk
->conses
[pos
]);
5945 lim
= CONS_BLOCK_SIZE
;
5946 /* If this block contains only free conses and we have already
5947 seen more than two blocks worth of free conses then deallocate
5949 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5951 *cprev
= cblk
->next
;
5952 /* Unhook from the free list. */
5953 cons_free_list
= cblk
->conses
[0].u
.chain
;
5954 lisp_align_free (cblk
);
5958 num_free
+= this_free
;
5959 cprev
= &cblk
->next
;
5962 total_conses
= num_used
;
5963 total_free_conses
= num_free
;
5966 /* Put all unmarked floats on free list */
5968 register struct float_block
*fblk
;
5969 struct float_block
**fprev
= &float_block
;
5970 register int lim
= float_block_index
;
5971 EMACS_INT num_free
= 0, num_used
= 0;
5973 float_free_list
= 0;
5975 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5979 for (i
= 0; i
< lim
; i
++)
5980 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5983 fblk
->floats
[i
].u
.chain
= float_free_list
;
5984 float_free_list
= &fblk
->floats
[i
];
5989 FLOAT_UNMARK (&fblk
->floats
[i
]);
5991 lim
= FLOAT_BLOCK_SIZE
;
5992 /* If this block contains only free floats and we have already
5993 seen more than two blocks worth of free floats then deallocate
5995 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5997 *fprev
= fblk
->next
;
5998 /* Unhook from the free list. */
5999 float_free_list
= fblk
->floats
[0].u
.chain
;
6000 lisp_align_free (fblk
);
6004 num_free
+= this_free
;
6005 fprev
= &fblk
->next
;
6008 total_floats
= num_used
;
6009 total_free_floats
= num_free
;
6012 /* Put all unmarked intervals on free list */
6014 register struct interval_block
*iblk
;
6015 struct interval_block
**iprev
= &interval_block
;
6016 register int lim
= interval_block_index
;
6017 EMACS_INT num_free
= 0, num_used
= 0;
6019 interval_free_list
= 0;
6021 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6026 for (i
= 0; i
< lim
; i
++)
6028 if (!iblk
->intervals
[i
].gcmarkbit
)
6030 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
6031 interval_free_list
= &iblk
->intervals
[i
];
6037 iblk
->intervals
[i
].gcmarkbit
= 0;
6040 lim
= INTERVAL_BLOCK_SIZE
;
6041 /* If this block contains only free intervals and we have already
6042 seen more than two blocks worth of free intervals then
6043 deallocate this block. */
6044 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6046 *iprev
= iblk
->next
;
6047 /* Unhook from the free list. */
6048 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6053 num_free
+= this_free
;
6054 iprev
= &iblk
->next
;
6057 total_intervals
= num_used
;
6058 total_free_intervals
= num_free
;
6061 /* Put all unmarked symbols on free list */
6063 register struct symbol_block
*sblk
;
6064 struct symbol_block
**sprev
= &symbol_block
;
6065 register int lim
= symbol_block_index
;
6066 EMACS_INT num_free
= 0, num_used
= 0;
6068 symbol_free_list
= NULL
;
6070 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6073 struct Lisp_Symbol
*sym
= sblk
->symbols
;
6074 struct Lisp_Symbol
*end
= sym
+ lim
;
6076 for (; sym
< end
; ++sym
)
6078 /* Check if the symbol was created during loadup. In such a case
6079 it might be pointed to by pure bytecode which we don't trace,
6080 so we conservatively assume that it is live. */
6081 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
6083 if (!sym
->gcmarkbit
&& !pure_p
)
6085 if (sym
->redirect
== SYMBOL_LOCALIZED
)
6086 xfree (SYMBOL_BLV (sym
));
6087 sym
->next
= symbol_free_list
;
6088 symbol_free_list
= sym
;
6090 symbol_free_list
->function
= Vdead
;
6098 UNMARK_STRING (XSTRING (sym
->xname
));
6103 lim
= SYMBOL_BLOCK_SIZE
;
6104 /* If this block contains only free symbols and we have already
6105 seen more than two blocks worth of free symbols then deallocate
6107 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6109 *sprev
= sblk
->next
;
6110 /* Unhook from the free list. */
6111 symbol_free_list
= sblk
->symbols
[0].next
;
6116 num_free
+= this_free
;
6117 sprev
= &sblk
->next
;
6120 total_symbols
= num_used
;
6121 total_free_symbols
= num_free
;
6124 /* Put all unmarked misc's on free list.
6125 For a marker, first unchain it from the buffer it points into. */
6127 register struct marker_block
*mblk
;
6128 struct marker_block
**mprev
= &marker_block
;
6129 register int lim
= marker_block_index
;
6130 EMACS_INT num_free
= 0, num_used
= 0;
6132 marker_free_list
= 0;
6134 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6139 for (i
= 0; i
< lim
; i
++)
6141 if (!mblk
->markers
[i
].u_any
.gcmarkbit
)
6143 if (mblk
->markers
[i
].u_any
.type
== Lisp_Misc_Marker
)
6144 unchain_marker (&mblk
->markers
[i
].u_marker
);
6145 /* Set the type of the freed object to Lisp_Misc_Free.
6146 We could leave the type alone, since nobody checks it,
6147 but this might catch bugs faster. */
6148 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
6149 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
6150 marker_free_list
= &mblk
->markers
[i
];
6156 mblk
->markers
[i
].u_any
.gcmarkbit
= 0;
6159 lim
= MARKER_BLOCK_SIZE
;
6160 /* If this block contains only free markers and we have already
6161 seen more than two blocks worth of free markers then deallocate
6163 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6165 *mprev
= mblk
->next
;
6166 /* Unhook from the free list. */
6167 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
6172 num_free
+= this_free
;
6173 mprev
= &mblk
->next
;
6177 total_markers
= num_used
;
6178 total_free_markers
= num_free
;
6181 /* Free all unmarked buffers */
6183 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6186 if (!VECTOR_MARKED_P (buffer
))
6189 prev
->header
.next
= buffer
->header
.next
;
6191 all_buffers
= buffer
->header
.next
.buffer
;
6192 next
= buffer
->header
.next
.buffer
;
6198 VECTOR_UNMARK (buffer
);
6199 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6200 prev
= buffer
, buffer
= buffer
->header
.next
.buffer
;
6204 /* Free all unmarked vectors */
6206 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6207 total_vector_size
= 0;
6210 if (!VECTOR_MARKED_P (vector
))
6213 prev
->header
.next
= vector
->header
.next
;
6215 all_vectors
= vector
->header
.next
.vector
;
6216 next
= vector
->header
.next
.vector
;
6223 VECTOR_UNMARK (vector
);
6224 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
6225 total_vector_size
+= PSEUDOVECTOR_SIZE_MASK
& vector
->header
.size
;
6227 total_vector_size
+= vector
->header
.size
;
6228 prev
= vector
, vector
= vector
->header
.next
.vector
;
6232 #ifdef GC_CHECK_STRING_BYTES
6233 if (!noninteractive
)
6234 check_string_bytes (1);
6241 /* Debugging aids. */
6243 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6244 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6245 This may be helpful in debugging Emacs's memory usage.
6246 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6251 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6256 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6257 doc
: /* Return a list of counters that measure how much consing there has been.
6258 Each of these counters increments for a certain kind of object.
6259 The counters wrap around from the largest positive integer to zero.
6260 Garbage collection does not decrease them.
6261 The elements of the value are as follows:
6262 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6263 All are in units of 1 = one object consed
6264 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6266 MISCS include overlays, markers, and some internal types.
6267 Frames, windows, buffers, and subprocesses count as vectors
6268 (but the contents of a buffer's text do not count here). */)
6271 Lisp_Object consed
[8];
6273 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6274 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6275 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6276 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6277 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6278 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6279 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6280 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6282 return Flist (8, consed
);
6285 /* Find at most FIND_MAX symbols which have OBJ as their value or
6286 function. This is used in gdbinit's `xwhichsymbols' command. */
6289 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6291 struct symbol_block
*sblk
;
6292 int gc_count
= inhibit_garbage_collection ();
6293 Lisp_Object found
= Qnil
;
6297 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6299 struct Lisp_Symbol
*sym
= sblk
->symbols
;
6302 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, sym
++)
6307 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6310 XSETSYMBOL (tem
, sym
);
6311 val
= find_symbol_value (tem
);
6313 || EQ (sym
->function
, obj
)
6314 || (!NILP (sym
->function
)
6315 && COMPILEDP (sym
->function
)
6316 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6319 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6321 found
= Fcons (tem
, found
);
6322 if (--find_max
== 0)
6330 unbind_to (gc_count
, Qnil
);
6334 #ifdef ENABLE_CHECKING
6335 int suppress_checking
;
6338 die (const char *msg
, const char *file
, int line
)
6340 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6346 /* Initialization */
6349 init_alloc_once (void)
6351 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6353 pure_size
= PURESIZE
;
6354 pure_bytes_used
= 0;
6355 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6356 pure_bytes_used_before_overflow
= 0;
6358 /* Initialize the list of free aligned blocks. */
6361 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6363 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6367 ignore_warnings
= 1;
6368 #ifdef DOUG_LEA_MALLOC
6369 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6370 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6371 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6379 init_weak_hash_tables ();
6382 malloc_hysteresis
= 32;
6384 malloc_hysteresis
= 0;
6387 refill_memory_reserve ();
6389 ignore_warnings
= 0;
6391 byte_stack_list
= 0;
6393 consing_since_gc
= 0;
6394 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6395 gc_relative_threshold
= 0;
6402 byte_stack_list
= 0;
6404 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6405 setjmp_tested_p
= longjmps_done
= 0;
6408 Vgc_elapsed
= make_float (0.0);
6413 syms_of_alloc (void)
6415 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6416 doc
: /* Number of bytes of consing between garbage collections.
6417 Garbage collection can happen automatically once this many bytes have been
6418 allocated since the last garbage collection. All data types count.
6420 Garbage collection happens automatically only when `eval' is called.
6422 By binding this temporarily to a large number, you can effectively
6423 prevent garbage collection during a part of the program.
6424 See also `gc-cons-percentage'. */);
6426 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6427 doc
: /* Portion of the heap used for allocation.
6428 Garbage collection can happen automatically once this portion of the heap
6429 has been allocated since the last garbage collection.
6430 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6431 Vgc_cons_percentage
= make_float (0.1);
6433 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6434 doc
: /* Number of bytes of shareable Lisp data allocated so far. */);
6436 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6437 doc
: /* Number of cons cells that have been consed so far. */);
6439 DEFVAR_INT ("floats-consed", floats_consed
,
6440 doc
: /* Number of floats that have been consed so far. */);
6442 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6443 doc
: /* Number of vector cells that have been consed so far. */);
6445 DEFVAR_INT ("symbols-consed", symbols_consed
,
6446 doc
: /* Number of symbols that have been consed so far. */);
6448 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6449 doc
: /* Number of string characters that have been consed so far. */);
6451 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6452 doc
: /* Number of miscellaneous objects that have been consed so far.
6453 These include markers and overlays, plus certain objects not visible
6456 DEFVAR_INT ("intervals-consed", intervals_consed
,
6457 doc
: /* Number of intervals that have been consed so far. */);
6459 DEFVAR_INT ("strings-consed", strings_consed
,
6460 doc
: /* Number of strings that have been consed so far. */);
6462 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6463 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6464 This means that certain objects should be allocated in shared (pure) space.
6465 It can also be set to a hash-table, in which case this table is used to
6466 do hash-consing of the objects allocated to pure space. */);
6468 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6469 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6470 garbage_collection_messages
= 0;
6472 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6473 doc
: /* Hook run after garbage collection has finished. */);
6474 Vpost_gc_hook
= Qnil
;
6475 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6477 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6478 doc
: /* Precomputed `signal' argument for memory-full error. */);
6479 /* We build this in advance because if we wait until we need it, we might
6480 not be able to allocate the memory to hold it. */
6482 = pure_cons (Qerror
,
6483 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil
));
6485 DEFVAR_LISP ("memory-full", Vmemory_full
,
6486 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6487 Vmemory_full
= Qnil
;
6489 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6490 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6492 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6493 doc
: /* Accumulated time elapsed in garbage collections.
6494 The time is in seconds as a floating point value. */);
6495 DEFVAR_INT ("gcs-done", gcs_done
,
6496 doc
: /* Accumulated number of garbage collections done. */);
6501 defsubr (&Smake_byte_code
);
6502 defsubr (&Smake_list
);
6503 defsubr (&Smake_vector
);
6504 defsubr (&Smake_string
);
6505 defsubr (&Smake_bool_vector
);
6506 defsubr (&Smake_symbol
);
6507 defsubr (&Smake_marker
);
6508 defsubr (&Spurecopy
);
6509 defsubr (&Sgarbage_collect
);
6510 defsubr (&Smemory_limit
);
6511 defsubr (&Smemory_use_counts
);
6513 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6514 defsubr (&Sgc_status
);