1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
22 #include <limits.h> /* For CHAR_BIT. */
31 /* This file is part of the core Lisp implementation, and thus must
32 deal with the real data structures. If the Lisp implementation is
33 replaced, this file likely will not be used. */
35 #undef HIDE_LISP_IMPLEMENTATION
38 #include "intervals.h"
44 #include "blockinput.h"
45 #include "character.h"
46 #include "syssignal.h"
47 #include "termhooks.h" /* For struct terminal. */
51 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
52 memory. Can do this only if using gmalloc.c. */
54 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
55 #undef GC_MALLOC_CHECK
60 extern POINTER_TYPE
*sbrk ();
69 #ifdef DOUG_LEA_MALLOC
73 /* Specify maximum number of areas to mmap. It would be nice to use a
74 value that explicitly means "no limit". */
76 #define MMAP_MAX_AREAS 100000000
78 #else /* not DOUG_LEA_MALLOC */
80 /* The following come from gmalloc.c. */
82 extern size_t _bytes_used
;
83 extern size_t __malloc_extra_blocks
;
85 #endif /* not DOUG_LEA_MALLOC */
87 #if ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT
90 /* When GTK uses the file chooser dialog, different backends can be loaded
91 dynamically. One such a backend is the Gnome VFS backend that gets loaded
92 if you run Gnome. That backend creates several threads and also allocates
95 Also, gconf and gsettings may create several threads.
97 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
98 functions below are called from malloc, there is a chance that one
99 of these threads preempts the Emacs main thread and the hook variables
100 end up in an inconsistent state. So we have a mutex to prevent that (note
101 that the backend handles concurrent access to malloc within its own threads
102 but Emacs code running in the main thread is not included in that control).
104 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
105 happens in one of the backend threads we will have two threads that tries
106 to run Emacs code at once, and the code is not prepared for that.
107 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
109 static pthread_mutex_t alloc_mutex
;
111 #define BLOCK_INPUT_ALLOC \
114 if (pthread_equal (pthread_self (), main_thread)) \
116 pthread_mutex_lock (&alloc_mutex); \
119 #define UNBLOCK_INPUT_ALLOC \
122 pthread_mutex_unlock (&alloc_mutex); \
123 if (pthread_equal (pthread_self (), main_thread)) \
128 #else /* ! defined HAVE_PTHREAD */
130 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
131 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
133 #endif /* ! defined HAVE_PTHREAD */
134 #endif /* ! defined SYSTEM_MALLOC && ! defined SYNC_INPUT */
136 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
137 to a struct Lisp_String. */
139 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
140 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
141 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
143 #define VECTOR_MARK(V) ((V)->header.size |= ARRAY_MARK_FLAG)
144 #define VECTOR_UNMARK(V) ((V)->header.size &= ~ARRAY_MARK_FLAG)
145 #define VECTOR_MARKED_P(V) (((V)->header.size & ARRAY_MARK_FLAG) != 0)
147 /* Value is the number of bytes of S, a pointer to a struct Lisp_String.
148 Be careful during GC, because S->size contains the mark bit for
151 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
153 /* Global variables. */
154 struct emacs_globals globals
;
156 /* Number of bytes of consing done since the last gc. */
158 EMACS_INT consing_since_gc
;
160 /* Similar minimum, computed from Vgc_cons_percentage. */
162 EMACS_INT gc_relative_threshold
;
164 /* Minimum number of bytes of consing since GC before next GC,
165 when memory is full. */
167 EMACS_INT memory_full_cons_threshold
;
169 /* Nonzero during GC. */
173 /* Nonzero means abort if try to GC.
174 This is for code which is written on the assumption that
175 no GC will happen, so as to verify that assumption. */
179 /* Number of live and free conses etc. */
181 static EMACS_INT total_conses
, total_markers
, total_symbols
, total_vector_size
;
182 static EMACS_INT total_free_conses
, total_free_markers
, total_free_symbols
;
183 static EMACS_INT total_free_floats
, total_floats
;
185 /* Points to memory space allocated as "spare", to be freed if we run
186 out of memory. We keep one large block, four cons-blocks, and
187 two string blocks. */
189 static char *spare_memory
[7];
191 /* Amount of spare memory to keep in large reserve block, or to see
192 whether this much is available when malloc fails on a larger request. */
194 #define SPARE_MEMORY (1 << 14)
196 /* Number of extra blocks malloc should get when it needs more core. */
198 static int malloc_hysteresis
;
200 /* Initialize it to a nonzero value to force it into data space
201 (rather than bss space). That way unexec will remap it into text
202 space (pure), on some systems. We have not implemented the
203 remapping on more recent systems because this is less important
204 nowadays than in the days of small memories and timesharing. */
206 #ifndef VIRT_ADDR_VARIES
209 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
210 #define PUREBEG (char *) pure
212 /* Pointer to the pure area, and its size. */
214 static char *purebeg
;
215 static ptrdiff_t pure_size
;
217 /* Number of bytes of pure storage used before pure storage overflowed.
218 If this is non-zero, this implies that an overflow occurred. */
220 static ptrdiff_t pure_bytes_used_before_overflow
;
222 /* Value is non-zero if P points into pure space. */
224 #define PURE_POINTER_P(P) \
225 (((PNTR_COMPARISON_TYPE) (P) \
226 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
227 && ((PNTR_COMPARISON_TYPE) (P) \
228 >= (PNTR_COMPARISON_TYPE) purebeg))
230 /* Index in pure at which next pure Lisp object will be allocated.. */
232 static EMACS_INT pure_bytes_used_lisp
;
234 /* Number of bytes allocated for non-Lisp objects in pure storage. */
236 static EMACS_INT pure_bytes_used_non_lisp
;
238 /* If nonzero, this is a warning delivered by malloc and not yet
241 const char *pending_malloc_warning
;
243 /* Maximum amount of C stack to save when a GC happens. */
245 #ifndef MAX_SAVE_STACK
246 #define MAX_SAVE_STACK 16000
249 /* Buffer in which we save a copy of the C stack at each GC. */
251 #if MAX_SAVE_STACK > 0
252 static char *stack_copy
;
253 static ptrdiff_t stack_copy_size
;
256 /* Non-zero means ignore malloc warnings. Set during initialization.
257 Currently not used. */
259 static int ignore_warnings
;
261 static Lisp_Object Qgc_cons_threshold
;
262 Lisp_Object Qchar_table_extra_slots
;
264 /* Hook run after GC has finished. */
266 static Lisp_Object Qpost_gc_hook
;
268 static void mark_buffer (Lisp_Object
);
269 static void mark_terminals (void);
270 static void gc_sweep (void);
271 static void mark_glyph_matrix (struct glyph_matrix
*);
272 static void mark_face_cache (struct face_cache
*);
274 #if !defined REL_ALLOC || defined SYSTEM_MALLOC
275 static void refill_memory_reserve (void);
277 static struct Lisp_String
*allocate_string (void);
278 static void compact_small_strings (void);
279 static void free_large_strings (void);
280 static void sweep_strings (void);
281 static void free_misc (Lisp_Object
);
282 extern Lisp_Object
which_symbols (Lisp_Object
, EMACS_INT
) EXTERNALLY_VISIBLE
;
284 /* When scanning the C stack for live Lisp objects, Emacs keeps track
285 of what memory allocated via lisp_malloc is intended for what
286 purpose. This enumeration specifies the type of memory. */
297 /* We used to keep separate mem_types for subtypes of vectors such as
298 process, hash_table, frame, terminal, and window, but we never made
299 use of the distinction, so it only caused source-code complexity
300 and runtime slowdown. Minor but pointless. */
304 static POINTER_TYPE
*lisp_align_malloc (size_t, enum mem_type
);
305 static POINTER_TYPE
*lisp_malloc (size_t, enum mem_type
);
308 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
310 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
311 #include <stdio.h> /* For fprintf. */
314 /* A unique object in pure space used to make some Lisp objects
315 on free lists recognizable in O(1). */
317 static Lisp_Object Vdead
;
318 #define DEADP(x) EQ (x, Vdead)
320 #ifdef GC_MALLOC_CHECK
322 enum mem_type allocated_mem_type
;
323 static int dont_register_blocks
;
325 #endif /* GC_MALLOC_CHECK */
327 /* A node in the red-black tree describing allocated memory containing
328 Lisp data. Each such block is recorded with its start and end
329 address when it is allocated, and removed from the tree when it
332 A red-black tree is a balanced binary tree with the following
335 1. Every node is either red or black.
336 2. Every leaf is black.
337 3. If a node is red, then both of its children are black.
338 4. Every simple path from a node to a descendant leaf contains
339 the same number of black nodes.
340 5. The root is always black.
342 When nodes are inserted into the tree, or deleted from the tree,
343 the tree is "fixed" so that these properties are always true.
345 A red-black tree with N internal nodes has height at most 2
346 log(N+1). Searches, insertions and deletions are done in O(log N).
347 Please see a text book about data structures for a detailed
348 description of red-black trees. Any book worth its salt should
353 /* Children of this node. These pointers are never NULL. When there
354 is no child, the value is MEM_NIL, which points to a dummy node. */
355 struct mem_node
*left
, *right
;
357 /* The parent of this node. In the root node, this is NULL. */
358 struct mem_node
*parent
;
360 /* Start and end of allocated region. */
364 enum {MEM_BLACK
, MEM_RED
} color
;
370 /* Base address of stack. Set in main. */
372 Lisp_Object
*stack_base
;
374 /* Root of the tree describing allocated Lisp memory. */
376 static struct mem_node
*mem_root
;
378 /* Lowest and highest known address in the heap. */
380 static void *min_heap_address
, *max_heap_address
;
382 /* Sentinel node of the tree. */
384 static struct mem_node mem_z
;
385 #define MEM_NIL &mem_z
387 static struct Lisp_Vector
*allocate_vectorlike (EMACS_INT
);
388 static void lisp_free (POINTER_TYPE
*);
389 static void mark_stack (void);
390 static int live_vector_p (struct mem_node
*, void *);
391 static int live_buffer_p (struct mem_node
*, void *);
392 static int live_string_p (struct mem_node
*, void *);
393 static int live_cons_p (struct mem_node
*, void *);
394 static int live_symbol_p (struct mem_node
*, void *);
395 static int live_float_p (struct mem_node
*, void *);
396 static int live_misc_p (struct mem_node
*, void *);
397 static void mark_maybe_object (Lisp_Object
);
398 static void mark_memory (void *, void *);
399 static void mem_init (void);
400 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
401 static void mem_insert_fixup (struct mem_node
*);
402 static void mem_rotate_left (struct mem_node
*);
403 static void mem_rotate_right (struct mem_node
*);
404 static void mem_delete (struct mem_node
*);
405 static void mem_delete_fixup (struct mem_node
*);
406 static inline struct mem_node
*mem_find (void *);
409 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
410 static void check_gcpros (void);
413 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
419 /* Recording what needs to be marked for gc. */
421 struct gcpro
*gcprolist
;
423 /* Addresses of staticpro'd variables. Initialize it to a nonzero
424 value; otherwise some compilers put it into BSS. */
426 #define NSTATICS 0x640
427 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
429 /* Index of next unused slot in staticvec. */
431 static int staticidx
= 0;
433 static POINTER_TYPE
*pure_alloc (size_t, int);
436 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
437 ALIGNMENT must be a power of 2. */
439 #define ALIGN(ptr, ALIGNMENT) \
440 ((POINTER_TYPE *) ((((uintptr_t) (ptr)) + (ALIGNMENT) - 1) \
441 & ~((ALIGNMENT) - 1)))
445 /************************************************************************
447 ************************************************************************/
449 /* Function malloc calls this if it finds we are near exhausting storage. */
452 malloc_warning (const char *str
)
454 pending_malloc_warning
= str
;
458 /* Display an already-pending malloc warning. */
461 display_malloc_warning (void)
463 call3 (intern ("display-warning"),
465 build_string (pending_malloc_warning
),
466 intern ("emergency"));
467 pending_malloc_warning
= 0;
470 /* Called if we can't allocate relocatable space for a buffer. */
473 buffer_memory_full (EMACS_INT nbytes
)
475 /* If buffers use the relocating allocator, no need to free
476 spare_memory, because we may have plenty of malloc space left
477 that we could get, and if we don't, the malloc that fails will
478 itself cause spare_memory to be freed. If buffers don't use the
479 relocating allocator, treat this like any other failing
483 memory_full (nbytes
);
486 /* This used to call error, but if we've run out of memory, we could
487 get infinite recursion trying to build the string. */
488 xsignal (Qnil
, Vmemory_signal_data
);
492 #ifndef XMALLOC_OVERRUN_CHECK
493 #define XMALLOC_OVERRUN_CHECK_OVERHEAD 0
496 /* Check for overrun in malloc'ed buffers by wrapping a header and trailer
499 The header consists of XMALLOC_OVERRUN_CHECK_SIZE fixed bytes
500 followed by XMALLOC_OVERRUN_SIZE_SIZE bytes containing the original
501 block size in little-endian order. The trailer consists of
502 XMALLOC_OVERRUN_CHECK_SIZE fixed bytes.
504 The header is used to detect whether this block has been allocated
505 through these functions, as some low-level libc functions may
506 bypass the malloc hooks. */
508 #define XMALLOC_OVERRUN_CHECK_SIZE 16
509 #define XMALLOC_OVERRUN_CHECK_OVERHEAD \
510 (2 * XMALLOC_OVERRUN_CHECK_SIZE + XMALLOC_OVERRUN_SIZE_SIZE)
512 /* Define XMALLOC_OVERRUN_SIZE_SIZE so that (1) it's large enough to
513 hold a size_t value and (2) the header size is a multiple of the
514 alignment that Emacs needs for C types and for USE_LSB_TAG. */
515 #define XMALLOC_BASE_ALIGNMENT \
518 union { long double d; intmax_t i; void *p; } u; \
523 /* A common multiple of the positive integers A and B. Ideally this
524 would be the least common multiple, but there's no way to do that
525 as a constant expression in C, so do the best that we can easily do. */
526 # define COMMON_MULTIPLE(a, b) \
527 ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b))
528 # define XMALLOC_HEADER_ALIGNMENT \
529 COMMON_MULTIPLE (1 << GCTYPEBITS, XMALLOC_BASE_ALIGNMENT)
531 # define XMALLOC_HEADER_ALIGNMENT XMALLOC_BASE_ALIGNMENT
533 #define XMALLOC_OVERRUN_SIZE_SIZE \
534 (((XMALLOC_OVERRUN_CHECK_SIZE + sizeof (size_t) \
535 + XMALLOC_HEADER_ALIGNMENT - 1) \
536 / XMALLOC_HEADER_ALIGNMENT * XMALLOC_HEADER_ALIGNMENT) \
537 - XMALLOC_OVERRUN_CHECK_SIZE)
539 static char const xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
] =
540 { '\x9a', '\x9b', '\xae', '\xaf',
541 '\xbf', '\xbe', '\xce', '\xcf',
542 '\xea', '\xeb', '\xec', '\xed',
543 '\xdf', '\xde', '\x9c', '\x9d' };
545 static char const xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
546 { '\xaa', '\xab', '\xac', '\xad',
547 '\xba', '\xbb', '\xbc', '\xbd',
548 '\xca', '\xcb', '\xcc', '\xcd',
549 '\xda', '\xdb', '\xdc', '\xdd' };
551 /* Insert and extract the block size in the header. */
554 xmalloc_put_size (unsigned char *ptr
, size_t size
)
557 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
559 *--ptr
= size
& ((1 << CHAR_BIT
) - 1);
565 xmalloc_get_size (unsigned char *ptr
)
569 ptr
-= XMALLOC_OVERRUN_SIZE_SIZE
;
570 for (i
= 0; i
< XMALLOC_OVERRUN_SIZE_SIZE
; i
++)
579 /* The call depth in overrun_check functions. For example, this might happen:
581 overrun_check_malloc()
582 -> malloc -> (via hook)_-> emacs_blocked_malloc
583 -> overrun_check_malloc
584 call malloc (hooks are NULL, so real malloc is called).
585 malloc returns 10000.
586 add overhead, return 10016.
587 <- (back in overrun_check_malloc)
588 add overhead again, return 10032
589 xmalloc returns 10032.
594 overrun_check_free(10032)
596 free(10016) <- crash, because 10000 is the original pointer. */
598 static ptrdiff_t check_depth
;
600 /* Like malloc, but wraps allocated block with header and trailer. */
602 static POINTER_TYPE
*
603 overrun_check_malloc (size_t size
)
605 register unsigned char *val
;
606 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
607 if (SIZE_MAX
- overhead
< size
)
610 val
= (unsigned char *) malloc (size
+ overhead
);
611 if (val
&& check_depth
== 1)
613 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
614 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
615 xmalloc_put_size (val
, size
);
616 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
617 XMALLOC_OVERRUN_CHECK_SIZE
);
620 return (POINTER_TYPE
*)val
;
624 /* Like realloc, but checks old block for overrun, and wraps new block
625 with header and trailer. */
627 static POINTER_TYPE
*
628 overrun_check_realloc (POINTER_TYPE
*block
, size_t size
)
630 register unsigned char *val
= (unsigned char *) block
;
631 int overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_OVERHEAD
: 0;
632 if (SIZE_MAX
- overhead
< size
)
637 && memcmp (xmalloc_overrun_check_header
,
638 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
639 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
641 size_t osize
= xmalloc_get_size (val
);
642 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
643 XMALLOC_OVERRUN_CHECK_SIZE
))
645 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
646 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
647 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
650 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
652 if (val
&& check_depth
== 1)
654 memcpy (val
, xmalloc_overrun_check_header
, XMALLOC_OVERRUN_CHECK_SIZE
);
655 val
+= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
656 xmalloc_put_size (val
, size
);
657 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
658 XMALLOC_OVERRUN_CHECK_SIZE
);
661 return (POINTER_TYPE
*)val
;
664 /* Like free, but checks block for overrun. */
667 overrun_check_free (POINTER_TYPE
*block
)
669 unsigned char *val
= (unsigned char *) block
;
674 && memcmp (xmalloc_overrun_check_header
,
675 val
- XMALLOC_OVERRUN_CHECK_SIZE
- XMALLOC_OVERRUN_SIZE_SIZE
,
676 XMALLOC_OVERRUN_CHECK_SIZE
) == 0)
678 size_t osize
= xmalloc_get_size (val
);
679 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
680 XMALLOC_OVERRUN_CHECK_SIZE
))
682 #ifdef XMALLOC_CLEAR_FREE_MEMORY
683 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
684 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_OVERHEAD
);
686 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
687 val
-= XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
;
688 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
+ XMALLOC_OVERRUN_SIZE_SIZE
);
699 #define malloc overrun_check_malloc
700 #define realloc overrun_check_realloc
701 #define free overrun_check_free
705 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
706 there's no need to block input around malloc. */
707 #define MALLOC_BLOCK_INPUT ((void)0)
708 #define MALLOC_UNBLOCK_INPUT ((void)0)
710 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
711 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
714 /* Like malloc but check for no memory and block interrupt input.. */
717 xmalloc (size_t size
)
719 register POINTER_TYPE
*val
;
722 val
= (POINTER_TYPE
*) malloc (size
);
723 MALLOC_UNBLOCK_INPUT
;
731 /* Like realloc but check for no memory and block interrupt input.. */
734 xrealloc (POINTER_TYPE
*block
, size_t size
)
736 register POINTER_TYPE
*val
;
739 /* We must call malloc explicitly when BLOCK is 0, since some
740 reallocs don't do this. */
742 val
= (POINTER_TYPE
*) malloc (size
);
744 val
= (POINTER_TYPE
*) realloc (block
, size
);
745 MALLOC_UNBLOCK_INPUT
;
753 /* Like free but block interrupt input. */
756 xfree (POINTER_TYPE
*block
)
762 MALLOC_UNBLOCK_INPUT
;
763 /* We don't call refill_memory_reserve here
764 because that duplicates doing so in emacs_blocked_free
765 and the criterion should go there. */
769 /* Other parts of Emacs pass large int values to allocator functions
770 expecting ptrdiff_t. This is portable in practice, but check it to
772 verify (INT_MAX
<= PTRDIFF_MAX
);
775 /* Allocate an array of NITEMS items, each of size ITEM_SIZE.
776 Signal an error on memory exhaustion, and block interrupt input. */
779 xnmalloc (ptrdiff_t nitems
, ptrdiff_t item_size
)
781 xassert (0 <= nitems
&& 0 < item_size
);
782 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
783 memory_full (SIZE_MAX
);
784 return xmalloc (nitems
* item_size
);
788 /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
789 Signal an error on memory exhaustion, and block interrupt input. */
792 xnrealloc (void *pa
, ptrdiff_t nitems
, ptrdiff_t item_size
)
794 xassert (0 <= nitems
&& 0 < item_size
);
795 if (min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
< nitems
)
796 memory_full (SIZE_MAX
);
797 return xrealloc (pa
, nitems
* item_size
);
801 /* Grow PA, which points to an array of *NITEMS items, and return the
802 location of the reallocated array, updating *NITEMS to reflect its
803 new size. The new array will contain at least NITEMS_INCR_MIN more
804 items, but will not contain more than NITEMS_MAX items total.
805 ITEM_SIZE is the size of each item, in bytes.
807 ITEM_SIZE and NITEMS_INCR_MIN must be positive. *NITEMS must be
808 nonnegative. If NITEMS_MAX is -1, it is treated as if it were
811 If PA is null, then allocate a new array instead of reallocating
812 the old one. Thus, to grow an array A without saving its old
813 contents, invoke xfree (A) immediately followed by xgrowalloc (0,
816 Block interrupt input as needed. If memory exhaustion occurs, set
817 *NITEMS to zero if PA is null, and signal an error (i.e., do not
821 xpalloc (void *pa
, ptrdiff_t *nitems
, ptrdiff_t nitems_incr_min
,
822 ptrdiff_t nitems_max
, ptrdiff_t item_size
)
824 /* The approximate size to use for initial small allocation
825 requests. This is the largest "small" request for the GNU C
827 enum { DEFAULT_MXFAST
= 64 * sizeof (size_t) / 4 };
829 /* If the array is tiny, grow it to about (but no greater than)
830 DEFAULT_MXFAST bytes. Otherwise, grow it by about 50%. */
831 ptrdiff_t n
= *nitems
;
832 ptrdiff_t tiny_max
= DEFAULT_MXFAST
/ item_size
- n
;
833 ptrdiff_t half_again
= n
>> 1;
834 ptrdiff_t incr_estimate
= max (tiny_max
, half_again
);
836 /* Adjust the increment according to three constraints: NITEMS_INCR_MIN,
837 NITEMS_MAX, and what the C language can represent safely. */
838 ptrdiff_t C_language_max
= min (PTRDIFF_MAX
, SIZE_MAX
) / item_size
;
839 ptrdiff_t n_max
= (0 <= nitems_max
&& nitems_max
< C_language_max
840 ? nitems_max
: C_language_max
);
841 ptrdiff_t nitems_incr_max
= n_max
- n
;
842 ptrdiff_t incr
= max (nitems_incr_min
, min (incr_estimate
, nitems_incr_max
));
844 xassert (0 < item_size
&& 0 < nitems_incr_min
&& 0 <= n
&& -1 <= nitems_max
);
847 if (nitems_incr_max
< incr
)
848 memory_full (SIZE_MAX
);
850 pa
= xrealloc (pa
, n
* item_size
);
856 /* Like strdup, but uses xmalloc. */
859 xstrdup (const char *s
)
861 size_t len
= strlen (s
) + 1;
862 char *p
= (char *) xmalloc (len
);
868 /* Unwind for SAFE_ALLOCA */
871 safe_alloca_unwind (Lisp_Object arg
)
873 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
883 /* Like malloc but used for allocating Lisp data. NBYTES is the
884 number of bytes to allocate, TYPE describes the intended use of the
885 allcated memory block (for strings, for conses, ...). */
888 static void *lisp_malloc_loser
;
891 static POINTER_TYPE
*
892 lisp_malloc (size_t nbytes
, enum mem_type type
)
898 #ifdef GC_MALLOC_CHECK
899 allocated_mem_type
= type
;
902 val
= (void *) malloc (nbytes
);
905 /* If the memory just allocated cannot be addressed thru a Lisp
906 object's pointer, and it needs to be,
907 that's equivalent to running out of memory. */
908 if (val
&& type
!= MEM_TYPE_NON_LISP
)
911 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
912 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
914 lisp_malloc_loser
= val
;
921 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
922 if (val
&& type
!= MEM_TYPE_NON_LISP
)
923 mem_insert (val
, (char *) val
+ nbytes
, type
);
926 MALLOC_UNBLOCK_INPUT
;
928 memory_full (nbytes
);
932 /* Free BLOCK. This must be called to free memory allocated with a
933 call to lisp_malloc. */
936 lisp_free (POINTER_TYPE
*block
)
940 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
941 mem_delete (mem_find (block
));
943 MALLOC_UNBLOCK_INPUT
;
946 /* Allocation of aligned blocks of memory to store Lisp data. */
947 /* The entry point is lisp_align_malloc which returns blocks of at most */
948 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
950 /* Use posix_memalloc if the system has it and we're using the system's
951 malloc (because our gmalloc.c routines don't have posix_memalign although
952 its memalloc could be used). */
953 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
954 #define USE_POSIX_MEMALIGN 1
957 /* BLOCK_ALIGN has to be a power of 2. */
958 #define BLOCK_ALIGN (1 << 10)
960 /* Padding to leave at the end of a malloc'd block. This is to give
961 malloc a chance to minimize the amount of memory wasted to alignment.
962 It should be tuned to the particular malloc library used.
963 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
964 posix_memalign on the other hand would ideally prefer a value of 4
965 because otherwise, there's 1020 bytes wasted between each ablocks.
966 In Emacs, testing shows that those 1020 can most of the time be
967 efficiently used by malloc to place other objects, so a value of 0 can
968 still preferable unless you have a lot of aligned blocks and virtually
970 #define BLOCK_PADDING 0
971 #define BLOCK_BYTES \
972 (BLOCK_ALIGN - sizeof (struct ablocks *) - BLOCK_PADDING)
974 /* Internal data structures and constants. */
976 #define ABLOCKS_SIZE 16
978 /* An aligned block of memory. */
983 char payload
[BLOCK_BYTES
];
984 struct ablock
*next_free
;
986 /* `abase' is the aligned base of the ablocks. */
987 /* It is overloaded to hold the virtual `busy' field that counts
988 the number of used ablock in the parent ablocks.
989 The first ablock has the `busy' field, the others have the `abase'
990 field. To tell the difference, we assume that pointers will have
991 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
992 is used to tell whether the real base of the parent ablocks is `abase'
993 (if not, the word before the first ablock holds a pointer to the
995 struct ablocks
*abase
;
996 /* The padding of all but the last ablock is unused. The padding of
997 the last ablock in an ablocks is not allocated. */
999 char padding
[BLOCK_PADDING
];
1003 /* A bunch of consecutive aligned blocks. */
1006 struct ablock blocks
[ABLOCKS_SIZE
];
1009 /* Size of the block requested from malloc or memalign. */
1010 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
1012 #define ABLOCK_ABASE(block) \
1013 (((uintptr_t) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
1014 ? (struct ablocks *)(block) \
1017 /* Virtual `busy' field. */
1018 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
1020 /* Pointer to the (not necessarily aligned) malloc block. */
1021 #ifdef USE_POSIX_MEMALIGN
1022 #define ABLOCKS_BASE(abase) (abase)
1024 #define ABLOCKS_BASE(abase) \
1025 (1 & (intptr_t) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
1028 /* The list of free ablock. */
1029 static struct ablock
*free_ablock
;
1031 /* Allocate an aligned block of nbytes.
1032 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
1033 smaller or equal to BLOCK_BYTES. */
1034 static POINTER_TYPE
*
1035 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
1038 struct ablocks
*abase
;
1040 eassert (nbytes
<= BLOCK_BYTES
);
1044 #ifdef GC_MALLOC_CHECK
1045 allocated_mem_type
= type
;
1051 intptr_t aligned
; /* int gets warning casting to 64-bit pointer. */
1053 #ifdef DOUG_LEA_MALLOC
1054 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1055 because mapped region contents are not preserved in
1057 mallopt (M_MMAP_MAX
, 0);
1060 #ifdef USE_POSIX_MEMALIGN
1062 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1068 base
= malloc (ABLOCKS_BYTES
);
1069 abase
= ALIGN (base
, BLOCK_ALIGN
);
1074 MALLOC_UNBLOCK_INPUT
;
1075 memory_full (ABLOCKS_BYTES
);
1078 aligned
= (base
== abase
);
1080 ((void**)abase
)[-1] = base
;
1082 #ifdef DOUG_LEA_MALLOC
1083 /* Back to a reasonable maximum of mmap'ed areas. */
1084 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1088 /* If the memory just allocated cannot be addressed thru a Lisp
1089 object's pointer, and it needs to be, that's equivalent to
1090 running out of memory. */
1091 if (type
!= MEM_TYPE_NON_LISP
)
1094 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1095 XSETCONS (tem
, end
);
1096 if ((char *) XCONS (tem
) != end
)
1098 lisp_malloc_loser
= base
;
1100 MALLOC_UNBLOCK_INPUT
;
1101 memory_full (SIZE_MAX
);
1106 /* Initialize the blocks and put them on the free list.
1107 Is `base' was not properly aligned, we can't use the last block. */
1108 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1110 abase
->blocks
[i
].abase
= abase
;
1111 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1112 free_ablock
= &abase
->blocks
[i
];
1114 ABLOCKS_BUSY (abase
) = (struct ablocks
*) aligned
;
1116 eassert (0 == ((uintptr_t) abase
) % BLOCK_ALIGN
);
1117 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1118 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1119 eassert (ABLOCKS_BASE (abase
) == base
);
1120 eassert (aligned
== (intptr_t) ABLOCKS_BUSY (abase
));
1123 abase
= ABLOCK_ABASE (free_ablock
);
1124 ABLOCKS_BUSY (abase
) =
1125 (struct ablocks
*) (2 + (intptr_t) ABLOCKS_BUSY (abase
));
1127 free_ablock
= free_ablock
->x
.next_free
;
1129 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1130 if (type
!= MEM_TYPE_NON_LISP
)
1131 mem_insert (val
, (char *) val
+ nbytes
, type
);
1134 MALLOC_UNBLOCK_INPUT
;
1136 eassert (0 == ((uintptr_t) val
) % BLOCK_ALIGN
);
1141 lisp_align_free (POINTER_TYPE
*block
)
1143 struct ablock
*ablock
= block
;
1144 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1147 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1148 mem_delete (mem_find (block
));
1150 /* Put on free list. */
1151 ablock
->x
.next_free
= free_ablock
;
1152 free_ablock
= ablock
;
1153 /* Update busy count. */
1154 ABLOCKS_BUSY (abase
) =
1155 (struct ablocks
*) (-2 + (intptr_t) ABLOCKS_BUSY (abase
));
1157 if (2 > (intptr_t) ABLOCKS_BUSY (abase
))
1158 { /* All the blocks are free. */
1159 int i
= 0, aligned
= (intptr_t) ABLOCKS_BUSY (abase
);
1160 struct ablock
**tem
= &free_ablock
;
1161 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1165 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1168 *tem
= (*tem
)->x
.next_free
;
1171 tem
= &(*tem
)->x
.next_free
;
1173 eassert ((aligned
& 1) == aligned
);
1174 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1175 #ifdef USE_POSIX_MEMALIGN
1176 eassert ((uintptr_t) ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1178 free (ABLOCKS_BASE (abase
));
1180 MALLOC_UNBLOCK_INPUT
;
1183 /* Return a new buffer structure allocated from the heap with
1184 a call to lisp_malloc. */
1187 allocate_buffer (void)
1190 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1192 XSETPVECTYPESIZE (b
, PVEC_BUFFER
,
1193 ((sizeof (struct buffer
) + sizeof (EMACS_INT
) - 1)
1194 / sizeof (EMACS_INT
)));
1199 #ifndef SYSTEM_MALLOC
1201 /* Arranging to disable input signals while we're in malloc.
1203 This only works with GNU malloc. To help out systems which can't
1204 use GNU malloc, all the calls to malloc, realloc, and free
1205 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1206 pair; unfortunately, we have no idea what C library functions
1207 might call malloc, so we can't really protect them unless you're
1208 using GNU malloc. Fortunately, most of the major operating systems
1209 can use GNU malloc. */
1212 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1213 there's no need to block input around malloc. */
1215 #ifndef DOUG_LEA_MALLOC
1216 extern void * (*__malloc_hook
) (size_t, const void *);
1217 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1218 extern void (*__free_hook
) (void *, const void *);
1219 /* Else declared in malloc.h, perhaps with an extra arg. */
1220 #endif /* DOUG_LEA_MALLOC */
1221 static void * (*old_malloc_hook
) (size_t, const void *);
1222 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1223 static void (*old_free_hook
) (void*, const void*);
1225 #ifdef DOUG_LEA_MALLOC
1226 # define BYTES_USED (mallinfo ().uordblks)
1228 # define BYTES_USED _bytes_used
1231 static size_t bytes_used_when_reconsidered
;
1233 /* Value of _bytes_used, when spare_memory was freed. */
1235 static size_t bytes_used_when_full
;
1237 /* This function is used as the hook for free to call. */
1240 emacs_blocked_free (void *ptr
, const void *ptr2
)
1244 #ifdef GC_MALLOC_CHECK
1250 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1253 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1258 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1262 #endif /* GC_MALLOC_CHECK */
1264 __free_hook
= old_free_hook
;
1267 /* If we released our reserve (due to running out of memory),
1268 and we have a fair amount free once again,
1269 try to set aside another reserve in case we run out once more. */
1270 if (! NILP (Vmemory_full
)
1271 /* Verify there is enough space that even with the malloc
1272 hysteresis this call won't run out again.
1273 The code here is correct as long as SPARE_MEMORY
1274 is substantially larger than the block size malloc uses. */
1275 && (bytes_used_when_full
1276 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1277 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1278 refill_memory_reserve ();
1280 __free_hook
= emacs_blocked_free
;
1281 UNBLOCK_INPUT_ALLOC
;
1285 /* This function is the malloc hook that Emacs uses. */
1288 emacs_blocked_malloc (size_t size
, const void *ptr
)
1293 __malloc_hook
= old_malloc_hook
;
1294 #ifdef DOUG_LEA_MALLOC
1295 /* Segfaults on my system. --lorentey */
1296 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1298 __malloc_extra_blocks
= malloc_hysteresis
;
1301 value
= (void *) malloc (size
);
1303 #ifdef GC_MALLOC_CHECK
1305 struct mem_node
*m
= mem_find (value
);
1308 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1310 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1311 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1316 if (!dont_register_blocks
)
1318 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1319 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1322 #endif /* GC_MALLOC_CHECK */
1324 __malloc_hook
= emacs_blocked_malloc
;
1325 UNBLOCK_INPUT_ALLOC
;
1327 /* fprintf (stderr, "%p malloc\n", value); */
1332 /* This function is the realloc hook that Emacs uses. */
1335 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1340 __realloc_hook
= old_realloc_hook
;
1342 #ifdef GC_MALLOC_CHECK
1345 struct mem_node
*m
= mem_find (ptr
);
1346 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1349 "Realloc of %p which wasn't allocated with malloc\n",
1357 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1359 /* Prevent malloc from registering blocks. */
1360 dont_register_blocks
= 1;
1361 #endif /* GC_MALLOC_CHECK */
1363 value
= (void *) realloc (ptr
, size
);
1365 #ifdef GC_MALLOC_CHECK
1366 dont_register_blocks
= 0;
1369 struct mem_node
*m
= mem_find (value
);
1372 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1376 /* Can't handle zero size regions in the red-black tree. */
1377 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1380 /* fprintf (stderr, "%p <- realloc\n", value); */
1381 #endif /* GC_MALLOC_CHECK */
1383 __realloc_hook
= emacs_blocked_realloc
;
1384 UNBLOCK_INPUT_ALLOC
;
1391 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1392 normal malloc. Some thread implementations need this as they call
1393 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1394 calls malloc because it is the first call, and we have an endless loop. */
1397 reset_malloc_hooks (void)
1399 __free_hook
= old_free_hook
;
1400 __malloc_hook
= old_malloc_hook
;
1401 __realloc_hook
= old_realloc_hook
;
1403 #endif /* HAVE_PTHREAD */
1406 /* Called from main to set up malloc to use our hooks. */
1409 uninterrupt_malloc (void)
1412 #ifdef DOUG_LEA_MALLOC
1413 pthread_mutexattr_t attr
;
1415 /* GLIBC has a faster way to do this, but lets keep it portable.
1416 This is according to the Single UNIX Specification. */
1417 pthread_mutexattr_init (&attr
);
1418 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1419 pthread_mutex_init (&alloc_mutex
, &attr
);
1420 #else /* !DOUG_LEA_MALLOC */
1421 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1422 and the bundled gmalloc.c doesn't require it. */
1423 pthread_mutex_init (&alloc_mutex
, NULL
);
1424 #endif /* !DOUG_LEA_MALLOC */
1425 #endif /* HAVE_PTHREAD */
1427 if (__free_hook
!= emacs_blocked_free
)
1428 old_free_hook
= __free_hook
;
1429 __free_hook
= emacs_blocked_free
;
1431 if (__malloc_hook
!= emacs_blocked_malloc
)
1432 old_malloc_hook
= __malloc_hook
;
1433 __malloc_hook
= emacs_blocked_malloc
;
1435 if (__realloc_hook
!= emacs_blocked_realloc
)
1436 old_realloc_hook
= __realloc_hook
;
1437 __realloc_hook
= emacs_blocked_realloc
;
1440 #endif /* not SYNC_INPUT */
1441 #endif /* not SYSTEM_MALLOC */
1445 /***********************************************************************
1447 ***********************************************************************/
1449 /* Number of intervals allocated in an interval_block structure.
1450 The 1020 is 1024 minus malloc overhead. */
1452 #define INTERVAL_BLOCK_SIZE \
1453 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1455 /* Intervals are allocated in chunks in form of an interval_block
1458 struct interval_block
1460 /* Place `intervals' first, to preserve alignment. */
1461 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1462 struct interval_block
*next
;
1465 /* Current interval block. Its `next' pointer points to older
1468 static struct interval_block
*interval_block
;
1470 /* Index in interval_block above of the next unused interval
1473 static int interval_block_index
;
1475 /* Number of free and live intervals. */
1477 static EMACS_INT total_free_intervals
, total_intervals
;
1479 /* List of free intervals. */
1481 static INTERVAL interval_free_list
;
1484 /* Initialize interval allocation. */
1487 init_intervals (void)
1489 interval_block
= NULL
;
1490 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1491 interval_free_list
= 0;
1495 /* Return a new interval. */
1498 make_interval (void)
1502 /* eassert (!handling_signal); */
1506 if (interval_free_list
)
1508 val
= interval_free_list
;
1509 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1513 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1515 register struct interval_block
*newi
;
1517 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1520 newi
->next
= interval_block
;
1521 interval_block
= newi
;
1522 interval_block_index
= 0;
1524 val
= &interval_block
->intervals
[interval_block_index
++];
1527 MALLOC_UNBLOCK_INPUT
;
1529 consing_since_gc
+= sizeof (struct interval
);
1531 RESET_INTERVAL (val
);
1537 /* Mark Lisp objects in interval I. */
1540 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1542 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1544 mark_object (i
->plist
);
1548 /* Mark the interval tree rooted in TREE. Don't call this directly;
1549 use the macro MARK_INTERVAL_TREE instead. */
1552 mark_interval_tree (register INTERVAL tree
)
1554 /* No need to test if this tree has been marked already; this
1555 function is always called through the MARK_INTERVAL_TREE macro,
1556 which takes care of that. */
1558 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1562 /* Mark the interval tree rooted in I. */
1564 #define MARK_INTERVAL_TREE(i) \
1566 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1567 mark_interval_tree (i); \
1571 #define UNMARK_BALANCE_INTERVALS(i) \
1573 if (! NULL_INTERVAL_P (i)) \
1574 (i) = balance_intervals (i); \
1578 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1579 can't create number objects in macros. */
1582 make_number (EMACS_INT n
)
1586 obj
.s
.type
= Lisp_Int
;
1591 /***********************************************************************
1593 ***********************************************************************/
1595 /* Lisp_Strings are allocated in string_block structures. When a new
1596 string_block is allocated, all the Lisp_Strings it contains are
1597 added to a free-list string_free_list. When a new Lisp_String is
1598 needed, it is taken from that list. During the sweep phase of GC,
1599 string_blocks that are entirely free are freed, except two which
1602 String data is allocated from sblock structures. Strings larger
1603 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1604 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1606 Sblocks consist internally of sdata structures, one for each
1607 Lisp_String. The sdata structure points to the Lisp_String it
1608 belongs to. The Lisp_String points back to the `u.data' member of
1609 its sdata structure.
1611 When a Lisp_String is freed during GC, it is put back on
1612 string_free_list, and its `data' member and its sdata's `string'
1613 pointer is set to null. The size of the string is recorded in the
1614 `u.nbytes' member of the sdata. So, sdata structures that are no
1615 longer used, can be easily recognized, and it's easy to compact the
1616 sblocks of small strings which we do in compact_small_strings. */
1618 /* Size in bytes of an sblock structure used for small strings. This
1619 is 8192 minus malloc overhead. */
1621 #define SBLOCK_SIZE 8188
1623 /* Strings larger than this are considered large strings. String data
1624 for large strings is allocated from individual sblocks. */
1626 #define LARGE_STRING_BYTES 1024
1628 /* Structure describing string memory sub-allocated from an sblock.
1629 This is where the contents of Lisp strings are stored. */
1633 /* Back-pointer to the string this sdata belongs to. If null, this
1634 structure is free, and the NBYTES member of the union below
1635 contains the string's byte size (the same value that STRING_BYTES
1636 would return if STRING were non-null). If non-null, STRING_BYTES
1637 (STRING) is the size of the data, and DATA contains the string's
1639 struct Lisp_String
*string
;
1641 #ifdef GC_CHECK_STRING_BYTES
1644 unsigned char data
[1];
1646 #define SDATA_NBYTES(S) (S)->nbytes
1647 #define SDATA_DATA(S) (S)->data
1648 #define SDATA_SELECTOR(member) member
1650 #else /* not GC_CHECK_STRING_BYTES */
1654 /* When STRING is non-null. */
1655 unsigned char data
[1];
1657 /* When STRING is null. */
1661 #define SDATA_NBYTES(S) (S)->u.nbytes
1662 #define SDATA_DATA(S) (S)->u.data
1663 #define SDATA_SELECTOR(member) u.member
1665 #endif /* not GC_CHECK_STRING_BYTES */
1667 #define SDATA_DATA_OFFSET offsetof (struct sdata, SDATA_SELECTOR (data))
1671 /* Structure describing a block of memory which is sub-allocated to
1672 obtain string data memory for strings. Blocks for small strings
1673 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1674 as large as needed. */
1679 struct sblock
*next
;
1681 /* Pointer to the next free sdata block. This points past the end
1682 of the sblock if there isn't any space left in this block. */
1683 struct sdata
*next_free
;
1685 /* Start of data. */
1686 struct sdata first_data
;
1689 /* Number of Lisp strings in a string_block structure. The 1020 is
1690 1024 minus malloc overhead. */
1692 #define STRING_BLOCK_SIZE \
1693 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1695 /* Structure describing a block from which Lisp_String structures
1700 /* Place `strings' first, to preserve alignment. */
1701 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1702 struct string_block
*next
;
1705 /* Head and tail of the list of sblock structures holding Lisp string
1706 data. We always allocate from current_sblock. The NEXT pointers
1707 in the sblock structures go from oldest_sblock to current_sblock. */
1709 static struct sblock
*oldest_sblock
, *current_sblock
;
1711 /* List of sblocks for large strings. */
1713 static struct sblock
*large_sblocks
;
1715 /* List of string_block structures. */
1717 static struct string_block
*string_blocks
;
1719 /* Free-list of Lisp_Strings. */
1721 static struct Lisp_String
*string_free_list
;
1723 /* Number of live and free Lisp_Strings. */
1725 static EMACS_INT total_strings
, total_free_strings
;
1727 /* Number of bytes used by live strings. */
1729 static EMACS_INT total_string_size
;
1731 /* Given a pointer to a Lisp_String S which is on the free-list
1732 string_free_list, return a pointer to its successor in the
1735 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1737 /* Return a pointer to the sdata structure belonging to Lisp string S.
1738 S must be live, i.e. S->data must not be null. S->data is actually
1739 a pointer to the `u.data' member of its sdata structure; the
1740 structure starts at a constant offset in front of that. */
1742 #define SDATA_OF_STRING(S) ((struct sdata *) ((S)->data - SDATA_DATA_OFFSET))
1745 #ifdef GC_CHECK_STRING_OVERRUN
1747 /* We check for overrun in string data blocks by appending a small
1748 "cookie" after each allocated string data block, and check for the
1749 presence of this cookie during GC. */
1751 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1752 static char const string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1753 { '\xde', '\xad', '\xbe', '\xef' };
1756 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1759 /* Value is the size of an sdata structure large enough to hold NBYTES
1760 bytes of string data. The value returned includes a terminating
1761 NUL byte, the size of the sdata structure, and padding. */
1763 #ifdef GC_CHECK_STRING_BYTES
1765 #define SDATA_SIZE(NBYTES) \
1766 ((SDATA_DATA_OFFSET \
1768 + sizeof (EMACS_INT) - 1) \
1769 & ~(sizeof (EMACS_INT) - 1))
1771 #else /* not GC_CHECK_STRING_BYTES */
1773 /* The 'max' reserves space for the nbytes union member even when NBYTES + 1 is
1774 less than the size of that member. The 'max' is not needed when
1775 SDATA_DATA_OFFSET is a multiple of sizeof (EMACS_INT), because then the
1776 alignment code reserves enough space. */
1778 #define SDATA_SIZE(NBYTES) \
1779 ((SDATA_DATA_OFFSET \
1780 + (SDATA_DATA_OFFSET % sizeof (EMACS_INT) == 0 \
1782 : max (NBYTES, sizeof (EMACS_INT) - 1)) \
1784 + sizeof (EMACS_INT) - 1) \
1785 & ~(sizeof (EMACS_INT) - 1))
1787 #endif /* not GC_CHECK_STRING_BYTES */
1789 /* Extra bytes to allocate for each string. */
1791 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1793 /* Exact bound on the number of bytes in a string, not counting the
1794 terminating null. A string cannot contain more bytes than
1795 STRING_BYTES_BOUND, nor can it be so long that the size_t
1796 arithmetic in allocate_string_data would overflow while it is
1797 calculating a value to be passed to malloc. */
1798 #define STRING_BYTES_MAX \
1799 min (STRING_BYTES_BOUND, \
1800 ((SIZE_MAX - XMALLOC_OVERRUN_CHECK_OVERHEAD \
1802 - offsetof (struct sblock, first_data) \
1803 - SDATA_DATA_OFFSET) \
1804 & ~(sizeof (EMACS_INT) - 1)))
1806 /* Initialize string allocation. Called from init_alloc_once. */
1811 total_strings
= total_free_strings
= total_string_size
= 0;
1812 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1813 string_blocks
= NULL
;
1814 string_free_list
= NULL
;
1815 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1816 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1820 #ifdef GC_CHECK_STRING_BYTES
1822 static int check_string_bytes_count
;
1824 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1827 /* Like GC_STRING_BYTES, but with debugging check. */
1830 string_bytes (struct Lisp_String
*s
)
1833 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1835 if (!PURE_POINTER_P (s
)
1837 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1842 /* Check validity of Lisp strings' string_bytes member in B. */
1845 check_sblock (struct sblock
*b
)
1847 struct sdata
*from
, *end
, *from_end
;
1851 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1853 /* Compute the next FROM here because copying below may
1854 overwrite data we need to compute it. */
1857 /* Check that the string size recorded in the string is the
1858 same as the one recorded in the sdata structure. */
1860 CHECK_STRING_BYTES (from
->string
);
1863 nbytes
= GC_STRING_BYTES (from
->string
);
1865 nbytes
= SDATA_NBYTES (from
);
1867 nbytes
= SDATA_SIZE (nbytes
);
1868 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1873 /* Check validity of Lisp strings' string_bytes member. ALL_P
1874 non-zero means check all strings, otherwise check only most
1875 recently allocated strings. Used for hunting a bug. */
1878 check_string_bytes (int all_p
)
1884 for (b
= large_sblocks
; b
; b
= b
->next
)
1886 struct Lisp_String
*s
= b
->first_data
.string
;
1888 CHECK_STRING_BYTES (s
);
1891 for (b
= oldest_sblock
; b
; b
= b
->next
)
1895 check_sblock (current_sblock
);
1898 #endif /* GC_CHECK_STRING_BYTES */
1900 #ifdef GC_CHECK_STRING_FREE_LIST
1902 /* Walk through the string free list looking for bogus next pointers.
1903 This may catch buffer overrun from a previous string. */
1906 check_string_free_list (void)
1908 struct Lisp_String
*s
;
1910 /* Pop a Lisp_String off the free-list. */
1911 s
= string_free_list
;
1914 if ((uintptr_t) s
< 1024)
1916 s
= NEXT_FREE_LISP_STRING (s
);
1920 #define check_string_free_list()
1923 /* Return a new Lisp_String. */
1925 static struct Lisp_String
*
1926 allocate_string (void)
1928 struct Lisp_String
*s
;
1930 /* eassert (!handling_signal); */
1934 /* If the free-list is empty, allocate a new string_block, and
1935 add all the Lisp_Strings in it to the free-list. */
1936 if (string_free_list
== NULL
)
1938 struct string_block
*b
;
1941 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1942 memset (b
, 0, sizeof *b
);
1943 b
->next
= string_blocks
;
1946 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1949 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1950 string_free_list
= s
;
1953 total_free_strings
+= STRING_BLOCK_SIZE
;
1956 check_string_free_list ();
1958 /* Pop a Lisp_String off the free-list. */
1959 s
= string_free_list
;
1960 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1962 MALLOC_UNBLOCK_INPUT
;
1964 /* Probably not strictly necessary, but play it safe. */
1965 memset (s
, 0, sizeof *s
);
1967 --total_free_strings
;
1970 consing_since_gc
+= sizeof *s
;
1972 #ifdef GC_CHECK_STRING_BYTES
1973 if (!noninteractive
)
1975 if (++check_string_bytes_count
== 200)
1977 check_string_bytes_count
= 0;
1978 check_string_bytes (1);
1981 check_string_bytes (0);
1983 #endif /* GC_CHECK_STRING_BYTES */
1989 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1990 plus a NUL byte at the end. Allocate an sdata structure for S, and
1991 set S->data to its `u.data' member. Store a NUL byte at the end of
1992 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1993 S->data if it was initially non-null. */
1996 allocate_string_data (struct Lisp_String
*s
,
1997 EMACS_INT nchars
, EMACS_INT nbytes
)
1999 struct sdata
*data
, *old_data
;
2001 EMACS_INT needed
, old_nbytes
;
2003 if (STRING_BYTES_MAX
< nbytes
)
2006 /* Determine the number of bytes needed to store NBYTES bytes
2008 needed
= SDATA_SIZE (nbytes
);
2009 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
2010 old_nbytes
= GC_STRING_BYTES (s
);
2014 if (nbytes
> LARGE_STRING_BYTES
)
2016 size_t size
= offsetof (struct sblock
, first_data
) + needed
;
2018 #ifdef DOUG_LEA_MALLOC
2019 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2020 because mapped region contents are not preserved in
2023 In case you think of allowing it in a dumped Emacs at the
2024 cost of not being able to re-dump, there's another reason:
2025 mmap'ed data typically have an address towards the top of the
2026 address space, which won't fit into an EMACS_INT (at least on
2027 32-bit systems with the current tagging scheme). --fx */
2028 mallopt (M_MMAP_MAX
, 0);
2031 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
2033 #ifdef DOUG_LEA_MALLOC
2034 /* Back to a reasonable maximum of mmap'ed areas. */
2035 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2038 b
->next_free
= &b
->first_data
;
2039 b
->first_data
.string
= NULL
;
2040 b
->next
= large_sblocks
;
2043 else if (current_sblock
== NULL
2044 || (((char *) current_sblock
+ SBLOCK_SIZE
2045 - (char *) current_sblock
->next_free
)
2046 < (needed
+ GC_STRING_EXTRA
)))
2048 /* Not enough room in the current sblock. */
2049 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2050 b
->next_free
= &b
->first_data
;
2051 b
->first_data
.string
= NULL
;
2055 current_sblock
->next
= b
;
2063 data
= b
->next_free
;
2064 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2066 MALLOC_UNBLOCK_INPUT
;
2069 s
->data
= SDATA_DATA (data
);
2070 #ifdef GC_CHECK_STRING_BYTES
2071 SDATA_NBYTES (data
) = nbytes
;
2074 s
->size_byte
= nbytes
;
2075 s
->data
[nbytes
] = '\0';
2076 #ifdef GC_CHECK_STRING_OVERRUN
2077 memcpy ((char *) data
+ needed
, string_overrun_cookie
,
2078 GC_STRING_OVERRUN_COOKIE_SIZE
);
2081 /* If S had already data assigned, mark that as free by setting its
2082 string back-pointer to null, and recording the size of the data
2086 SDATA_NBYTES (old_data
) = old_nbytes
;
2087 old_data
->string
= NULL
;
2090 consing_since_gc
+= needed
;
2094 /* Sweep and compact strings. */
2097 sweep_strings (void)
2099 struct string_block
*b
, *next
;
2100 struct string_block
*live_blocks
= NULL
;
2102 string_free_list
= NULL
;
2103 total_strings
= total_free_strings
= 0;
2104 total_string_size
= 0;
2106 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2107 for (b
= string_blocks
; b
; b
= next
)
2110 struct Lisp_String
*free_list_before
= string_free_list
;
2114 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2116 struct Lisp_String
*s
= b
->strings
+ i
;
2120 /* String was not on free-list before. */
2121 if (STRING_MARKED_P (s
))
2123 /* String is live; unmark it and its intervals. */
2126 if (!NULL_INTERVAL_P (s
->intervals
))
2127 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2130 total_string_size
+= STRING_BYTES (s
);
2134 /* String is dead. Put it on the free-list. */
2135 struct sdata
*data
= SDATA_OF_STRING (s
);
2137 /* Save the size of S in its sdata so that we know
2138 how large that is. Reset the sdata's string
2139 back-pointer so that we know it's free. */
2140 #ifdef GC_CHECK_STRING_BYTES
2141 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2144 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2146 data
->string
= NULL
;
2148 /* Reset the strings's `data' member so that we
2152 /* Put the string on the free-list. */
2153 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2154 string_free_list
= s
;
2160 /* S was on the free-list before. Put it there again. */
2161 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2162 string_free_list
= s
;
2167 /* Free blocks that contain free Lisp_Strings only, except
2168 the first two of them. */
2169 if (nfree
== STRING_BLOCK_SIZE
2170 && total_free_strings
> STRING_BLOCK_SIZE
)
2173 string_free_list
= free_list_before
;
2177 total_free_strings
+= nfree
;
2178 b
->next
= live_blocks
;
2183 check_string_free_list ();
2185 string_blocks
= live_blocks
;
2186 free_large_strings ();
2187 compact_small_strings ();
2189 check_string_free_list ();
2193 /* Free dead large strings. */
2196 free_large_strings (void)
2198 struct sblock
*b
, *next
;
2199 struct sblock
*live_blocks
= NULL
;
2201 for (b
= large_sblocks
; b
; b
= next
)
2205 if (b
->first_data
.string
== NULL
)
2209 b
->next
= live_blocks
;
2214 large_sblocks
= live_blocks
;
2218 /* Compact data of small strings. Free sblocks that don't contain
2219 data of live strings after compaction. */
2222 compact_small_strings (void)
2224 struct sblock
*b
, *tb
, *next
;
2225 struct sdata
*from
, *to
, *end
, *tb_end
;
2226 struct sdata
*to_end
, *from_end
;
2228 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2229 to, and TB_END is the end of TB. */
2231 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2232 to
= &tb
->first_data
;
2234 /* Step through the blocks from the oldest to the youngest. We
2235 expect that old blocks will stabilize over time, so that less
2236 copying will happen this way. */
2237 for (b
= oldest_sblock
; b
; b
= b
->next
)
2240 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2242 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2244 /* Compute the next FROM here because copying below may
2245 overwrite data we need to compute it. */
2248 #ifdef GC_CHECK_STRING_BYTES
2249 /* Check that the string size recorded in the string is the
2250 same as the one recorded in the sdata structure. */
2252 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2254 #endif /* GC_CHECK_STRING_BYTES */
2257 nbytes
= GC_STRING_BYTES (from
->string
);
2259 nbytes
= SDATA_NBYTES (from
);
2261 if (nbytes
> LARGE_STRING_BYTES
)
2264 nbytes
= SDATA_SIZE (nbytes
);
2265 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2267 #ifdef GC_CHECK_STRING_OVERRUN
2268 if (memcmp (string_overrun_cookie
,
2269 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2270 GC_STRING_OVERRUN_COOKIE_SIZE
))
2274 /* FROM->string non-null means it's alive. Copy its data. */
2277 /* If TB is full, proceed with the next sblock. */
2278 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2279 if (to_end
> tb_end
)
2283 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2284 to
= &tb
->first_data
;
2285 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2288 /* Copy, and update the string's `data' pointer. */
2291 xassert (tb
!= b
|| to
< from
);
2292 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2293 to
->string
->data
= SDATA_DATA (to
);
2296 /* Advance past the sdata we copied to. */
2302 /* The rest of the sblocks following TB don't contain live data, so
2303 we can free them. */
2304 for (b
= tb
->next
; b
; b
= next
)
2312 current_sblock
= tb
;
2316 string_overflow (void)
2318 error ("Maximum string size exceeded");
2321 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2322 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2323 LENGTH must be an integer.
2324 INIT must be an integer that represents a character. */)
2325 (Lisp_Object length
, Lisp_Object init
)
2327 register Lisp_Object val
;
2328 register unsigned char *p
, *end
;
2332 CHECK_NATNUM (length
);
2333 CHECK_CHARACTER (init
);
2335 c
= XFASTINT (init
);
2336 if (ASCII_CHAR_P (c
))
2338 nbytes
= XINT (length
);
2339 val
= make_uninit_string (nbytes
);
2341 end
= p
+ SCHARS (val
);
2347 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2348 int len
= CHAR_STRING (c
, str
);
2349 EMACS_INT string_len
= XINT (length
);
2351 if (string_len
> STRING_BYTES_MAX
/ len
)
2353 nbytes
= len
* string_len
;
2354 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2359 memcpy (p
, str
, len
);
2369 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2370 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2371 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2372 (Lisp_Object length
, Lisp_Object init
)
2374 register Lisp_Object val
;
2375 struct Lisp_Bool_Vector
*p
;
2376 EMACS_INT length_in_chars
, length_in_elts
;
2379 CHECK_NATNUM (length
);
2381 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2383 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2384 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2385 / BOOL_VECTOR_BITS_PER_CHAR
);
2387 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2388 slot `size' of the struct Lisp_Bool_Vector. */
2389 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2391 /* No Lisp_Object to trace in there. */
2392 XSETPVECTYPESIZE (XVECTOR (val
), PVEC_BOOL_VECTOR
, 0);
2394 p
= XBOOL_VECTOR (val
);
2395 p
->size
= XFASTINT (length
);
2397 if (length_in_chars
)
2399 memset (p
->data
, ! NILP (init
) ? -1 : 0, length_in_chars
);
2401 /* Clear any extraneous bits in the last byte. */
2402 p
->data
[length_in_chars
- 1]
2403 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2410 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2411 of characters from the contents. This string may be unibyte or
2412 multibyte, depending on the contents. */
2415 make_string (const char *contents
, EMACS_INT nbytes
)
2417 register Lisp_Object val
;
2418 EMACS_INT nchars
, multibyte_nbytes
;
2420 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2421 &nchars
, &multibyte_nbytes
);
2422 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2423 /* CONTENTS contains no multibyte sequences or contains an invalid
2424 multibyte sequence. We must make unibyte string. */
2425 val
= make_unibyte_string (contents
, nbytes
);
2427 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2432 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2435 make_unibyte_string (const char *contents
, EMACS_INT length
)
2437 register Lisp_Object val
;
2438 val
= make_uninit_string (length
);
2439 memcpy (SDATA (val
), contents
, length
);
2444 /* Make a multibyte string from NCHARS characters occupying NBYTES
2445 bytes at CONTENTS. */
2448 make_multibyte_string (const char *contents
,
2449 EMACS_INT nchars
, EMACS_INT nbytes
)
2451 register Lisp_Object val
;
2452 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2453 memcpy (SDATA (val
), contents
, nbytes
);
2458 /* Make a string from NCHARS characters occupying NBYTES bytes at
2459 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2462 make_string_from_bytes (const char *contents
,
2463 EMACS_INT nchars
, EMACS_INT nbytes
)
2465 register Lisp_Object val
;
2466 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2467 memcpy (SDATA (val
), contents
, nbytes
);
2468 if (SBYTES (val
) == SCHARS (val
))
2469 STRING_SET_UNIBYTE (val
);
2474 /* Make a string from NCHARS characters occupying NBYTES bytes at
2475 CONTENTS. The argument MULTIBYTE controls whether to label the
2476 string as multibyte. If NCHARS is negative, it counts the number of
2477 characters by itself. */
2480 make_specified_string (const char *contents
,
2481 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
2483 register Lisp_Object val
;
2488 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2493 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2494 memcpy (SDATA (val
), contents
, nbytes
);
2496 STRING_SET_UNIBYTE (val
);
2501 /* Make a string from the data at STR, treating it as multibyte if the
2505 build_string (const char *str
)
2507 return make_string (str
, strlen (str
));
2511 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2512 occupying LENGTH bytes. */
2515 make_uninit_string (EMACS_INT length
)
2520 return empty_unibyte_string
;
2521 val
= make_uninit_multibyte_string (length
, length
);
2522 STRING_SET_UNIBYTE (val
);
2527 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2528 which occupy NBYTES bytes. */
2531 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2534 struct Lisp_String
*s
;
2539 return empty_multibyte_string
;
2541 s
= allocate_string ();
2542 allocate_string_data (s
, nchars
, nbytes
);
2543 XSETSTRING (string
, s
);
2544 string_chars_consed
+= nbytes
;
2550 /***********************************************************************
2552 ***********************************************************************/
2554 /* We store float cells inside of float_blocks, allocating a new
2555 float_block with malloc whenever necessary. Float cells reclaimed
2556 by GC are put on a free list to be reallocated before allocating
2557 any new float cells from the latest float_block. */
2559 #define FLOAT_BLOCK_SIZE \
2560 (((BLOCK_BYTES - sizeof (struct float_block *) \
2561 /* The compiler might add padding at the end. */ \
2562 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2563 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2565 #define GETMARKBIT(block,n) \
2566 (((block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2567 >> ((n) % (sizeof (int) * CHAR_BIT))) \
2570 #define SETMARKBIT(block,n) \
2571 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2572 |= 1 << ((n) % (sizeof (int) * CHAR_BIT))
2574 #define UNSETMARKBIT(block,n) \
2575 (block)->gcmarkbits[(n) / (sizeof (int) * CHAR_BIT)] \
2576 &= ~(1 << ((n) % (sizeof (int) * CHAR_BIT)))
2578 #define FLOAT_BLOCK(fptr) \
2579 ((struct float_block *) (((uintptr_t) (fptr)) & ~(BLOCK_ALIGN - 1)))
2581 #define FLOAT_INDEX(fptr) \
2582 ((((uintptr_t) (fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2586 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2587 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2588 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2589 struct float_block
*next
;
2592 #define FLOAT_MARKED_P(fptr) \
2593 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2595 #define FLOAT_MARK(fptr) \
2596 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2598 #define FLOAT_UNMARK(fptr) \
2599 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2601 /* Current float_block. */
2603 static struct float_block
*float_block
;
2605 /* Index of first unused Lisp_Float in the current float_block. */
2607 static int float_block_index
;
2609 /* Free-list of Lisp_Floats. */
2611 static struct Lisp_Float
*float_free_list
;
2614 /* Initialize float allocation. */
2620 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2621 float_free_list
= 0;
2625 /* Return a new float object with value FLOAT_VALUE. */
2628 make_float (double float_value
)
2630 register Lisp_Object val
;
2632 /* eassert (!handling_signal); */
2636 if (float_free_list
)
2638 /* We use the data field for chaining the free list
2639 so that we won't use the same field that has the mark bit. */
2640 XSETFLOAT (val
, float_free_list
);
2641 float_free_list
= float_free_list
->u
.chain
;
2645 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2647 register struct float_block
*new;
2649 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2651 new->next
= float_block
;
2652 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2654 float_block_index
= 0;
2656 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2657 float_block_index
++;
2660 MALLOC_UNBLOCK_INPUT
;
2662 XFLOAT_INIT (val
, float_value
);
2663 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2664 consing_since_gc
+= sizeof (struct Lisp_Float
);
2671 /***********************************************************************
2673 ***********************************************************************/
2675 /* We store cons cells inside of cons_blocks, allocating a new
2676 cons_block with malloc whenever necessary. Cons cells reclaimed by
2677 GC are put on a free list to be reallocated before allocating
2678 any new cons cells from the latest cons_block. */
2680 #define CONS_BLOCK_SIZE \
2681 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2682 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2684 #define CONS_BLOCK(fptr) \
2685 ((struct cons_block *) ((uintptr_t) (fptr) & ~(BLOCK_ALIGN - 1)))
2687 #define CONS_INDEX(fptr) \
2688 (((uintptr_t) (fptr) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2692 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2693 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2694 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof (int) * CHAR_BIT
)];
2695 struct cons_block
*next
;
2698 #define CONS_MARKED_P(fptr) \
2699 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2701 #define CONS_MARK(fptr) \
2702 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2704 #define CONS_UNMARK(fptr) \
2705 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2707 /* Current cons_block. */
2709 static struct cons_block
*cons_block
;
2711 /* Index of first unused Lisp_Cons in the current block. */
2713 static int cons_block_index
;
2715 /* Free-list of Lisp_Cons structures. */
2717 static struct Lisp_Cons
*cons_free_list
;
2720 /* Initialize cons allocation. */
2726 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2731 /* Explicitly free a cons cell by putting it on the free-list. */
2734 free_cons (struct Lisp_Cons
*ptr
)
2736 ptr
->u
.chain
= cons_free_list
;
2740 cons_free_list
= ptr
;
2743 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2744 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2745 (Lisp_Object car
, Lisp_Object cdr
)
2747 register Lisp_Object val
;
2749 /* eassert (!handling_signal); */
2755 /* We use the cdr for chaining the free list
2756 so that we won't use the same field that has the mark bit. */
2757 XSETCONS (val
, cons_free_list
);
2758 cons_free_list
= cons_free_list
->u
.chain
;
2762 if (cons_block_index
== CONS_BLOCK_SIZE
)
2764 register struct cons_block
*new;
2765 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2767 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2768 new->next
= cons_block
;
2770 cons_block_index
= 0;
2772 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2776 MALLOC_UNBLOCK_INPUT
;
2780 eassert (!CONS_MARKED_P (XCONS (val
)));
2781 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2782 cons_cells_consed
++;
2786 #ifdef GC_CHECK_CONS_LIST
2787 /* Get an error now if there's any junk in the cons free list. */
2789 check_cons_list (void)
2791 struct Lisp_Cons
*tail
= cons_free_list
;
2794 tail
= tail
->u
.chain
;
2798 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2801 list1 (Lisp_Object arg1
)
2803 return Fcons (arg1
, Qnil
);
2807 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2809 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2814 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2816 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2821 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2823 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2828 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2830 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2831 Fcons (arg5
, Qnil
)))));
2835 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2836 doc
: /* Return a newly created list with specified arguments as elements.
2837 Any number of arguments, even zero arguments, are allowed.
2838 usage: (list &rest OBJECTS) */)
2839 (ptrdiff_t nargs
, Lisp_Object
*args
)
2841 register Lisp_Object val
;
2847 val
= Fcons (args
[nargs
], val
);
2853 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2854 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2855 (register Lisp_Object length
, Lisp_Object init
)
2857 register Lisp_Object val
;
2858 register EMACS_INT size
;
2860 CHECK_NATNUM (length
);
2861 size
= XFASTINT (length
);
2866 val
= Fcons (init
, val
);
2871 val
= Fcons (init
, val
);
2876 val
= Fcons (init
, val
);
2881 val
= Fcons (init
, val
);
2886 val
= Fcons (init
, val
);
2901 /***********************************************************************
2903 ***********************************************************************/
2905 /* Singly-linked list of all vectors. */
2907 static struct Lisp_Vector
*all_vectors
;
2909 /* Handy constants for vectorlike objects. */
2912 header_size
= offsetof (struct Lisp_Vector
, contents
),
2913 word_size
= sizeof (Lisp_Object
)
2916 /* Value is a pointer to a newly allocated Lisp_Vector structure
2917 with room for LEN Lisp_Objects. */
2919 static struct Lisp_Vector
*
2920 allocate_vectorlike (EMACS_INT len
)
2922 struct Lisp_Vector
*p
;
2927 #ifdef DOUG_LEA_MALLOC
2928 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2929 because mapped region contents are not preserved in
2931 mallopt (M_MMAP_MAX
, 0);
2934 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2935 /* eassert (!handling_signal); */
2937 nbytes
= header_size
+ len
* word_size
;
2938 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
2940 #ifdef DOUG_LEA_MALLOC
2941 /* Back to a reasonable maximum of mmap'ed areas. */
2942 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2945 consing_since_gc
+= nbytes
;
2946 vector_cells_consed
+= len
;
2948 p
->header
.next
.vector
= all_vectors
;
2951 MALLOC_UNBLOCK_INPUT
;
2957 /* Allocate a vector with LEN slots. */
2959 struct Lisp_Vector
*
2960 allocate_vector (EMACS_INT len
)
2962 struct Lisp_Vector
*v
;
2963 ptrdiff_t nbytes_max
= min (PTRDIFF_MAX
, SIZE_MAX
);
2965 if (min ((nbytes_max
- header_size
) / word_size
, MOST_POSITIVE_FIXNUM
) < len
)
2966 memory_full (SIZE_MAX
);
2967 v
= allocate_vectorlike (len
);
2968 v
->header
.size
= len
;
2973 /* Allocate other vector-like structures. */
2975 struct Lisp_Vector
*
2976 allocate_pseudovector (int memlen
, int lisplen
, EMACS_INT tag
)
2978 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2981 /* Only the first lisplen slots will be traced normally by the GC. */
2982 for (i
= 0; i
< lisplen
; ++i
)
2983 v
->contents
[i
] = Qnil
;
2985 XSETPVECTYPESIZE (v
, tag
, lisplen
);
2989 struct Lisp_Hash_Table
*
2990 allocate_hash_table (void)
2992 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
2997 allocate_window (void)
2999 return ALLOCATE_PSEUDOVECTOR (struct window
, current_matrix
, PVEC_WINDOW
);
3004 allocate_terminal (void)
3006 struct terminal
*t
= ALLOCATE_PSEUDOVECTOR (struct terminal
,
3007 next_terminal
, PVEC_TERMINAL
);
3008 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3009 memset (&t
->next_terminal
, 0,
3010 (char*) (t
+ 1) - (char*) &t
->next_terminal
);
3016 allocate_frame (void)
3018 struct frame
*f
= ALLOCATE_PSEUDOVECTOR (struct frame
,
3019 face_cache
, PVEC_FRAME
);
3020 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3021 memset (&f
->face_cache
, 0,
3022 (char *) (f
+ 1) - (char *) &f
->face_cache
);
3027 struct Lisp_Process
*
3028 allocate_process (void)
3030 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
3034 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3035 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3036 See also the function `vector'. */)
3037 (register Lisp_Object length
, Lisp_Object init
)
3040 register EMACS_INT sizei
;
3041 register EMACS_INT i
;
3042 register struct Lisp_Vector
*p
;
3044 CHECK_NATNUM (length
);
3045 sizei
= XFASTINT (length
);
3047 p
= allocate_vector (sizei
);
3048 for (i
= 0; i
< sizei
; i
++)
3049 p
->contents
[i
] = init
;
3051 XSETVECTOR (vector
, p
);
3056 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3057 doc
: /* Return a newly created vector with specified arguments as elements.
3058 Any number of arguments, even zero arguments, are allowed.
3059 usage: (vector &rest OBJECTS) */)
3060 (ptrdiff_t nargs
, Lisp_Object
*args
)
3062 register Lisp_Object len
, val
;
3064 register struct Lisp_Vector
*p
;
3066 XSETFASTINT (len
, nargs
);
3067 val
= Fmake_vector (len
, Qnil
);
3069 for (i
= 0; i
< nargs
; i
++)
3070 p
->contents
[i
] = args
[i
];
3075 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3076 doc
: /* Create a byte-code object with specified arguments as elements.
3077 The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant
3078 vector CONSTANTS, maximum stack size DEPTH, (optional) DOCSTRING,
3079 and (optional) INTERACTIVE-SPEC.
3080 The first four arguments are required; at most six have any
3082 The ARGLIST can be either like the one of `lambda', in which case the arguments
3083 will be dynamically bound before executing the byte code, or it can be an
3084 integer of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the
3085 minimum number of arguments, the 7-bit NNNNNNN specifies the maximum number
3086 of arguments (ignoring &rest) and the R bit specifies whether there is a &rest
3087 argument to catch the left-over arguments. If such an integer is used, the
3088 arguments will not be dynamically bound but will be instead pushed on the
3089 stack before executing the byte-code.
3090 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3091 (ptrdiff_t nargs
, Lisp_Object
*args
)
3093 register Lisp_Object len
, val
;
3095 register struct Lisp_Vector
*p
;
3097 XSETFASTINT (len
, nargs
);
3098 if (!NILP (Vpurify_flag
))
3099 val
= make_pure_vector (nargs
);
3101 val
= Fmake_vector (len
, Qnil
);
3103 if (nargs
> 1 && STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3104 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3105 earlier because they produced a raw 8-bit string for byte-code
3106 and now such a byte-code string is loaded as multibyte while
3107 raw 8-bit characters converted to multibyte form. Thus, now we
3108 must convert them back to the original unibyte form. */
3109 args
[1] = Fstring_as_unibyte (args
[1]);
3112 for (i
= 0; i
< nargs
; i
++)
3114 if (!NILP (Vpurify_flag
))
3115 args
[i
] = Fpurecopy (args
[i
]);
3116 p
->contents
[i
] = args
[i
];
3118 XSETPVECTYPE (p
, PVEC_COMPILED
);
3119 XSETCOMPILED (val
, p
);
3125 /***********************************************************************
3127 ***********************************************************************/
3129 /* Each symbol_block is just under 1020 bytes long, since malloc
3130 really allocates in units of powers of two and uses 4 bytes for its
3133 #define SYMBOL_BLOCK_SIZE \
3134 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3138 /* Place `symbols' first, to preserve alignment. */
3139 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3140 struct symbol_block
*next
;
3143 /* Current symbol block and index of first unused Lisp_Symbol
3146 static struct symbol_block
*symbol_block
;
3147 static int symbol_block_index
;
3149 /* List of free symbols. */
3151 static struct Lisp_Symbol
*symbol_free_list
;
3154 /* Initialize symbol allocation. */
3159 symbol_block
= NULL
;
3160 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3161 symbol_free_list
= 0;
3165 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3166 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3167 Its value and function definition are void, and its property list is nil. */)
3170 register Lisp_Object val
;
3171 register struct Lisp_Symbol
*p
;
3173 CHECK_STRING (name
);
3175 /* eassert (!handling_signal); */
3179 if (symbol_free_list
)
3181 XSETSYMBOL (val
, symbol_free_list
);
3182 symbol_free_list
= symbol_free_list
->next
;
3186 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3188 struct symbol_block
*new;
3189 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3191 new->next
= symbol_block
;
3193 symbol_block_index
= 0;
3195 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3196 symbol_block_index
++;
3199 MALLOC_UNBLOCK_INPUT
;
3204 p
->redirect
= SYMBOL_PLAINVAL
;
3205 SET_SYMBOL_VAL (p
, Qunbound
);
3206 p
->function
= Qunbound
;
3209 p
->interned
= SYMBOL_UNINTERNED
;
3211 p
->declared_special
= 0;
3212 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3219 /***********************************************************************
3220 Marker (Misc) Allocation
3221 ***********************************************************************/
3223 /* Allocation of markers and other objects that share that structure.
3224 Works like allocation of conses. */
3226 #define MARKER_BLOCK_SIZE \
3227 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3231 /* Place `markers' first, to preserve alignment. */
3232 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3233 struct marker_block
*next
;
3236 static struct marker_block
*marker_block
;
3237 static int marker_block_index
;
3239 static union Lisp_Misc
*marker_free_list
;
3244 marker_block
= NULL
;
3245 marker_block_index
= MARKER_BLOCK_SIZE
;
3246 marker_free_list
= 0;
3249 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3252 allocate_misc (void)
3256 /* eassert (!handling_signal); */
3260 if (marker_free_list
)
3262 XSETMISC (val
, marker_free_list
);
3263 marker_free_list
= marker_free_list
->u_free
.chain
;
3267 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3269 struct marker_block
*new;
3270 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3272 new->next
= marker_block
;
3274 marker_block_index
= 0;
3275 total_free_markers
+= MARKER_BLOCK_SIZE
;
3277 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3278 marker_block_index
++;
3281 MALLOC_UNBLOCK_INPUT
;
3283 --total_free_markers
;
3284 consing_since_gc
+= sizeof (union Lisp_Misc
);
3285 misc_objects_consed
++;
3286 XMISCANY (val
)->gcmarkbit
= 0;
3290 /* Free a Lisp_Misc object */
3293 free_misc (Lisp_Object misc
)
3295 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3296 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3297 marker_free_list
= XMISC (misc
);
3299 total_free_markers
++;
3302 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3303 INTEGER. This is used to package C values to call record_unwind_protect.
3304 The unwind function can get the C values back using XSAVE_VALUE. */
3307 make_save_value (void *pointer
, ptrdiff_t integer
)
3309 register Lisp_Object val
;
3310 register struct Lisp_Save_Value
*p
;
3312 val
= allocate_misc ();
3313 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3314 p
= XSAVE_VALUE (val
);
3315 p
->pointer
= pointer
;
3316 p
->integer
= integer
;
3321 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3322 doc
: /* Return a newly allocated marker which does not point at any place. */)
3325 register Lisp_Object val
;
3326 register struct Lisp_Marker
*p
;
3328 val
= allocate_misc ();
3329 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3335 p
->insertion_type
= 0;
3339 /* Put MARKER back on the free list after using it temporarily. */
3342 free_marker (Lisp_Object marker
)
3344 unchain_marker (XMARKER (marker
));
3349 /* Return a newly created vector or string with specified arguments as
3350 elements. If all the arguments are characters that can fit
3351 in a string of events, make a string; otherwise, make a vector.
3353 Any number of arguments, even zero arguments, are allowed. */
3356 make_event_array (register int nargs
, Lisp_Object
*args
)
3360 for (i
= 0; i
< nargs
; i
++)
3361 /* The things that fit in a string
3362 are characters that are in 0...127,
3363 after discarding the meta bit and all the bits above it. */
3364 if (!INTEGERP (args
[i
])
3365 || (XINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3366 return Fvector (nargs
, args
);
3368 /* Since the loop exited, we know that all the things in it are
3369 characters, so we can make a string. */
3373 result
= Fmake_string (make_number (nargs
), make_number (0));
3374 for (i
= 0; i
< nargs
; i
++)
3376 SSET (result
, i
, XINT (args
[i
]));
3377 /* Move the meta bit to the right place for a string char. */
3378 if (XINT (args
[i
]) & CHAR_META
)
3379 SSET (result
, i
, SREF (result
, i
) | 0x80);
3388 /************************************************************************
3389 Memory Full Handling
3390 ************************************************************************/
3393 /* Called if malloc (NBYTES) returns zero. If NBYTES == SIZE_MAX,
3394 there may have been size_t overflow so that malloc was never
3395 called, or perhaps malloc was invoked successfully but the
3396 resulting pointer had problems fitting into a tagged EMACS_INT. In
3397 either case this counts as memory being full even though malloc did
3401 memory_full (size_t nbytes
)
3403 /* Do not go into hysterics merely because a large request failed. */
3404 int enough_free_memory
= 0;
3405 if (SPARE_MEMORY
< nbytes
)
3410 p
= malloc (SPARE_MEMORY
);
3414 enough_free_memory
= 1;
3416 MALLOC_UNBLOCK_INPUT
;
3419 if (! enough_free_memory
)
3425 memory_full_cons_threshold
= sizeof (struct cons_block
);
3427 /* The first time we get here, free the spare memory. */
3428 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3429 if (spare_memory
[i
])
3432 free (spare_memory
[i
]);
3433 else if (i
>= 1 && i
<= 4)
3434 lisp_align_free (spare_memory
[i
]);
3436 lisp_free (spare_memory
[i
]);
3437 spare_memory
[i
] = 0;
3440 /* Record the space now used. When it decreases substantially,
3441 we can refill the memory reserve. */
3442 #if !defined SYSTEM_MALLOC && !defined SYNC_INPUT
3443 bytes_used_when_full
= BYTES_USED
;
3447 /* This used to call error, but if we've run out of memory, we could
3448 get infinite recursion trying to build the string. */
3449 xsignal (Qnil
, Vmemory_signal_data
);
3452 /* If we released our reserve (due to running out of memory),
3453 and we have a fair amount free once again,
3454 try to set aside another reserve in case we run out once more.
3456 This is called when a relocatable block is freed in ralloc.c,
3457 and also directly from this file, in case we're not using ralloc.c. */
3460 refill_memory_reserve (void)
3462 #ifndef SYSTEM_MALLOC
3463 if (spare_memory
[0] == 0)
3464 spare_memory
[0] = (char *) malloc (SPARE_MEMORY
);
3465 if (spare_memory
[1] == 0)
3466 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3468 if (spare_memory
[2] == 0)
3469 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3471 if (spare_memory
[3] == 0)
3472 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3474 if (spare_memory
[4] == 0)
3475 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3477 if (spare_memory
[5] == 0)
3478 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3480 if (spare_memory
[6] == 0)
3481 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3483 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3484 Vmemory_full
= Qnil
;
3488 /************************************************************************
3490 ************************************************************************/
3492 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3494 /* Conservative C stack marking requires a method to identify possibly
3495 live Lisp objects given a pointer value. We do this by keeping
3496 track of blocks of Lisp data that are allocated in a red-black tree
3497 (see also the comment of mem_node which is the type of nodes in
3498 that tree). Function lisp_malloc adds information for an allocated
3499 block to the red-black tree with calls to mem_insert, and function
3500 lisp_free removes it with mem_delete. Functions live_string_p etc
3501 call mem_find to lookup information about a given pointer in the
3502 tree, and use that to determine if the pointer points to a Lisp
3505 /* Initialize this part of alloc.c. */
3510 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3511 mem_z
.parent
= NULL
;
3512 mem_z
.color
= MEM_BLACK
;
3513 mem_z
.start
= mem_z
.end
= NULL
;
3518 /* Value is a pointer to the mem_node containing START. Value is
3519 MEM_NIL if there is no node in the tree containing START. */
3521 static inline struct mem_node
*
3522 mem_find (void *start
)
3526 if (start
< min_heap_address
|| start
> max_heap_address
)
3529 /* Make the search always successful to speed up the loop below. */
3530 mem_z
.start
= start
;
3531 mem_z
.end
= (char *) start
+ 1;
3534 while (start
< p
->start
|| start
>= p
->end
)
3535 p
= start
< p
->start
? p
->left
: p
->right
;
3540 /* Insert a new node into the tree for a block of memory with start
3541 address START, end address END, and type TYPE. Value is a
3542 pointer to the node that was inserted. */
3544 static struct mem_node
*
3545 mem_insert (void *start
, void *end
, enum mem_type type
)
3547 struct mem_node
*c
, *parent
, *x
;
3549 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3550 min_heap_address
= start
;
3551 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3552 max_heap_address
= end
;
3554 /* See where in the tree a node for START belongs. In this
3555 particular application, it shouldn't happen that a node is already
3556 present. For debugging purposes, let's check that. */
3560 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3562 while (c
!= MEM_NIL
)
3564 if (start
>= c
->start
&& start
< c
->end
)
3567 c
= start
< c
->start
? c
->left
: c
->right
;
3570 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3572 while (c
!= MEM_NIL
)
3575 c
= start
< c
->start
? c
->left
: c
->right
;
3578 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3580 /* Create a new node. */
3581 #ifdef GC_MALLOC_CHECK
3582 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3586 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3592 x
->left
= x
->right
= MEM_NIL
;
3595 /* Insert it as child of PARENT or install it as root. */
3598 if (start
< parent
->start
)
3606 /* Re-establish red-black tree properties. */
3607 mem_insert_fixup (x
);
3613 /* Re-establish the red-black properties of the tree, and thereby
3614 balance the tree, after node X has been inserted; X is always red. */
3617 mem_insert_fixup (struct mem_node
*x
)
3619 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3621 /* X is red and its parent is red. This is a violation of
3622 red-black tree property #3. */
3624 if (x
->parent
== x
->parent
->parent
->left
)
3626 /* We're on the left side of our grandparent, and Y is our
3628 struct mem_node
*y
= x
->parent
->parent
->right
;
3630 if (y
->color
== MEM_RED
)
3632 /* Uncle and parent are red but should be black because
3633 X is red. Change the colors accordingly and proceed
3634 with the grandparent. */
3635 x
->parent
->color
= MEM_BLACK
;
3636 y
->color
= MEM_BLACK
;
3637 x
->parent
->parent
->color
= MEM_RED
;
3638 x
= x
->parent
->parent
;
3642 /* Parent and uncle have different colors; parent is
3643 red, uncle is black. */
3644 if (x
== x
->parent
->right
)
3647 mem_rotate_left (x
);
3650 x
->parent
->color
= MEM_BLACK
;
3651 x
->parent
->parent
->color
= MEM_RED
;
3652 mem_rotate_right (x
->parent
->parent
);
3657 /* This is the symmetrical case of above. */
3658 struct mem_node
*y
= x
->parent
->parent
->left
;
3660 if (y
->color
== MEM_RED
)
3662 x
->parent
->color
= MEM_BLACK
;
3663 y
->color
= MEM_BLACK
;
3664 x
->parent
->parent
->color
= MEM_RED
;
3665 x
= x
->parent
->parent
;
3669 if (x
== x
->parent
->left
)
3672 mem_rotate_right (x
);
3675 x
->parent
->color
= MEM_BLACK
;
3676 x
->parent
->parent
->color
= MEM_RED
;
3677 mem_rotate_left (x
->parent
->parent
);
3682 /* The root may have been changed to red due to the algorithm. Set
3683 it to black so that property #5 is satisfied. */
3684 mem_root
->color
= MEM_BLACK
;
3695 mem_rotate_left (struct mem_node
*x
)
3699 /* Turn y's left sub-tree into x's right sub-tree. */
3702 if (y
->left
!= MEM_NIL
)
3703 y
->left
->parent
= x
;
3705 /* Y's parent was x's parent. */
3707 y
->parent
= x
->parent
;
3709 /* Get the parent to point to y instead of x. */
3712 if (x
== x
->parent
->left
)
3713 x
->parent
->left
= y
;
3715 x
->parent
->right
= y
;
3720 /* Put x on y's left. */
3734 mem_rotate_right (struct mem_node
*x
)
3736 struct mem_node
*y
= x
->left
;
3739 if (y
->right
!= MEM_NIL
)
3740 y
->right
->parent
= x
;
3743 y
->parent
= x
->parent
;
3746 if (x
== x
->parent
->right
)
3747 x
->parent
->right
= y
;
3749 x
->parent
->left
= y
;
3760 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3763 mem_delete (struct mem_node
*z
)
3765 struct mem_node
*x
, *y
;
3767 if (!z
|| z
== MEM_NIL
)
3770 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3775 while (y
->left
!= MEM_NIL
)
3779 if (y
->left
!= MEM_NIL
)
3784 x
->parent
= y
->parent
;
3787 if (y
== y
->parent
->left
)
3788 y
->parent
->left
= x
;
3790 y
->parent
->right
= x
;
3797 z
->start
= y
->start
;
3802 if (y
->color
== MEM_BLACK
)
3803 mem_delete_fixup (x
);
3805 #ifdef GC_MALLOC_CHECK
3813 /* Re-establish the red-black properties of the tree, after a
3817 mem_delete_fixup (struct mem_node
*x
)
3819 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3821 if (x
== x
->parent
->left
)
3823 struct mem_node
*w
= x
->parent
->right
;
3825 if (w
->color
== MEM_RED
)
3827 w
->color
= MEM_BLACK
;
3828 x
->parent
->color
= MEM_RED
;
3829 mem_rotate_left (x
->parent
);
3830 w
= x
->parent
->right
;
3833 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3840 if (w
->right
->color
== MEM_BLACK
)
3842 w
->left
->color
= MEM_BLACK
;
3844 mem_rotate_right (w
);
3845 w
= x
->parent
->right
;
3847 w
->color
= x
->parent
->color
;
3848 x
->parent
->color
= MEM_BLACK
;
3849 w
->right
->color
= MEM_BLACK
;
3850 mem_rotate_left (x
->parent
);
3856 struct mem_node
*w
= x
->parent
->left
;
3858 if (w
->color
== MEM_RED
)
3860 w
->color
= MEM_BLACK
;
3861 x
->parent
->color
= MEM_RED
;
3862 mem_rotate_right (x
->parent
);
3863 w
= x
->parent
->left
;
3866 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3873 if (w
->left
->color
== MEM_BLACK
)
3875 w
->right
->color
= MEM_BLACK
;
3877 mem_rotate_left (w
);
3878 w
= x
->parent
->left
;
3881 w
->color
= x
->parent
->color
;
3882 x
->parent
->color
= MEM_BLACK
;
3883 w
->left
->color
= MEM_BLACK
;
3884 mem_rotate_right (x
->parent
);
3890 x
->color
= MEM_BLACK
;
3894 /* Value is non-zero if P is a pointer to a live Lisp string on
3895 the heap. M is a pointer to the mem_block for P. */
3898 live_string_p (struct mem_node
*m
, void *p
)
3900 if (m
->type
== MEM_TYPE_STRING
)
3902 struct string_block
*b
= (struct string_block
*) m
->start
;
3903 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3905 /* P must point to the start of a Lisp_String structure, and it
3906 must not be on the free-list. */
3908 && offset
% sizeof b
->strings
[0] == 0
3909 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3910 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3917 /* Value is non-zero if P is a pointer to a live Lisp cons on
3918 the heap. M is a pointer to the mem_block for P. */
3921 live_cons_p (struct mem_node
*m
, void *p
)
3923 if (m
->type
== MEM_TYPE_CONS
)
3925 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3926 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
3928 /* P must point to the start of a Lisp_Cons, not be
3929 one of the unused cells in the current cons block,
3930 and not be on the free-list. */
3932 && offset
% sizeof b
->conses
[0] == 0
3933 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3935 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3936 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3943 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3944 the heap. M is a pointer to the mem_block for P. */
3947 live_symbol_p (struct mem_node
*m
, void *p
)
3949 if (m
->type
== MEM_TYPE_SYMBOL
)
3951 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3952 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
3954 /* P must point to the start of a Lisp_Symbol, not be
3955 one of the unused cells in the current symbol block,
3956 and not be on the free-list. */
3958 && offset
% sizeof b
->symbols
[0] == 0
3959 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3960 && (b
!= symbol_block
3961 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3962 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3969 /* Value is non-zero if P is a pointer to a live Lisp float on
3970 the heap. M is a pointer to the mem_block for P. */
3973 live_float_p (struct mem_node
*m
, void *p
)
3975 if (m
->type
== MEM_TYPE_FLOAT
)
3977 struct float_block
*b
= (struct float_block
*) m
->start
;
3978 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
3980 /* P must point to the start of a Lisp_Float and not be
3981 one of the unused cells in the current float block. */
3983 && offset
% sizeof b
->floats
[0] == 0
3984 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3985 && (b
!= float_block
3986 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3993 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3994 the heap. M is a pointer to the mem_block for P. */
3997 live_misc_p (struct mem_node
*m
, void *p
)
3999 if (m
->type
== MEM_TYPE_MISC
)
4001 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4002 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
4004 /* P must point to the start of a Lisp_Misc, not be
4005 one of the unused cells in the current misc block,
4006 and not be on the free-list. */
4008 && offset
% sizeof b
->markers
[0] == 0
4009 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4010 && (b
!= marker_block
4011 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4012 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
4019 /* Value is non-zero if P is a pointer to a live vector-like object.
4020 M is a pointer to the mem_block for P. */
4023 live_vector_p (struct mem_node
*m
, void *p
)
4025 return (p
== m
->start
&& m
->type
== MEM_TYPE_VECTORLIKE
);
4029 /* Value is non-zero if P is a pointer to a live buffer. M is a
4030 pointer to the mem_block for P. */
4033 live_buffer_p (struct mem_node
*m
, void *p
)
4035 /* P must point to the start of the block, and the buffer
4036 must not have been killed. */
4037 return (m
->type
== MEM_TYPE_BUFFER
4039 && !NILP (((struct buffer
*) p
)->BUFFER_INTERNAL_FIELD (name
)));
4042 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4046 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4048 /* Array of objects that are kept alive because the C stack contains
4049 a pattern that looks like a reference to them . */
4051 #define MAX_ZOMBIES 10
4052 static Lisp_Object zombies
[MAX_ZOMBIES
];
4054 /* Number of zombie objects. */
4056 static EMACS_INT nzombies
;
4058 /* Number of garbage collections. */
4060 static EMACS_INT ngcs
;
4062 /* Average percentage of zombies per collection. */
4064 static double avg_zombies
;
4066 /* Max. number of live and zombie objects. */
4068 static EMACS_INT max_live
, max_zombies
;
4070 /* Average number of live objects per GC. */
4072 static double avg_live
;
4074 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4075 doc
: /* Show information about live and zombie objects. */)
4078 Lisp_Object args
[8], zombie_list
= Qnil
;
4080 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); i
++)
4081 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4082 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4083 args
[1] = make_number (ngcs
);
4084 args
[2] = make_float (avg_live
);
4085 args
[3] = make_float (avg_zombies
);
4086 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4087 args
[5] = make_number (max_live
);
4088 args
[6] = make_number (max_zombies
);
4089 args
[7] = zombie_list
;
4090 return Fmessage (8, args
);
4093 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4096 /* Mark OBJ if we can prove it's a Lisp_Object. */
4099 mark_maybe_object (Lisp_Object obj
)
4107 po
= (void *) XPNTR (obj
);
4114 switch (XTYPE (obj
))
4117 mark_p
= (live_string_p (m
, po
)
4118 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4122 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4126 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4130 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4133 case Lisp_Vectorlike
:
4134 /* Note: can't check BUFFERP before we know it's a
4135 buffer because checking that dereferences the pointer
4136 PO which might point anywhere. */
4137 if (live_vector_p (m
, po
))
4138 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4139 else if (live_buffer_p (m
, po
))
4140 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4144 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4153 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4154 if (nzombies
< MAX_ZOMBIES
)
4155 zombies
[nzombies
] = obj
;
4164 /* If P points to Lisp data, mark that as live if it isn't already
4168 mark_maybe_pointer (void *p
)
4172 /* Quickly rule out some values which can't point to Lisp data. */
4175 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4177 2 /* We assume that Lisp data is aligned on even addresses. */
4185 Lisp_Object obj
= Qnil
;
4189 case MEM_TYPE_NON_LISP
:
4190 /* Nothing to do; not a pointer to Lisp memory. */
4193 case MEM_TYPE_BUFFER
:
4194 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P ((struct buffer
*)p
))
4195 XSETVECTOR (obj
, p
);
4199 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4203 case MEM_TYPE_STRING
:
4204 if (live_string_p (m
, p
)
4205 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4206 XSETSTRING (obj
, p
);
4210 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4214 case MEM_TYPE_SYMBOL
:
4215 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4216 XSETSYMBOL (obj
, p
);
4219 case MEM_TYPE_FLOAT
:
4220 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4224 case MEM_TYPE_VECTORLIKE
:
4225 if (live_vector_p (m
, p
))
4228 XSETVECTOR (tem
, p
);
4229 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4244 /* Alignment of Lisp_Object and pointer values. Use offsetof, as it
4245 sometimes returns a smaller alignment than GCC's __alignof__ and
4246 mark_memory might miss objects if __alignof__ were used. For
4247 example, on x86 with WIDE_EMACS_INT, __alignof__ (Lisp_Object) is 8
4248 but GC_LISP_OBJECT_ALIGNMENT should be 4. */
4249 #ifndef GC_LISP_OBJECT_ALIGNMENT
4250 # define GC_LISP_OBJECT_ALIGNMENT offsetof (struct {char a; Lisp_Object b;}, b)
4252 #define GC_POINTER_ALIGNMENT offsetof (struct {char a; void *b;}, b)
4254 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4255 or END+OFFSET..START. */
4258 mark_memory (void *start
, void *end
)
4264 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4268 /* Make START the pointer to the start of the memory region,
4269 if it isn't already. */
4277 /* Mark Lisp_Objects. */
4278 for (p
= start
; (void *) p
< end
; p
++)
4279 for (i
= 0; i
< sizeof *p
; i
+= GC_LISP_OBJECT_ALIGNMENT
)
4280 mark_maybe_object (*(Lisp_Object
*) ((char *) p
+ i
));
4282 /* Mark Lisp data pointed to. This is necessary because, in some
4283 situations, the C compiler optimizes Lisp objects away, so that
4284 only a pointer to them remains. Example:
4286 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4289 Lisp_Object obj = build_string ("test");
4290 struct Lisp_String *s = XSTRING (obj);
4291 Fgarbage_collect ();
4292 fprintf (stderr, "test `%s'\n", s->data);
4296 Here, `obj' isn't really used, and the compiler optimizes it
4297 away. The only reference to the life string is through the
4300 for (pp
= start
; (void *) pp
< end
; pp
++)
4301 for (i
= 0; i
< sizeof *pp
; i
+= GC_POINTER_ALIGNMENT
)
4302 mark_maybe_pointer (*(void **) ((char *) pp
+ i
));
4305 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4306 the GCC system configuration. In gcc 3.2, the only systems for
4307 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4308 by others?) and ns32k-pc532-min. */
4310 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4312 static int setjmp_tested_p
, longjmps_done
;
4314 #define SETJMP_WILL_LIKELY_WORK "\
4316 Emacs garbage collector has been changed to use conservative stack\n\
4317 marking. Emacs has determined that the method it uses to do the\n\
4318 marking will likely work on your system, but this isn't sure.\n\
4320 If you are a system-programmer, or can get the help of a local wizard\n\
4321 who is, please take a look at the function mark_stack in alloc.c, and\n\
4322 verify that the methods used are appropriate for your system.\n\
4324 Please mail the result to <emacs-devel@gnu.org>.\n\
4327 #define SETJMP_WILL_NOT_WORK "\
4329 Emacs garbage collector has been changed to use conservative stack\n\
4330 marking. Emacs has determined that the default method it uses to do the\n\
4331 marking will not work on your system. We will need a system-dependent\n\
4332 solution for your system.\n\
4334 Please take a look at the function mark_stack in alloc.c, and\n\
4335 try to find a way to make it work on your system.\n\
4337 Note that you may get false negatives, depending on the compiler.\n\
4338 In particular, you need to use -O with GCC for this test.\n\
4340 Please mail the result to <emacs-devel@gnu.org>.\n\
4344 /* Perform a quick check if it looks like setjmp saves registers in a
4345 jmp_buf. Print a message to stderr saying so. When this test
4346 succeeds, this is _not_ a proof that setjmp is sufficient for
4347 conservative stack marking. Only the sources or a disassembly
4358 /* Arrange for X to be put in a register. */
4364 if (longjmps_done
== 1)
4366 /* Came here after the longjmp at the end of the function.
4368 If x == 1, the longjmp has restored the register to its
4369 value before the setjmp, and we can hope that setjmp
4370 saves all such registers in the jmp_buf, although that
4373 For other values of X, either something really strange is
4374 taking place, or the setjmp just didn't save the register. */
4377 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4380 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4387 if (longjmps_done
== 1)
4391 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4394 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4396 /* Abort if anything GCPRO'd doesn't survive the GC. */
4404 for (p
= gcprolist
; p
; p
= p
->next
)
4405 for (i
= 0; i
< p
->nvars
; ++i
)
4406 if (!survives_gc_p (p
->var
[i
]))
4407 /* FIXME: It's not necessarily a bug. It might just be that the
4408 GCPRO is unnecessary or should release the object sooner. */
4412 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4419 fprintf (stderr
, "\nZombies kept alive = %"pI
"d:\n", nzombies
);
4420 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4422 fprintf (stderr
, " %d = ", i
);
4423 debug_print (zombies
[i
]);
4427 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4430 /* Mark live Lisp objects on the C stack.
4432 There are several system-dependent problems to consider when
4433 porting this to new architectures:
4437 We have to mark Lisp objects in CPU registers that can hold local
4438 variables or are used to pass parameters.
4440 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4441 something that either saves relevant registers on the stack, or
4442 calls mark_maybe_object passing it each register's contents.
4444 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4445 implementation assumes that calling setjmp saves registers we need
4446 to see in a jmp_buf which itself lies on the stack. This doesn't
4447 have to be true! It must be verified for each system, possibly
4448 by taking a look at the source code of setjmp.
4450 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4451 can use it as a machine independent method to store all registers
4452 to the stack. In this case the macros described in the previous
4453 two paragraphs are not used.
4457 Architectures differ in the way their processor stack is organized.
4458 For example, the stack might look like this
4461 | Lisp_Object | size = 4
4463 | something else | size = 2
4465 | Lisp_Object | size = 4
4469 In such a case, not every Lisp_Object will be aligned equally. To
4470 find all Lisp_Object on the stack it won't be sufficient to walk
4471 the stack in steps of 4 bytes. Instead, two passes will be
4472 necessary, one starting at the start of the stack, and a second
4473 pass starting at the start of the stack + 2. Likewise, if the
4474 minimal alignment of Lisp_Objects on the stack is 1, four passes
4475 would be necessary, each one starting with one byte more offset
4476 from the stack start. */
4483 #ifdef HAVE___BUILTIN_UNWIND_INIT
4484 /* Force callee-saved registers and register windows onto the stack.
4485 This is the preferred method if available, obviating the need for
4486 machine dependent methods. */
4487 __builtin_unwind_init ();
4489 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4490 #ifndef GC_SAVE_REGISTERS_ON_STACK
4491 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4492 union aligned_jmpbuf
{
4496 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4498 /* This trick flushes the register windows so that all the state of
4499 the process is contained in the stack. */
4500 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4501 needed on ia64 too. See mach_dep.c, where it also says inline
4502 assembler doesn't work with relevant proprietary compilers. */
4504 #if defined (__sparc64__) && defined (__FreeBSD__)
4505 /* FreeBSD does not have a ta 3 handler. */
4512 /* Save registers that we need to see on the stack. We need to see
4513 registers used to hold register variables and registers used to
4515 #ifdef GC_SAVE_REGISTERS_ON_STACK
4516 GC_SAVE_REGISTERS_ON_STACK (end
);
4517 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4519 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4520 setjmp will definitely work, test it
4521 and print a message with the result
4523 if (!setjmp_tested_p
)
4525 setjmp_tested_p
= 1;
4528 #endif /* GC_SETJMP_WORKS */
4531 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4532 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4533 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4535 /* This assumes that the stack is a contiguous region in memory. If
4536 that's not the case, something has to be done here to iterate
4537 over the stack segments. */
4538 mark_memory (stack_base
, end
);
4540 /* Allow for marking a secondary stack, like the register stack on the
4542 #ifdef GC_MARK_SECONDARY_STACK
4543 GC_MARK_SECONDARY_STACK ();
4546 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4551 #endif /* GC_MARK_STACK != 0 */
4554 /* Determine whether it is safe to access memory at address P. */
4556 valid_pointer_p (void *p
)
4559 return w32_valid_pointer_p (p
, 16);
4563 /* Obviously, we cannot just access it (we would SEGV trying), so we
4564 trick the o/s to tell us whether p is a valid pointer.
4565 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4566 not validate p in that case. */
4570 int valid
= (emacs_write (fd
[1], (char *) p
, 16) == 16);
4571 emacs_close (fd
[1]);
4572 emacs_close (fd
[0]);
4580 /* Return 1 if OBJ is a valid lisp object.
4581 Return 0 if OBJ is NOT a valid lisp object.
4582 Return -1 if we cannot validate OBJ.
4583 This function can be quite slow,
4584 so it should only be used in code for manual debugging. */
4587 valid_lisp_object_p (Lisp_Object obj
)
4597 p
= (void *) XPNTR (obj
);
4598 if (PURE_POINTER_P (p
))
4602 return valid_pointer_p (p
);
4609 int valid
= valid_pointer_p (p
);
4621 case MEM_TYPE_NON_LISP
:
4624 case MEM_TYPE_BUFFER
:
4625 return live_buffer_p (m
, p
);
4628 return live_cons_p (m
, p
);
4630 case MEM_TYPE_STRING
:
4631 return live_string_p (m
, p
);
4634 return live_misc_p (m
, p
);
4636 case MEM_TYPE_SYMBOL
:
4637 return live_symbol_p (m
, p
);
4639 case MEM_TYPE_FLOAT
:
4640 return live_float_p (m
, p
);
4642 case MEM_TYPE_VECTORLIKE
:
4643 return live_vector_p (m
, p
);
4656 /***********************************************************************
4657 Pure Storage Management
4658 ***********************************************************************/
4660 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4661 pointer to it. TYPE is the Lisp type for which the memory is
4662 allocated. TYPE < 0 means it's not used for a Lisp object. */
4664 static POINTER_TYPE
*
4665 pure_alloc (size_t size
, int type
)
4667 POINTER_TYPE
*result
;
4669 size_t alignment
= (1 << GCTYPEBITS
);
4671 size_t alignment
= sizeof (EMACS_INT
);
4673 /* Give Lisp_Floats an extra alignment. */
4674 if (type
== Lisp_Float
)
4676 #if defined __GNUC__ && __GNUC__ >= 2
4677 alignment
= __alignof (struct Lisp_Float
);
4679 alignment
= sizeof (struct Lisp_Float
);
4687 /* Allocate space for a Lisp object from the beginning of the free
4688 space with taking account of alignment. */
4689 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4690 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4694 /* Allocate space for a non-Lisp object from the end of the free
4696 pure_bytes_used_non_lisp
+= size
;
4697 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4699 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4701 if (pure_bytes_used
<= pure_size
)
4704 /* Don't allocate a large amount here,
4705 because it might get mmap'd and then its address
4706 might not be usable. */
4707 purebeg
= (char *) xmalloc (10000);
4709 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4710 pure_bytes_used
= 0;
4711 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4716 /* Print a warning if PURESIZE is too small. */
4719 check_pure_size (void)
4721 if (pure_bytes_used_before_overflow
)
4722 message (("emacs:0:Pure Lisp storage overflow (approx. %"pI
"d"
4724 pure_bytes_used
+ pure_bytes_used_before_overflow
);
4728 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4729 the non-Lisp data pool of the pure storage, and return its start
4730 address. Return NULL if not found. */
4733 find_string_data_in_pure (const char *data
, EMACS_INT nbytes
)
4736 EMACS_INT skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4737 const unsigned char *p
;
4740 if (pure_bytes_used_non_lisp
< nbytes
+ 1)
4743 /* Set up the Boyer-Moore table. */
4745 for (i
= 0; i
< 256; i
++)
4748 p
= (const unsigned char *) data
;
4750 bm_skip
[*p
++] = skip
;
4752 last_char_skip
= bm_skip
['\0'];
4754 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4755 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4757 /* See the comments in the function `boyer_moore' (search.c) for the
4758 use of `infinity'. */
4759 infinity
= pure_bytes_used_non_lisp
+ 1;
4760 bm_skip
['\0'] = infinity
;
4762 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4766 /* Check the last character (== '\0'). */
4769 start
+= bm_skip
[*(p
+ start
)];
4771 while (start
<= start_max
);
4773 if (start
< infinity
)
4774 /* Couldn't find the last character. */
4777 /* No less than `infinity' means we could find the last
4778 character at `p[start - infinity]'. */
4781 /* Check the remaining characters. */
4782 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4784 return non_lisp_beg
+ start
;
4786 start
+= last_char_skip
;
4788 while (start
<= start_max
);
4794 /* Return a string allocated in pure space. DATA is a buffer holding
4795 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4796 non-zero means make the result string multibyte.
4798 Must get an error if pure storage is full, since if it cannot hold
4799 a large string it may be able to hold conses that point to that
4800 string; then the string is not protected from gc. */
4803 make_pure_string (const char *data
,
4804 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
4807 struct Lisp_String
*s
;
4809 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4810 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4811 if (s
->data
== NULL
)
4813 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4814 memcpy (s
->data
, data
, nbytes
);
4815 s
->data
[nbytes
] = '\0';
4818 s
->size_byte
= multibyte
? nbytes
: -1;
4819 s
->intervals
= NULL_INTERVAL
;
4820 XSETSTRING (string
, s
);
4824 /* Return a string a string allocated in pure space. Do not allocate
4825 the string data, just point to DATA. */
4828 make_pure_c_string (const char *data
)
4831 struct Lisp_String
*s
;
4832 EMACS_INT nchars
= strlen (data
);
4834 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4837 s
->data
= (unsigned char *) data
;
4838 s
->intervals
= NULL_INTERVAL
;
4839 XSETSTRING (string
, s
);
4843 /* Return a cons allocated from pure space. Give it pure copies
4844 of CAR as car and CDR as cdr. */
4847 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4849 register Lisp_Object
new;
4850 struct Lisp_Cons
*p
;
4852 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4854 XSETCAR (new, Fpurecopy (car
));
4855 XSETCDR (new, Fpurecopy (cdr
));
4860 /* Value is a float object with value NUM allocated from pure space. */
4863 make_pure_float (double num
)
4865 register Lisp_Object
new;
4866 struct Lisp_Float
*p
;
4868 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4870 XFLOAT_INIT (new, num
);
4875 /* Return a vector with room for LEN Lisp_Objects allocated from
4879 make_pure_vector (EMACS_INT len
)
4882 struct Lisp_Vector
*p
;
4883 size_t size
= (offsetof (struct Lisp_Vector
, contents
)
4884 + len
* sizeof (Lisp_Object
));
4886 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4887 XSETVECTOR (new, p
);
4888 XVECTOR (new)->header
.size
= len
;
4893 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4894 doc
: /* Make a copy of object OBJ in pure storage.
4895 Recursively copies contents of vectors and cons cells.
4896 Does not copy symbols. Copies strings without text properties. */)
4897 (register Lisp_Object obj
)
4899 if (NILP (Vpurify_flag
))
4902 if (PURE_POINTER_P (XPNTR (obj
)))
4905 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4907 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
4913 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
4914 else if (FLOATP (obj
))
4915 obj
= make_pure_float (XFLOAT_DATA (obj
));
4916 else if (STRINGP (obj
))
4917 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
4919 STRING_MULTIBYTE (obj
));
4920 else if (COMPILEDP (obj
) || VECTORP (obj
))
4922 register struct Lisp_Vector
*vec
;
4923 register EMACS_INT i
;
4927 if (size
& PSEUDOVECTOR_FLAG
)
4928 size
&= PSEUDOVECTOR_SIZE_MASK
;
4929 vec
= XVECTOR (make_pure_vector (size
));
4930 for (i
= 0; i
< size
; i
++)
4931 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4932 if (COMPILEDP (obj
))
4934 XSETPVECTYPE (vec
, PVEC_COMPILED
);
4935 XSETCOMPILED (obj
, vec
);
4938 XSETVECTOR (obj
, vec
);
4940 else if (MARKERP (obj
))
4941 error ("Attempt to copy a marker to pure storage");
4943 /* Not purified, don't hash-cons. */
4946 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4947 Fputhash (obj
, obj
, Vpurify_flag
);
4954 /***********************************************************************
4956 ***********************************************************************/
4958 /* Put an entry in staticvec, pointing at the variable with address
4962 staticpro (Lisp_Object
*varaddress
)
4964 staticvec
[staticidx
++] = varaddress
;
4965 if (staticidx
>= NSTATICS
)
4970 /***********************************************************************
4972 ***********************************************************************/
4974 /* Temporarily prevent garbage collection. */
4977 inhibit_garbage_collection (void)
4979 int count
= SPECPDL_INDEX ();
4981 specbind (Qgc_cons_threshold
, make_number (MOST_POSITIVE_FIXNUM
));
4986 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4987 doc
: /* Reclaim storage for Lisp objects no longer needed.
4988 Garbage collection happens automatically if you cons more than
4989 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4990 `garbage-collect' normally returns a list with info on amount of space in use:
4991 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4992 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4993 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4994 (USED-STRINGS . FREE-STRINGS))
4995 However, if there was overflow in pure space, `garbage-collect'
4996 returns nil, because real GC can't be done. */)
4999 register struct specbinding
*bind
;
5000 char stack_top_variable
;
5003 Lisp_Object total
[8];
5004 int count
= SPECPDL_INDEX ();
5005 EMACS_TIME t1
, t2
, t3
;
5010 /* Can't GC if pure storage overflowed because we can't determine
5011 if something is a pure object or not. */
5012 if (pure_bytes_used_before_overflow
)
5017 /* Don't keep undo information around forever.
5018 Do this early on, so it is no problem if the user quits. */
5020 register struct buffer
*nextb
= all_buffers
;
5024 /* If a buffer's undo list is Qt, that means that undo is
5025 turned off in that buffer. Calling truncate_undo_list on
5026 Qt tends to return NULL, which effectively turns undo back on.
5027 So don't call truncate_undo_list if undo_list is Qt. */
5028 if (! NILP (nextb
->BUFFER_INTERNAL_FIELD (name
)) && ! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5029 truncate_undo_list (nextb
);
5031 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5032 if (nextb
->base_buffer
== 0 && !NILP (nextb
->BUFFER_INTERNAL_FIELD (name
))
5033 && ! nextb
->text
->inhibit_shrinking
)
5035 /* If a buffer's gap size is more than 10% of the buffer
5036 size, or larger than 2000 bytes, then shrink it
5037 accordingly. Keep a minimum size of 20 bytes. */
5038 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
5040 if (nextb
->text
->gap_size
> size
)
5042 struct buffer
*save_current
= current_buffer
;
5043 current_buffer
= nextb
;
5044 make_gap (-(nextb
->text
->gap_size
- size
));
5045 current_buffer
= save_current
;
5049 nextb
= nextb
->header
.next
.buffer
;
5053 EMACS_GET_TIME (t1
);
5055 /* In case user calls debug_print during GC,
5056 don't let that cause a recursive GC. */
5057 consing_since_gc
= 0;
5059 /* Save what's currently displayed in the echo area. */
5060 message_p
= push_message ();
5061 record_unwind_protect (pop_message_unwind
, Qnil
);
5063 /* Save a copy of the contents of the stack, for debugging. */
5064 #if MAX_SAVE_STACK > 0
5065 if (NILP (Vpurify_flag
))
5068 ptrdiff_t stack_size
;
5069 if (&stack_top_variable
< stack_bottom
)
5071 stack
= &stack_top_variable
;
5072 stack_size
= stack_bottom
- &stack_top_variable
;
5076 stack
= stack_bottom
;
5077 stack_size
= &stack_top_variable
- stack_bottom
;
5079 if (stack_size
<= MAX_SAVE_STACK
)
5081 if (stack_copy_size
< stack_size
)
5083 stack_copy
= (char *) xrealloc (stack_copy
, stack_size
);
5084 stack_copy_size
= stack_size
;
5086 memcpy (stack_copy
, stack
, stack_size
);
5089 #endif /* MAX_SAVE_STACK > 0 */
5091 if (garbage_collection_messages
)
5092 message1_nolog ("Garbage collecting...");
5096 shrink_regexp_cache ();
5100 /* clear_marks (); */
5102 /* Mark all the special slots that serve as the roots of accessibility. */
5104 for (i
= 0; i
< staticidx
; i
++)
5105 mark_object (*staticvec
[i
]);
5107 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5109 mark_object (bind
->symbol
);
5110 mark_object (bind
->old_value
);
5118 extern void xg_mark_data (void);
5123 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5124 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5128 register struct gcpro
*tail
;
5129 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5130 for (i
= 0; i
< tail
->nvars
; i
++)
5131 mark_object (tail
->var
[i
]);
5135 struct catchtag
*catch;
5136 struct handler
*handler
;
5138 for (catch = catchlist
; catch; catch = catch->next
)
5140 mark_object (catch->tag
);
5141 mark_object (catch->val
);
5143 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5145 mark_object (handler
->handler
);
5146 mark_object (handler
->var
);
5152 #ifdef HAVE_WINDOW_SYSTEM
5153 mark_fringe_data ();
5156 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5160 /* Everything is now marked, except for the things that require special
5161 finalization, i.e. the undo_list.
5162 Look thru every buffer's undo list
5163 for elements that update markers that were not marked,
5166 register struct buffer
*nextb
= all_buffers
;
5170 /* If a buffer's undo list is Qt, that means that undo is
5171 turned off in that buffer. Calling truncate_undo_list on
5172 Qt tends to return NULL, which effectively turns undo back on.
5173 So don't call truncate_undo_list if undo_list is Qt. */
5174 if (! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5176 Lisp_Object tail
, prev
;
5177 tail
= nextb
->BUFFER_INTERNAL_FIELD (undo_list
);
5179 while (CONSP (tail
))
5181 if (CONSP (XCAR (tail
))
5182 && MARKERP (XCAR (XCAR (tail
)))
5183 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5186 nextb
->BUFFER_INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5190 XSETCDR (prev
, tail
);
5200 /* Now that we have stripped the elements that need not be in the
5201 undo_list any more, we can finally mark the list. */
5202 mark_object (nextb
->BUFFER_INTERNAL_FIELD (undo_list
));
5204 nextb
= nextb
->header
.next
.buffer
;
5210 /* Clear the mark bits that we set in certain root slots. */
5212 unmark_byte_stack ();
5213 VECTOR_UNMARK (&buffer_defaults
);
5214 VECTOR_UNMARK (&buffer_local_symbols
);
5216 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5224 /* clear_marks (); */
5227 consing_since_gc
= 0;
5228 if (gc_cons_threshold
< 10000)
5229 gc_cons_threshold
= 10000;
5231 gc_relative_threshold
= 0;
5232 if (FLOATP (Vgc_cons_percentage
))
5233 { /* Set gc_cons_combined_threshold. */
5236 tot
+= total_conses
* sizeof (struct Lisp_Cons
);
5237 tot
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5238 tot
+= total_markers
* sizeof (union Lisp_Misc
);
5239 tot
+= total_string_size
;
5240 tot
+= total_vector_size
* sizeof (Lisp_Object
);
5241 tot
+= total_floats
* sizeof (struct Lisp_Float
);
5242 tot
+= total_intervals
* sizeof (struct interval
);
5243 tot
+= total_strings
* sizeof (struct Lisp_String
);
5245 tot
*= XFLOAT_DATA (Vgc_cons_percentage
);
5248 if (tot
< TYPE_MAXIMUM (EMACS_INT
))
5249 gc_relative_threshold
= tot
;
5251 gc_relative_threshold
= TYPE_MAXIMUM (EMACS_INT
);
5255 if (garbage_collection_messages
)
5257 if (message_p
|| minibuf_level
> 0)
5260 message1_nolog ("Garbage collecting...done");
5263 unbind_to (count
, Qnil
);
5265 total
[0] = Fcons (make_number (total_conses
),
5266 make_number (total_free_conses
));
5267 total
[1] = Fcons (make_number (total_symbols
),
5268 make_number (total_free_symbols
));
5269 total
[2] = Fcons (make_number (total_markers
),
5270 make_number (total_free_markers
));
5271 total
[3] = make_number (total_string_size
);
5272 total
[4] = make_number (total_vector_size
);
5273 total
[5] = Fcons (make_number (total_floats
),
5274 make_number (total_free_floats
));
5275 total
[6] = Fcons (make_number (total_intervals
),
5276 make_number (total_free_intervals
));
5277 total
[7] = Fcons (make_number (total_strings
),
5278 make_number (total_free_strings
));
5280 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5282 /* Compute average percentage of zombies. */
5285 for (i
= 0; i
< 7; ++i
)
5286 if (CONSP (total
[i
]))
5287 nlive
+= XFASTINT (XCAR (total
[i
]));
5289 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5290 max_live
= max (nlive
, max_live
);
5291 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5292 max_zombies
= max (nzombies
, max_zombies
);
5297 if (!NILP (Vpost_gc_hook
))
5299 int gc_count
= inhibit_garbage_collection ();
5300 safe_run_hooks (Qpost_gc_hook
);
5301 unbind_to (gc_count
, Qnil
);
5304 /* Accumulate statistics. */
5305 EMACS_GET_TIME (t2
);
5306 EMACS_SUB_TIME (t3
, t2
, t1
);
5307 if (FLOATP (Vgc_elapsed
))
5308 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5310 EMACS_USECS (t3
) * 1.0e-6);
5313 return Flist (sizeof total
/ sizeof *total
, total
);
5317 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5318 only interesting objects referenced from glyphs are strings. */
5321 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5323 struct glyph_row
*row
= matrix
->rows
;
5324 struct glyph_row
*end
= row
+ matrix
->nrows
;
5326 for (; row
< end
; ++row
)
5330 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5332 struct glyph
*glyph
= row
->glyphs
[area
];
5333 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5335 for (; glyph
< end_glyph
; ++glyph
)
5336 if (STRINGP (glyph
->object
)
5337 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5338 mark_object (glyph
->object
);
5344 /* Mark Lisp faces in the face cache C. */
5347 mark_face_cache (struct face_cache
*c
)
5352 for (i
= 0; i
< c
->used
; ++i
)
5354 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5358 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5359 mark_object (face
->lface
[j
]);
5367 /* Mark reference to a Lisp_Object.
5368 If the object referred to has not been seen yet, recursively mark
5369 all the references contained in it. */
5371 #define LAST_MARKED_SIZE 500
5372 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5373 static int last_marked_index
;
5375 /* For debugging--call abort when we cdr down this many
5376 links of a list, in mark_object. In debugging,
5377 the call to abort will hit a breakpoint.
5378 Normally this is zero and the check never goes off. */
5379 ptrdiff_t mark_object_loop_halt EXTERNALLY_VISIBLE
;
5382 mark_vectorlike (struct Lisp_Vector
*ptr
)
5384 EMACS_INT size
= ptr
->header
.size
;
5387 eassert (!VECTOR_MARKED_P (ptr
));
5388 VECTOR_MARK (ptr
); /* Else mark it */
5389 if (size
& PSEUDOVECTOR_FLAG
)
5390 size
&= PSEUDOVECTOR_SIZE_MASK
;
5392 /* Note that this size is not the memory-footprint size, but only
5393 the number of Lisp_Object fields that we should trace.
5394 The distinction is used e.g. by Lisp_Process which places extra
5395 non-Lisp_Object fields at the end of the structure. */
5396 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5397 mark_object (ptr
->contents
[i
]);
5400 /* Like mark_vectorlike but optimized for char-tables (and
5401 sub-char-tables) assuming that the contents are mostly integers or
5405 mark_char_table (struct Lisp_Vector
*ptr
)
5407 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5410 eassert (!VECTOR_MARKED_P (ptr
));
5412 for (i
= 0; i
< size
; i
++)
5414 Lisp_Object val
= ptr
->contents
[i
];
5416 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5418 if (SUB_CHAR_TABLE_P (val
))
5420 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5421 mark_char_table (XVECTOR (val
));
5429 mark_object (Lisp_Object arg
)
5431 register Lisp_Object obj
= arg
;
5432 #ifdef GC_CHECK_MARKED_OBJECTS
5436 ptrdiff_t cdr_count
= 0;
5440 if (PURE_POINTER_P (XPNTR (obj
)))
5443 last_marked
[last_marked_index
++] = obj
;
5444 if (last_marked_index
== LAST_MARKED_SIZE
)
5445 last_marked_index
= 0;
5447 /* Perform some sanity checks on the objects marked here. Abort if
5448 we encounter an object we know is bogus. This increases GC time
5449 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5450 #ifdef GC_CHECK_MARKED_OBJECTS
5452 po
= (void *) XPNTR (obj
);
5454 /* Check that the object pointed to by PO is known to be a Lisp
5455 structure allocated from the heap. */
5456 #define CHECK_ALLOCATED() \
5458 m = mem_find (po); \
5463 /* Check that the object pointed to by PO is live, using predicate
5465 #define CHECK_LIVE(LIVEP) \
5467 if (!LIVEP (m, po)) \
5471 /* Check both of the above conditions. */
5472 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5474 CHECK_ALLOCATED (); \
5475 CHECK_LIVE (LIVEP); \
5478 #else /* not GC_CHECK_MARKED_OBJECTS */
5480 #define CHECK_LIVE(LIVEP) (void) 0
5481 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5483 #endif /* not GC_CHECK_MARKED_OBJECTS */
5485 switch (SWITCH_ENUM_CAST (XTYPE (obj
)))
5489 register struct Lisp_String
*ptr
= XSTRING (obj
);
5490 if (STRING_MARKED_P (ptr
))
5492 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5493 MARK_INTERVAL_TREE (ptr
->intervals
);
5495 #ifdef GC_CHECK_STRING_BYTES
5496 /* Check that the string size recorded in the string is the
5497 same as the one recorded in the sdata structure. */
5498 CHECK_STRING_BYTES (ptr
);
5499 #endif /* GC_CHECK_STRING_BYTES */
5503 case Lisp_Vectorlike
:
5504 if (VECTOR_MARKED_P (XVECTOR (obj
)))
5506 #ifdef GC_CHECK_MARKED_OBJECTS
5508 if (m
== MEM_NIL
&& !SUBRP (obj
)
5509 && po
!= &buffer_defaults
5510 && po
!= &buffer_local_symbols
)
5512 #endif /* GC_CHECK_MARKED_OBJECTS */
5516 #ifdef GC_CHECK_MARKED_OBJECTS
5517 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5520 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->header
.next
.buffer
)
5525 #endif /* GC_CHECK_MARKED_OBJECTS */
5528 else if (SUBRP (obj
))
5530 else if (COMPILEDP (obj
))
5531 /* We could treat this just like a vector, but it is better to
5532 save the COMPILED_CONSTANTS element for last and avoid
5535 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5536 int size
= ptr
->header
.size
& PSEUDOVECTOR_SIZE_MASK
;
5539 CHECK_LIVE (live_vector_p
);
5540 VECTOR_MARK (ptr
); /* Else mark it */
5541 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5543 if (i
!= COMPILED_CONSTANTS
)
5544 mark_object (ptr
->contents
[i
]);
5546 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5549 else if (FRAMEP (obj
))
5551 register struct frame
*ptr
= XFRAME (obj
);
5552 mark_vectorlike (XVECTOR (obj
));
5553 mark_face_cache (ptr
->face_cache
);
5555 else if (WINDOWP (obj
))
5557 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5558 struct window
*w
= XWINDOW (obj
);
5559 mark_vectorlike (ptr
);
5560 /* Mark glyphs for leaf windows. Marking window matrices is
5561 sufficient because frame matrices use the same glyph
5563 if (NILP (w
->hchild
)
5565 && w
->current_matrix
)
5567 mark_glyph_matrix (w
->current_matrix
);
5568 mark_glyph_matrix (w
->desired_matrix
);
5571 else if (HASH_TABLE_P (obj
))
5573 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5574 mark_vectorlike ((struct Lisp_Vector
*)h
);
5575 /* If hash table is not weak, mark all keys and values.
5576 For weak tables, mark only the vector. */
5578 mark_object (h
->key_and_value
);
5580 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5582 else if (CHAR_TABLE_P (obj
))
5583 mark_char_table (XVECTOR (obj
));
5585 mark_vectorlike (XVECTOR (obj
));
5590 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5591 struct Lisp_Symbol
*ptrx
;
5595 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5597 mark_object (ptr
->function
);
5598 mark_object (ptr
->plist
);
5599 switch (ptr
->redirect
)
5601 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5602 case SYMBOL_VARALIAS
:
5605 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5609 case SYMBOL_LOCALIZED
:
5611 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5612 /* If the value is forwarded to a buffer or keyboard field,
5613 these are marked when we see the corresponding object.
5614 And if it's forwarded to a C variable, either it's not
5615 a Lisp_Object var, or it's staticpro'd already. */
5616 mark_object (blv
->where
);
5617 mark_object (blv
->valcell
);
5618 mark_object (blv
->defcell
);
5621 case SYMBOL_FORWARDED
:
5622 /* If the value is forwarded to a buffer or keyboard field,
5623 these are marked when we see the corresponding object.
5624 And if it's forwarded to a C variable, either it's not
5625 a Lisp_Object var, or it's staticpro'd already. */
5629 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5630 MARK_STRING (XSTRING (ptr
->xname
));
5631 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5636 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5637 XSETSYMBOL (obj
, ptrx
);
5644 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5645 if (XMISCANY (obj
)->gcmarkbit
)
5647 XMISCANY (obj
)->gcmarkbit
= 1;
5649 switch (XMISCTYPE (obj
))
5652 case Lisp_Misc_Marker
:
5653 /* DO NOT mark thru the marker's chain.
5654 The buffer's markers chain does not preserve markers from gc;
5655 instead, markers are removed from the chain when freed by gc. */
5658 case Lisp_Misc_Save_Value
:
5661 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5662 /* If DOGC is set, POINTER is the address of a memory
5663 area containing INTEGER potential Lisp_Objects. */
5666 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5668 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5669 mark_maybe_object (*p
);
5675 case Lisp_Misc_Overlay
:
5677 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5678 mark_object (ptr
->start
);
5679 mark_object (ptr
->end
);
5680 mark_object (ptr
->plist
);
5683 XSETMISC (obj
, ptr
->next
);
5696 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5697 if (CONS_MARKED_P (ptr
))
5699 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5701 /* If the cdr is nil, avoid recursion for the car. */
5702 if (EQ (ptr
->u
.cdr
, Qnil
))
5708 mark_object (ptr
->car
);
5711 if (cdr_count
== mark_object_loop_halt
)
5717 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5718 FLOAT_MARK (XFLOAT (obj
));
5729 #undef CHECK_ALLOCATED
5730 #undef CHECK_ALLOCATED_AND_LIVE
5733 /* Mark the pointers in a buffer structure. */
5736 mark_buffer (Lisp_Object buf
)
5738 register struct buffer
*buffer
= XBUFFER (buf
);
5739 register Lisp_Object
*ptr
, tmp
;
5740 Lisp_Object base_buffer
;
5742 eassert (!VECTOR_MARKED_P (buffer
));
5743 VECTOR_MARK (buffer
);
5745 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5747 /* For now, we just don't mark the undo_list. It's done later in
5748 a special way just before the sweep phase, and after stripping
5749 some of its elements that are not needed any more. */
5751 if (buffer
->overlays_before
)
5753 XSETMISC (tmp
, buffer
->overlays_before
);
5756 if (buffer
->overlays_after
)
5758 XSETMISC (tmp
, buffer
->overlays_after
);
5762 /* buffer-local Lisp variables start at `undo_list',
5763 tho only the ones from `name' on are GC'd normally. */
5764 for (ptr
= &buffer
->BUFFER_INTERNAL_FIELD (name
);
5765 ptr
<= &PER_BUFFER_VALUE (buffer
,
5766 PER_BUFFER_VAR_OFFSET (LAST_FIELD_PER_BUFFER
));
5770 /* If this is an indirect buffer, mark its base buffer. */
5771 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5773 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5774 mark_buffer (base_buffer
);
5778 /* Mark the Lisp pointers in the terminal objects.
5779 Called by the Fgarbage_collector. */
5782 mark_terminals (void)
5785 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5787 eassert (t
->name
!= NULL
);
5788 #ifdef HAVE_WINDOW_SYSTEM
5789 /* If a terminal object is reachable from a stacpro'ed object,
5790 it might have been marked already. Make sure the image cache
5792 mark_image_cache (t
->image_cache
);
5793 #endif /* HAVE_WINDOW_SYSTEM */
5794 if (!VECTOR_MARKED_P (t
))
5795 mark_vectorlike ((struct Lisp_Vector
*)t
);
5801 /* Value is non-zero if OBJ will survive the current GC because it's
5802 either marked or does not need to be marked to survive. */
5805 survives_gc_p (Lisp_Object obj
)
5809 switch (XTYPE (obj
))
5816 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5820 survives_p
= XMISCANY (obj
)->gcmarkbit
;
5824 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5827 case Lisp_Vectorlike
:
5828 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5832 survives_p
= CONS_MARKED_P (XCONS (obj
));
5836 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5843 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5848 /* Sweep: find all structures not marked, and free them. */
5853 /* Remove or mark entries in weak hash tables.
5854 This must be done before any object is unmarked. */
5855 sweep_weak_hash_tables ();
5858 #ifdef GC_CHECK_STRING_BYTES
5859 if (!noninteractive
)
5860 check_string_bytes (1);
5863 /* Put all unmarked conses on free list */
5865 register struct cons_block
*cblk
;
5866 struct cons_block
**cprev
= &cons_block
;
5867 register int lim
= cons_block_index
;
5868 EMACS_INT num_free
= 0, num_used
= 0;
5872 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5876 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
5878 /* Scan the mark bits an int at a time. */
5879 for (i
= 0; i
< ilim
; i
++)
5881 if (cblk
->gcmarkbits
[i
] == -1)
5883 /* Fast path - all cons cells for this int are marked. */
5884 cblk
->gcmarkbits
[i
] = 0;
5885 num_used
+= BITS_PER_INT
;
5889 /* Some cons cells for this int are not marked.
5890 Find which ones, and free them. */
5891 int start
, pos
, stop
;
5893 start
= i
* BITS_PER_INT
;
5895 if (stop
> BITS_PER_INT
)
5896 stop
= BITS_PER_INT
;
5899 for (pos
= start
; pos
< stop
; pos
++)
5901 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
5904 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
5905 cons_free_list
= &cblk
->conses
[pos
];
5907 cons_free_list
->car
= Vdead
;
5913 CONS_UNMARK (&cblk
->conses
[pos
]);
5919 lim
= CONS_BLOCK_SIZE
;
5920 /* If this block contains only free conses and we have already
5921 seen more than two blocks worth of free conses then deallocate
5923 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5925 *cprev
= cblk
->next
;
5926 /* Unhook from the free list. */
5927 cons_free_list
= cblk
->conses
[0].u
.chain
;
5928 lisp_align_free (cblk
);
5932 num_free
+= this_free
;
5933 cprev
= &cblk
->next
;
5936 total_conses
= num_used
;
5937 total_free_conses
= num_free
;
5940 /* Put all unmarked floats on free list */
5942 register struct float_block
*fblk
;
5943 struct float_block
**fprev
= &float_block
;
5944 register int lim
= float_block_index
;
5945 EMACS_INT num_free
= 0, num_used
= 0;
5947 float_free_list
= 0;
5949 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5953 for (i
= 0; i
< lim
; i
++)
5954 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5957 fblk
->floats
[i
].u
.chain
= float_free_list
;
5958 float_free_list
= &fblk
->floats
[i
];
5963 FLOAT_UNMARK (&fblk
->floats
[i
]);
5965 lim
= FLOAT_BLOCK_SIZE
;
5966 /* If this block contains only free floats and we have already
5967 seen more than two blocks worth of free floats then deallocate
5969 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5971 *fprev
= fblk
->next
;
5972 /* Unhook from the free list. */
5973 float_free_list
= fblk
->floats
[0].u
.chain
;
5974 lisp_align_free (fblk
);
5978 num_free
+= this_free
;
5979 fprev
= &fblk
->next
;
5982 total_floats
= num_used
;
5983 total_free_floats
= num_free
;
5986 /* Put all unmarked intervals on free list */
5988 register struct interval_block
*iblk
;
5989 struct interval_block
**iprev
= &interval_block
;
5990 register int lim
= interval_block_index
;
5991 EMACS_INT num_free
= 0, num_used
= 0;
5993 interval_free_list
= 0;
5995 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6000 for (i
= 0; i
< lim
; i
++)
6002 if (!iblk
->intervals
[i
].gcmarkbit
)
6004 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
6005 interval_free_list
= &iblk
->intervals
[i
];
6011 iblk
->intervals
[i
].gcmarkbit
= 0;
6014 lim
= INTERVAL_BLOCK_SIZE
;
6015 /* If this block contains only free intervals and we have already
6016 seen more than two blocks worth of free intervals then
6017 deallocate this block. */
6018 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6020 *iprev
= iblk
->next
;
6021 /* Unhook from the free list. */
6022 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6027 num_free
+= this_free
;
6028 iprev
= &iblk
->next
;
6031 total_intervals
= num_used
;
6032 total_free_intervals
= num_free
;
6035 /* Put all unmarked symbols on free list */
6037 register struct symbol_block
*sblk
;
6038 struct symbol_block
**sprev
= &symbol_block
;
6039 register int lim
= symbol_block_index
;
6040 EMACS_INT num_free
= 0, num_used
= 0;
6042 symbol_free_list
= NULL
;
6044 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6047 struct Lisp_Symbol
*sym
= sblk
->symbols
;
6048 struct Lisp_Symbol
*end
= sym
+ lim
;
6050 for (; sym
< end
; ++sym
)
6052 /* Check if the symbol was created during loadup. In such a case
6053 it might be pointed to by pure bytecode which we don't trace,
6054 so we conservatively assume that it is live. */
6055 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
6057 if (!sym
->gcmarkbit
&& !pure_p
)
6059 if (sym
->redirect
== SYMBOL_LOCALIZED
)
6060 xfree (SYMBOL_BLV (sym
));
6061 sym
->next
= symbol_free_list
;
6062 symbol_free_list
= sym
;
6064 symbol_free_list
->function
= Vdead
;
6072 UNMARK_STRING (XSTRING (sym
->xname
));
6077 lim
= SYMBOL_BLOCK_SIZE
;
6078 /* If this block contains only free symbols and we have already
6079 seen more than two blocks worth of free symbols then deallocate
6081 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6083 *sprev
= sblk
->next
;
6084 /* Unhook from the free list. */
6085 symbol_free_list
= sblk
->symbols
[0].next
;
6090 num_free
+= this_free
;
6091 sprev
= &sblk
->next
;
6094 total_symbols
= num_used
;
6095 total_free_symbols
= num_free
;
6098 /* Put all unmarked misc's on free list.
6099 For a marker, first unchain it from the buffer it points into. */
6101 register struct marker_block
*mblk
;
6102 struct marker_block
**mprev
= &marker_block
;
6103 register int lim
= marker_block_index
;
6104 EMACS_INT num_free
= 0, num_used
= 0;
6106 marker_free_list
= 0;
6108 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6113 for (i
= 0; i
< lim
; i
++)
6115 if (!mblk
->markers
[i
].u_any
.gcmarkbit
)
6117 if (mblk
->markers
[i
].u_any
.type
== Lisp_Misc_Marker
)
6118 unchain_marker (&mblk
->markers
[i
].u_marker
);
6119 /* Set the type of the freed object to Lisp_Misc_Free.
6120 We could leave the type alone, since nobody checks it,
6121 but this might catch bugs faster. */
6122 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
6123 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
6124 marker_free_list
= &mblk
->markers
[i
];
6130 mblk
->markers
[i
].u_any
.gcmarkbit
= 0;
6133 lim
= MARKER_BLOCK_SIZE
;
6134 /* If this block contains only free markers and we have already
6135 seen more than two blocks worth of free markers then deallocate
6137 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6139 *mprev
= mblk
->next
;
6140 /* Unhook from the free list. */
6141 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
6146 num_free
+= this_free
;
6147 mprev
= &mblk
->next
;
6151 total_markers
= num_used
;
6152 total_free_markers
= num_free
;
6155 /* Free all unmarked buffers */
6157 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6160 if (!VECTOR_MARKED_P (buffer
))
6163 prev
->header
.next
= buffer
->header
.next
;
6165 all_buffers
= buffer
->header
.next
.buffer
;
6166 next
= buffer
->header
.next
.buffer
;
6172 VECTOR_UNMARK (buffer
);
6173 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6174 prev
= buffer
, buffer
= buffer
->header
.next
.buffer
;
6178 /* Free all unmarked vectors */
6180 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6181 total_vector_size
= 0;
6184 if (!VECTOR_MARKED_P (vector
))
6187 prev
->header
.next
= vector
->header
.next
;
6189 all_vectors
= vector
->header
.next
.vector
;
6190 next
= vector
->header
.next
.vector
;
6197 VECTOR_UNMARK (vector
);
6198 if (vector
->header
.size
& PSEUDOVECTOR_FLAG
)
6199 total_vector_size
+= PSEUDOVECTOR_SIZE_MASK
& vector
->header
.size
;
6201 total_vector_size
+= vector
->header
.size
;
6202 prev
= vector
, vector
= vector
->header
.next
.vector
;
6206 #ifdef GC_CHECK_STRING_BYTES
6207 if (!noninteractive
)
6208 check_string_bytes (1);
6215 /* Debugging aids. */
6217 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6218 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6219 This may be helpful in debugging Emacs's memory usage.
6220 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6225 XSETINT (end
, (intptr_t) (char *) sbrk (0) / 1024);
6230 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6231 doc
: /* Return a list of counters that measure how much consing there has been.
6232 Each of these counters increments for a certain kind of object.
6233 The counters wrap around from the largest positive integer to zero.
6234 Garbage collection does not decrease them.
6235 The elements of the value are as follows:
6236 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6237 All are in units of 1 = one object consed
6238 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6240 MISCS include overlays, markers, and some internal types.
6241 Frames, windows, buffers, and subprocesses count as vectors
6242 (but the contents of a buffer's text do not count here). */)
6245 Lisp_Object consed
[8];
6247 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6248 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6249 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6250 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6251 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6252 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6253 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6254 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6256 return Flist (8, consed
);
6259 /* Find at most FIND_MAX symbols which have OBJ as their value or
6260 function. This is used in gdbinit's `xwhichsymbols' command. */
6263 which_symbols (Lisp_Object obj
, EMACS_INT find_max
)
6265 struct symbol_block
*sblk
;
6266 int gc_count
= inhibit_garbage_collection ();
6267 Lisp_Object found
= Qnil
;
6271 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
6273 struct Lisp_Symbol
*sym
= sblk
->symbols
;
6276 for (bn
= 0; bn
< SYMBOL_BLOCK_SIZE
; bn
++, sym
++)
6281 if (sblk
== symbol_block
&& bn
>= symbol_block_index
)
6284 XSETSYMBOL (tem
, sym
);
6285 val
= find_symbol_value (tem
);
6287 || EQ (sym
->function
, obj
)
6288 || (!NILP (sym
->function
)
6289 && COMPILEDP (sym
->function
)
6290 && EQ (AREF (sym
->function
, COMPILED_BYTECODE
), obj
))
6293 && EQ (AREF (val
, COMPILED_BYTECODE
), obj
)))
6295 found
= Fcons (tem
, found
);
6296 if (--find_max
== 0)
6304 unbind_to (gc_count
, Qnil
);
6308 #ifdef ENABLE_CHECKING
6309 int suppress_checking
;
6312 die (const char *msg
, const char *file
, int line
)
6314 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6320 /* Initialization */
6323 init_alloc_once (void)
6325 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6327 pure_size
= PURESIZE
;
6328 pure_bytes_used
= 0;
6329 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6330 pure_bytes_used_before_overflow
= 0;
6332 /* Initialize the list of free aligned blocks. */
6335 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6337 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6341 ignore_warnings
= 1;
6342 #ifdef DOUG_LEA_MALLOC
6343 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6344 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6345 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6353 init_weak_hash_tables ();
6356 malloc_hysteresis
= 32;
6358 malloc_hysteresis
= 0;
6361 refill_memory_reserve ();
6363 ignore_warnings
= 0;
6365 byte_stack_list
= 0;
6367 consing_since_gc
= 0;
6368 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6369 gc_relative_threshold
= 0;
6376 byte_stack_list
= 0;
6378 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6379 setjmp_tested_p
= longjmps_done
= 0;
6382 Vgc_elapsed
= make_float (0.0);
6387 syms_of_alloc (void)
6389 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6390 doc
: /* *Number of bytes of consing between garbage collections.
6391 Garbage collection can happen automatically once this many bytes have been
6392 allocated since the last garbage collection. All data types count.
6394 Garbage collection happens automatically only when `eval' is called.
6396 By binding this temporarily to a large number, you can effectively
6397 prevent garbage collection during a part of the program.
6398 See also `gc-cons-percentage'. */);
6400 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6401 doc
: /* *Portion of the heap used for allocation.
6402 Garbage collection can happen automatically once this portion of the heap
6403 has been allocated since the last garbage collection.
6404 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6405 Vgc_cons_percentage
= make_float (0.1);
6407 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6408 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6410 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6411 doc
: /* Number of cons cells that have been consed so far. */);
6413 DEFVAR_INT ("floats-consed", floats_consed
,
6414 doc
: /* Number of floats that have been consed so far. */);
6416 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6417 doc
: /* Number of vector cells that have been consed so far. */);
6419 DEFVAR_INT ("symbols-consed", symbols_consed
,
6420 doc
: /* Number of symbols that have been consed so far. */);
6422 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6423 doc
: /* Number of string characters that have been consed so far. */);
6425 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6426 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6428 DEFVAR_INT ("intervals-consed", intervals_consed
,
6429 doc
: /* Number of intervals that have been consed so far. */);
6431 DEFVAR_INT ("strings-consed", strings_consed
,
6432 doc
: /* Number of strings that have been consed so far. */);
6434 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6435 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6436 This means that certain objects should be allocated in shared (pure) space.
6437 It can also be set to a hash-table, in which case this table is used to
6438 do hash-consing of the objects allocated to pure space. */);
6440 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6441 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6442 garbage_collection_messages
= 0;
6444 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6445 doc
: /* Hook run after garbage collection has finished. */);
6446 Vpost_gc_hook
= Qnil
;
6447 DEFSYM (Qpost_gc_hook
, "post-gc-hook");
6449 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6450 doc
: /* Precomputed `signal' argument for memory-full error. */);
6451 /* We build this in advance because if we wait until we need it, we might
6452 not be able to allocate the memory to hold it. */
6454 = pure_cons (Qerror
,
6455 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil
));
6457 DEFVAR_LISP ("memory-full", Vmemory_full
,
6458 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6459 Vmemory_full
= Qnil
;
6461 DEFSYM (Qgc_cons_threshold
, "gc-cons-threshold");
6462 DEFSYM (Qchar_table_extra_slots
, "char-table-extra-slots");
6464 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6465 doc
: /* Accumulated time elapsed in garbage collections.
6466 The time is in seconds as a floating point value. */);
6467 DEFVAR_INT ("gcs-done", gcs_done
,
6468 doc
: /* Accumulated number of garbage collections done. */);
6473 defsubr (&Smake_byte_code
);
6474 defsubr (&Smake_list
);
6475 defsubr (&Smake_vector
);
6476 defsubr (&Smake_string
);
6477 defsubr (&Smake_bool_vector
);
6478 defsubr (&Smake_symbol
);
6479 defsubr (&Smake_marker
);
6480 defsubr (&Spurecopy
);
6481 defsubr (&Sgarbage_collect
);
6482 defsubr (&Smemory_limit
);
6483 defsubr (&Smemory_use_counts
);
6485 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6486 defsubr (&Sgc_status
);