1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
3 2000, 2001, 2002, 2003, 2004, 2005 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 2, or (at your option)
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; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
24 #include <limits.h> /* For CHAR_BIT. */
30 /* Note that this declares bzero on OSF/1. How dumb. */
34 #ifdef HAVE_GTK_AND_PTHREAD
38 /* This file is part of the core Lisp implementation, and thus must
39 deal with the real data structures. If the Lisp implementation is
40 replaced, this file likely will not be used. */
42 #undef HIDE_LISP_IMPLEMENTATION
45 #include "intervals.h"
51 #include "blockinput.h"
53 #include "syssignal.h"
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
57 memory. Can do this only if using gmalloc.c. */
59 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
60 #undef GC_MALLOC_CHECK
66 extern POINTER_TYPE
*sbrk ();
69 #ifdef DOUG_LEA_MALLOC
72 /* malloc.h #defines this as size_t, at least in glibc2. */
73 #ifndef __malloc_size_t
74 #define __malloc_size_t int
77 /* Specify maximum number of areas to mmap. It would be nice to use a
78 value that explicitly means "no limit". */
80 #define MMAP_MAX_AREAS 100000000
82 #else /* not DOUG_LEA_MALLOC */
84 /* The following come from gmalloc.c. */
86 #define __malloc_size_t size_t
87 extern __malloc_size_t _bytes_used
;
88 extern __malloc_size_t __malloc_extra_blocks
;
90 #endif /* not DOUG_LEA_MALLOC */
92 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
94 /* When GTK uses the file chooser dialog, different backends can be loaded
95 dynamically. One such a backend is the Gnome VFS backend that gets loaded
96 if you run Gnome. That backend creates several threads and also allocates
99 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
100 functions below are called from malloc, there is a chance that one
101 of these threads preempts the Emacs main thread and the hook variables
102 end up in an inconsistent state. So we have a mutex to prevent that (note
103 that the backend handles concurrent access to malloc within its own threads
104 but Emacs code running in the main thread is not included in that control).
106 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
107 happens in one of the backend threads we will have two threads that tries
108 to run Emacs code at once, and the code is not prepared for that.
109 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
111 static pthread_mutex_t alloc_mutex
;
113 #define BLOCK_INPUT_ALLOC \
116 pthread_mutex_lock (&alloc_mutex); \
117 if (pthread_self () == main_thread) \
121 #define UNBLOCK_INPUT_ALLOC \
124 if (pthread_self () == main_thread) \
126 pthread_mutex_unlock (&alloc_mutex); \
130 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
132 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
133 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
135 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
137 /* Value of _bytes_used, when spare_memory was freed. */
139 static __malloc_size_t bytes_used_when_full
;
141 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
142 to a struct Lisp_String. */
144 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
145 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
146 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
148 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
149 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
150 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
152 /* Value is the number of bytes/chars of S, a pointer to a struct
153 Lisp_String. This must be used instead of STRING_BYTES (S) or
154 S->size during GC, because S->size contains the mark bit for
157 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
158 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
160 /* Number of bytes of consing done since the last gc. */
162 int consing_since_gc
;
164 /* Count the amount of consing of various sorts of space. */
166 EMACS_INT cons_cells_consed
;
167 EMACS_INT floats_consed
;
168 EMACS_INT vector_cells_consed
;
169 EMACS_INT symbols_consed
;
170 EMACS_INT string_chars_consed
;
171 EMACS_INT misc_objects_consed
;
172 EMACS_INT intervals_consed
;
173 EMACS_INT strings_consed
;
175 /* Minimum number of bytes of consing since GC before next GC. */
177 EMACS_INT gc_cons_threshold
;
179 /* Similar minimum, computed from Vgc_cons_percentage. */
181 EMACS_INT gc_relative_threshold
;
183 static Lisp_Object Vgc_cons_percentage
;
185 /* Nonzero during GC. */
189 /* Nonzero means abort if try to GC.
190 This is for code which is written on the assumption that
191 no GC will happen, so as to verify that assumption. */
195 /* Nonzero means display messages at beginning and end of GC. */
197 int garbage_collection_messages
;
199 #ifndef VIRT_ADDR_VARIES
201 #endif /* VIRT_ADDR_VARIES */
202 int malloc_sbrk_used
;
204 #ifndef VIRT_ADDR_VARIES
206 #endif /* VIRT_ADDR_VARIES */
207 int malloc_sbrk_unused
;
209 /* Number of live and free conses etc. */
211 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
212 static int total_free_conses
, total_free_markers
, total_free_symbols
;
213 static int total_free_floats
, total_floats
;
215 /* Points to memory space allocated as "spare", to be freed if we run
220 /* Amount of spare memory to keep in reserve. */
222 #define SPARE_MEMORY (1 << 14)
224 /* Number of extra blocks malloc should get when it needs more core. */
226 static int malloc_hysteresis
;
228 /* Non-nil means defun should do purecopy on the function definition. */
230 Lisp_Object Vpurify_flag
;
232 /* Non-nil means we are handling a memory-full error. */
234 Lisp_Object Vmemory_full
;
238 /* Initialize it to a nonzero value to force it into data space
239 (rather than bss space). That way unexec will remap it into text
240 space (pure), on some systems. We have not implemented the
241 remapping on more recent systems because this is less important
242 nowadays than in the days of small memories and timesharing. */
244 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {1,};
245 #define PUREBEG (char *) pure
249 #define pure PURE_SEG_BITS /* Use shared memory segment */
250 #define PUREBEG (char *)PURE_SEG_BITS
252 #endif /* HAVE_SHM */
254 /* Pointer to the pure area, and its size. */
256 static char *purebeg
;
257 static size_t pure_size
;
259 /* Number of bytes of pure storage used before pure storage overflowed.
260 If this is non-zero, this implies that an overflow occurred. */
262 static size_t pure_bytes_used_before_overflow
;
264 /* Value is non-zero if P points into pure space. */
266 #define PURE_POINTER_P(P) \
267 (((PNTR_COMPARISON_TYPE) (P) \
268 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
269 && ((PNTR_COMPARISON_TYPE) (P) \
270 >= (PNTR_COMPARISON_TYPE) purebeg))
272 /* Index in pure at which next pure object will be allocated.. */
274 EMACS_INT pure_bytes_used
;
276 /* If nonzero, this is a warning delivered by malloc and not yet
279 char *pending_malloc_warning
;
281 /* Pre-computed signal argument for use when memory is exhausted. */
283 Lisp_Object Vmemory_signal_data
;
285 /* Maximum amount of C stack to save when a GC happens. */
287 #ifndef MAX_SAVE_STACK
288 #define MAX_SAVE_STACK 16000
291 /* Buffer in which we save a copy of the C stack at each GC. */
296 /* Non-zero means ignore malloc warnings. Set during initialization.
297 Currently not used. */
301 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
303 /* Hook run after GC has finished. */
305 Lisp_Object Vpost_gc_hook
, Qpost_gc_hook
;
307 Lisp_Object Vgc_elapsed
; /* accumulated elapsed time in GC */
308 EMACS_INT gcs_done
; /* accumulated GCs */
310 static void mark_buffer
P_ ((Lisp_Object
));
311 extern void mark_kboards
P_ ((void));
312 extern void mark_backtrace
P_ ((void));
313 static void gc_sweep
P_ ((void));
314 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
315 static void mark_face_cache
P_ ((struct face_cache
*));
317 #ifdef HAVE_WINDOW_SYSTEM
318 extern void mark_fringe_data
P_ ((void));
319 static void mark_image
P_ ((struct image
*));
320 static void mark_image_cache
P_ ((struct frame
*));
321 #endif /* HAVE_WINDOW_SYSTEM */
323 static struct Lisp_String
*allocate_string
P_ ((void));
324 static void compact_small_strings
P_ ((void));
325 static void free_large_strings
P_ ((void));
326 static void sweep_strings
P_ ((void));
328 extern int message_enable_multibyte
;
330 /* When scanning the C stack for live Lisp objects, Emacs keeps track
331 of what memory allocated via lisp_malloc is intended for what
332 purpose. This enumeration specifies the type of memory. */
343 /* Keep the following vector-like types together, with
344 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
345 first. Or change the code of live_vector_p, for instance. */
353 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
355 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
356 #include <stdio.h> /* For fprintf. */
359 /* A unique object in pure space used to make some Lisp objects
360 on free lists recognizable in O(1). */
364 #ifdef GC_MALLOC_CHECK
366 enum mem_type allocated_mem_type
;
367 int dont_register_blocks
;
369 #endif /* GC_MALLOC_CHECK */
371 /* A node in the red-black tree describing allocated memory containing
372 Lisp data. Each such block is recorded with its start and end
373 address when it is allocated, and removed from the tree when it
376 A red-black tree is a balanced binary tree with the following
379 1. Every node is either red or black.
380 2. Every leaf is black.
381 3. If a node is red, then both of its children are black.
382 4. Every simple path from a node to a descendant leaf contains
383 the same number of black nodes.
384 5. The root is always black.
386 When nodes are inserted into the tree, or deleted from the tree,
387 the tree is "fixed" so that these properties are always true.
389 A red-black tree with N internal nodes has height at most 2
390 log(N+1). Searches, insertions and deletions are done in O(log N).
391 Please see a text book about data structures for a detailed
392 description of red-black trees. Any book worth its salt should
397 /* Children of this node. These pointers are never NULL. When there
398 is no child, the value is MEM_NIL, which points to a dummy node. */
399 struct mem_node
*left
, *right
;
401 /* The parent of this node. In the root node, this is NULL. */
402 struct mem_node
*parent
;
404 /* Start and end of allocated region. */
408 enum {MEM_BLACK
, MEM_RED
} color
;
414 /* Base address of stack. Set in main. */
416 Lisp_Object
*stack_base
;
418 /* Root of the tree describing allocated Lisp memory. */
420 static struct mem_node
*mem_root
;
422 /* Lowest and highest known address in the heap. */
424 static void *min_heap_address
, *max_heap_address
;
426 /* Sentinel node of the tree. */
428 static struct mem_node mem_z
;
429 #define MEM_NIL &mem_z
431 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
432 static struct Lisp_Vector
*allocate_vectorlike
P_ ((EMACS_INT
, enum mem_type
));
433 static void lisp_free
P_ ((POINTER_TYPE
*));
434 static void mark_stack
P_ ((void));
435 static int live_vector_p
P_ ((struct mem_node
*, void *));
436 static int live_buffer_p
P_ ((struct mem_node
*, void *));
437 static int live_string_p
P_ ((struct mem_node
*, void *));
438 static int live_cons_p
P_ ((struct mem_node
*, void *));
439 static int live_symbol_p
P_ ((struct mem_node
*, void *));
440 static int live_float_p
P_ ((struct mem_node
*, void *));
441 static int live_misc_p
P_ ((struct mem_node
*, void *));
442 static void mark_maybe_object
P_ ((Lisp_Object
));
443 static void mark_memory
P_ ((void *, void *));
444 static void mem_init
P_ ((void));
445 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
446 static void mem_insert_fixup
P_ ((struct mem_node
*));
447 static void mem_rotate_left
P_ ((struct mem_node
*));
448 static void mem_rotate_right
P_ ((struct mem_node
*));
449 static void mem_delete
P_ ((struct mem_node
*));
450 static void mem_delete_fixup
P_ ((struct mem_node
*));
451 static INLINE
struct mem_node
*mem_find
P_ ((void *));
453 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
454 static void check_gcpros
P_ ((void));
457 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
459 /* Recording what needs to be marked for gc. */
461 struct gcpro
*gcprolist
;
463 /* Addresses of staticpro'd variables. Initialize it to a nonzero
464 value; otherwise some compilers put it into BSS. */
466 #define NSTATICS 1280
467 Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
469 /* Index of next unused slot in staticvec. */
473 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
476 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
477 ALIGNMENT must be a power of 2. */
479 #define ALIGN(ptr, ALIGNMENT) \
480 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
481 & ~((ALIGNMENT) - 1)))
485 /************************************************************************
487 ************************************************************************/
489 /* Function malloc calls this if it finds we are near exhausting storage. */
495 pending_malloc_warning
= str
;
499 /* Display an already-pending malloc warning. */
502 display_malloc_warning ()
504 call3 (intern ("display-warning"),
506 build_string (pending_malloc_warning
),
507 intern ("emergency"));
508 pending_malloc_warning
= 0;
512 #ifdef DOUG_LEA_MALLOC
513 # define BYTES_USED (mallinfo ().arena)
515 # define BYTES_USED _bytes_used
519 /* Called if malloc returns zero. */
526 #ifndef SYSTEM_MALLOC
527 bytes_used_when_full
= BYTES_USED
;
530 /* The first time we get here, free the spare memory. */
537 /* This used to call error, but if we've run out of memory, we could
538 get infinite recursion trying to build the string. */
540 Fsignal (Qnil
, Vmemory_signal_data
);
543 DEFUN ("memory-full-p", Fmemory_full_p
, Smemory_full_p
, 0, 0, 0,
544 doc
: /* t if memory is nearly full, nil otherwise. */)
547 return (spare_memory
? Qnil
: Qt
);
550 /* If we released our reserve (due to running out of memory),
551 and we have a fair amount free once again,
552 try to set aside another reserve in case we run out once more.
554 This is called when a relocatable block is freed in ralloc.c. */
557 refill_memory_reserve ()
559 #ifndef SYSTEM_MALLOC
560 if (spare_memory
== 0)
561 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
565 /* Called if we can't allocate relocatable space for a buffer. */
568 buffer_memory_full ()
570 /* If buffers use the relocating allocator, no need to free
571 spare_memory, because we may have plenty of malloc space left
572 that we could get, and if we don't, the malloc that fails will
573 itself cause spare_memory to be freed. If buffers don't use the
574 relocating allocator, treat this like any other failing
583 /* This used to call error, but if we've run out of memory, we could
584 get infinite recursion trying to build the string. */
586 Fsignal (Qnil
, Vmemory_signal_data
);
590 #ifdef XMALLOC_OVERRUN_CHECK
592 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
593 and a 16 byte trailer around each block.
595 The header consists of 12 fixed bytes + a 4 byte integer contaning the
596 original block size, while the trailer consists of 16 fixed bytes.
598 The header is used to detect whether this block has been allocated
599 through these functions -- as it seems that some low-level libc
600 functions may bypass the malloc hooks.
604 #define XMALLOC_OVERRUN_CHECK_SIZE 16
606 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
607 { 0x9a, 0x9b, 0xae, 0xaf,
608 0xbf, 0xbe, 0xce, 0xcf,
609 0xea, 0xeb, 0xec, 0xed };
611 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
612 { 0xaa, 0xab, 0xac, 0xad,
613 0xba, 0xbb, 0xbc, 0xbd,
614 0xca, 0xcb, 0xcc, 0xcd,
615 0xda, 0xdb, 0xdc, 0xdd };
617 /* Macros to insert and extract the block size in the header. */
619 #define XMALLOC_PUT_SIZE(ptr, size) \
620 (ptr[-1] = (size & 0xff), \
621 ptr[-2] = ((size >> 8) & 0xff), \
622 ptr[-3] = ((size >> 16) & 0xff), \
623 ptr[-4] = ((size >> 24) & 0xff))
625 #define XMALLOC_GET_SIZE(ptr) \
626 (size_t)((unsigned)(ptr[-1]) | \
627 ((unsigned)(ptr[-2]) << 8) | \
628 ((unsigned)(ptr[-3]) << 16) | \
629 ((unsigned)(ptr[-4]) << 24))
632 /* The call depth in overrun_check functions. For example, this might happen:
634 overrun_check_malloc()
635 -> malloc -> (via hook)_-> emacs_blocked_malloc
636 -> overrun_check_malloc
637 call malloc (hooks are NULL, so real malloc is called).
638 malloc returns 10000.
639 add overhead, return 10016.
640 <- (back in overrun_check_malloc)
641 add overhead again, return 10032
642 xmalloc returns 10032.
647 overrun_check_free(10032)
649 free(10016) <- crash, because 10000 is the original pointer. */
651 static int check_depth
;
653 /* Like malloc, but wraps allocated block with header and trailer. */
656 overrun_check_malloc (size
)
659 register unsigned char *val
;
660 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
662 val
= (unsigned char *) malloc (size
+ overhead
);
663 if (val
&& check_depth
== 1)
665 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
666 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
667 XMALLOC_PUT_SIZE(val
, size
);
668 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
671 return (POINTER_TYPE
*)val
;
675 /* Like realloc, but checks old block for overrun, and wraps new block
676 with header and trailer. */
679 overrun_check_realloc (block
, size
)
683 register unsigned char *val
= (unsigned char *)block
;
684 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
688 && bcmp (xmalloc_overrun_check_header
,
689 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
690 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
692 size_t osize
= XMALLOC_GET_SIZE (val
);
693 if (bcmp (xmalloc_overrun_check_trailer
,
695 XMALLOC_OVERRUN_CHECK_SIZE
))
697 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
698 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
699 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
702 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
704 if (val
&& check_depth
== 1)
706 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
707 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
708 XMALLOC_PUT_SIZE(val
, size
);
709 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
712 return (POINTER_TYPE
*)val
;
715 /* Like free, but checks block for overrun. */
718 overrun_check_free (block
)
721 unsigned char *val
= (unsigned char *)block
;
726 && bcmp (xmalloc_overrun_check_header
,
727 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
728 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
730 size_t osize
= XMALLOC_GET_SIZE (val
);
731 if (bcmp (xmalloc_overrun_check_trailer
,
733 XMALLOC_OVERRUN_CHECK_SIZE
))
735 #ifdef XMALLOC_CLEAR_FREE_MEMORY
736 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
737 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
739 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
740 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
741 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
752 #define malloc overrun_check_malloc
753 #define realloc overrun_check_realloc
754 #define free overrun_check_free
758 /* Like malloc but check for no memory and block interrupt input.. */
764 register POINTER_TYPE
*val
;
767 val
= (POINTER_TYPE
*) malloc (size
);
776 /* Like realloc but check for no memory and block interrupt input.. */
779 xrealloc (block
, size
)
783 register POINTER_TYPE
*val
;
786 /* We must call malloc explicitly when BLOCK is 0, since some
787 reallocs don't do this. */
789 val
= (POINTER_TYPE
*) malloc (size
);
791 val
= (POINTER_TYPE
*) realloc (block
, size
);
794 if (!val
&& size
) memory_full ();
799 /* Like free but block interrupt input. */
809 #ifndef SYSTEM_MALLOC
810 /* Refill the spare memory if we can. */
811 if (spare_memory
== 0)
812 refill_memory_reserve ();
817 /* Like strdup, but uses xmalloc. */
823 size_t len
= strlen (s
) + 1;
824 char *p
= (char *) xmalloc (len
);
830 /* Unwind for SAFE_ALLOCA */
833 safe_alloca_unwind (arg
)
836 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
846 /* Like malloc but used for allocating Lisp data. NBYTES is the
847 number of bytes to allocate, TYPE describes the intended use of the
848 allcated memory block (for strings, for conses, ...). */
851 static void *lisp_malloc_loser
;
854 static POINTER_TYPE
*
855 lisp_malloc (nbytes
, type
)
863 #ifdef GC_MALLOC_CHECK
864 allocated_mem_type
= type
;
867 val
= (void *) malloc (nbytes
);
870 /* If the memory just allocated cannot be addressed thru a Lisp
871 object's pointer, and it needs to be,
872 that's equivalent to running out of memory. */
873 if (val
&& type
!= MEM_TYPE_NON_LISP
)
876 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
877 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
879 lisp_malloc_loser
= val
;
886 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
887 if (val
&& type
!= MEM_TYPE_NON_LISP
)
888 mem_insert (val
, (char *) val
+ nbytes
, type
);
897 /* Free BLOCK. This must be called to free memory allocated with a
898 call to lisp_malloc. */
906 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
907 mem_delete (mem_find (block
));
912 /* Allocation of aligned blocks of memory to store Lisp data. */
913 /* The entry point is lisp_align_malloc which returns blocks of at most */
914 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
917 /* BLOCK_ALIGN has to be a power of 2. */
918 #define BLOCK_ALIGN (1 << 10)
920 /* Padding to leave at the end of a malloc'd block. This is to give
921 malloc a chance to minimize the amount of memory wasted to alignment.
922 It should be tuned to the particular malloc library used.
923 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
924 posix_memalign on the other hand would ideally prefer a value of 4
925 because otherwise, there's 1020 bytes wasted between each ablocks.
926 In Emacs, testing shows that those 1020 can most of the time be
927 efficiently used by malloc to place other objects, so a value of 0 can
928 still preferable unless you have a lot of aligned blocks and virtually
930 #define BLOCK_PADDING 0
931 #define BLOCK_BYTES \
932 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
934 /* Internal data structures and constants. */
936 #define ABLOCKS_SIZE 16
938 /* An aligned block of memory. */
943 char payload
[BLOCK_BYTES
];
944 struct ablock
*next_free
;
946 /* `abase' is the aligned base of the ablocks. */
947 /* It is overloaded to hold the virtual `busy' field that counts
948 the number of used ablock in the parent ablocks.
949 The first ablock has the `busy' field, the others have the `abase'
950 field. To tell the difference, we assume that pointers will have
951 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
952 is used to tell whether the real base of the parent ablocks is `abase'
953 (if not, the word before the first ablock holds a pointer to the
955 struct ablocks
*abase
;
956 /* The padding of all but the last ablock is unused. The padding of
957 the last ablock in an ablocks is not allocated. */
959 char padding
[BLOCK_PADDING
];
963 /* A bunch of consecutive aligned blocks. */
966 struct ablock blocks
[ABLOCKS_SIZE
];
969 /* Size of the block requested from malloc or memalign. */
970 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
972 #define ABLOCK_ABASE(block) \
973 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
974 ? (struct ablocks *)(block) \
977 /* Virtual `busy' field. */
978 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
980 /* Pointer to the (not necessarily aligned) malloc block. */
981 #ifdef HAVE_POSIX_MEMALIGN
982 #define ABLOCKS_BASE(abase) (abase)
984 #define ABLOCKS_BASE(abase) \
985 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
988 /* The list of free ablock. */
989 static struct ablock
*free_ablock
;
991 /* Allocate an aligned block of nbytes.
992 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
993 smaller or equal to BLOCK_BYTES. */
994 static POINTER_TYPE
*
995 lisp_align_malloc (nbytes
, type
)
1000 struct ablocks
*abase
;
1002 eassert (nbytes
<= BLOCK_BYTES
);
1006 #ifdef GC_MALLOC_CHECK
1007 allocated_mem_type
= type
;
1013 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
1015 #ifdef DOUG_LEA_MALLOC
1016 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1017 because mapped region contents are not preserved in
1019 mallopt (M_MMAP_MAX
, 0);
1022 #ifdef HAVE_POSIX_MEMALIGN
1024 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1030 base
= malloc (ABLOCKS_BYTES
);
1031 abase
= ALIGN (base
, BLOCK_ALIGN
);
1040 aligned
= (base
== abase
);
1042 ((void**)abase
)[-1] = base
;
1044 #ifdef DOUG_LEA_MALLOC
1045 /* Back to a reasonable maximum of mmap'ed areas. */
1046 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1050 /* If the memory just allocated cannot be addressed thru a Lisp
1051 object's pointer, and it needs to be, that's equivalent to
1052 running out of memory. */
1053 if (type
!= MEM_TYPE_NON_LISP
)
1056 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1057 XSETCONS (tem
, end
);
1058 if ((char *) XCONS (tem
) != end
)
1060 lisp_malloc_loser
= base
;
1068 /* Initialize the blocks and put them on the free list.
1069 Is `base' was not properly aligned, we can't use the last block. */
1070 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1072 abase
->blocks
[i
].abase
= abase
;
1073 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1074 free_ablock
= &abase
->blocks
[i
];
1076 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
1078 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
1079 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1080 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1081 eassert (ABLOCKS_BASE (abase
) == base
);
1082 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1085 abase
= ABLOCK_ABASE (free_ablock
);
1086 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1088 free_ablock
= free_ablock
->x
.next_free
;
1090 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1091 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1092 mem_insert (val
, (char *) val
+ nbytes
, type
);
1099 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1104 lisp_align_free (block
)
1105 POINTER_TYPE
*block
;
1107 struct ablock
*ablock
= block
;
1108 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1111 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1112 mem_delete (mem_find (block
));
1114 /* Put on free list. */
1115 ablock
->x
.next_free
= free_ablock
;
1116 free_ablock
= ablock
;
1117 /* Update busy count. */
1118 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1120 if (2 > (long) ABLOCKS_BUSY (abase
))
1121 { /* All the blocks are free. */
1122 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1123 struct ablock
**tem
= &free_ablock
;
1124 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1128 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1131 *tem
= (*tem
)->x
.next_free
;
1134 tem
= &(*tem
)->x
.next_free
;
1136 eassert ((aligned
& 1) == aligned
);
1137 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1138 free (ABLOCKS_BASE (abase
));
1143 /* Return a new buffer structure allocated from the heap with
1144 a call to lisp_malloc. */
1150 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1156 #ifndef SYSTEM_MALLOC
1158 /* Arranging to disable input signals while we're in malloc.
1160 This only works with GNU malloc. To help out systems which can't
1161 use GNU malloc, all the calls to malloc, realloc, and free
1162 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1163 pair; unfortunately, we have no idea what C library functions
1164 might call malloc, so we can't really protect them unless you're
1165 using GNU malloc. Fortunately, most of the major operating systems
1166 can use GNU malloc. */
1170 #ifndef DOUG_LEA_MALLOC
1171 extern void * (*__malloc_hook
) P_ ((size_t, const void *));
1172 extern void * (*__realloc_hook
) P_ ((void *, size_t, const void *));
1173 extern void (*__free_hook
) P_ ((void *, const void *));
1174 /* Else declared in malloc.h, perhaps with an extra arg. */
1175 #endif /* DOUG_LEA_MALLOC */
1176 static void * (*old_malloc_hook
) P_ ((size_t, const void *));
1177 static void * (*old_realloc_hook
) P_ ((void *, size_t, const void*));
1178 static void (*old_free_hook
) P_ ((void*, const void*));
1180 /* This function is used as the hook for free to call. */
1183 emacs_blocked_free (ptr
, ptr2
)
1189 #ifdef GC_MALLOC_CHECK
1195 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1198 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1203 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1207 #endif /* GC_MALLOC_CHECK */
1209 __free_hook
= old_free_hook
;
1212 /* If we released our reserve (due to running out of memory),
1213 and we have a fair amount free once again,
1214 try to set aside another reserve in case we run out once more. */
1215 if (spare_memory
== 0
1216 /* Verify there is enough space that even with the malloc
1217 hysteresis this call won't run out again.
1218 The code here is correct as long as SPARE_MEMORY
1219 is substantially larger than the block size malloc uses. */
1220 && (bytes_used_when_full
1221 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
1222 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
1224 __free_hook
= emacs_blocked_free
;
1225 UNBLOCK_INPUT_ALLOC
;
1229 /* This function is the malloc hook that Emacs uses. */
1232 emacs_blocked_malloc (size
, ptr
)
1239 __malloc_hook
= old_malloc_hook
;
1240 #ifdef DOUG_LEA_MALLOC
1241 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
1243 __malloc_extra_blocks
= malloc_hysteresis
;
1246 value
= (void *) malloc (size
);
1248 #ifdef GC_MALLOC_CHECK
1250 struct mem_node
*m
= mem_find (value
);
1253 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1255 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1256 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1261 if (!dont_register_blocks
)
1263 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1264 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1267 #endif /* GC_MALLOC_CHECK */
1269 __malloc_hook
= emacs_blocked_malloc
;
1270 UNBLOCK_INPUT_ALLOC
;
1272 /* fprintf (stderr, "%p malloc\n", value); */
1277 /* This function is the realloc hook that Emacs uses. */
1280 emacs_blocked_realloc (ptr
, size
, ptr2
)
1288 __realloc_hook
= old_realloc_hook
;
1290 #ifdef GC_MALLOC_CHECK
1293 struct mem_node
*m
= mem_find (ptr
);
1294 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1297 "Realloc of %p which wasn't allocated with malloc\n",
1305 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1307 /* Prevent malloc from registering blocks. */
1308 dont_register_blocks
= 1;
1309 #endif /* GC_MALLOC_CHECK */
1311 value
= (void *) realloc (ptr
, size
);
1313 #ifdef GC_MALLOC_CHECK
1314 dont_register_blocks
= 0;
1317 struct mem_node
*m
= mem_find (value
);
1320 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1324 /* Can't handle zero size regions in the red-black tree. */
1325 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1328 /* fprintf (stderr, "%p <- realloc\n", value); */
1329 #endif /* GC_MALLOC_CHECK */
1331 __realloc_hook
= emacs_blocked_realloc
;
1332 UNBLOCK_INPUT_ALLOC
;
1338 #ifdef HAVE_GTK_AND_PTHREAD
1339 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1340 normal malloc. Some thread implementations need this as they call
1341 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1342 calls malloc because it is the first call, and we have an endless loop. */
1345 reset_malloc_hooks ()
1351 #endif /* HAVE_GTK_AND_PTHREAD */
1354 /* Called from main to set up malloc to use our hooks. */
1357 uninterrupt_malloc ()
1359 #ifdef HAVE_GTK_AND_PTHREAD
1360 pthread_mutexattr_t attr
;
1362 /* GLIBC has a faster way to do this, but lets keep it portable.
1363 This is according to the Single UNIX Specification. */
1364 pthread_mutexattr_init (&attr
);
1365 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1366 pthread_mutex_init (&alloc_mutex
, &attr
);
1367 #endif /* HAVE_GTK_AND_PTHREAD */
1369 if (__free_hook
!= emacs_blocked_free
)
1370 old_free_hook
= __free_hook
;
1371 __free_hook
= emacs_blocked_free
;
1373 if (__malloc_hook
!= emacs_blocked_malloc
)
1374 old_malloc_hook
= __malloc_hook
;
1375 __malloc_hook
= emacs_blocked_malloc
;
1377 if (__realloc_hook
!= emacs_blocked_realloc
)
1378 old_realloc_hook
= __realloc_hook
;
1379 __realloc_hook
= emacs_blocked_realloc
;
1382 #endif /* not SYNC_INPUT */
1383 #endif /* not SYSTEM_MALLOC */
1387 /***********************************************************************
1389 ***********************************************************************/
1391 /* Number of intervals allocated in an interval_block structure.
1392 The 1020 is 1024 minus malloc overhead. */
1394 #define INTERVAL_BLOCK_SIZE \
1395 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1397 /* Intervals are allocated in chunks in form of an interval_block
1400 struct interval_block
1402 /* Place `intervals' first, to preserve alignment. */
1403 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1404 struct interval_block
*next
;
1407 /* Current interval block. Its `next' pointer points to older
1410 struct interval_block
*interval_block
;
1412 /* Index in interval_block above of the next unused interval
1415 static int interval_block_index
;
1417 /* Number of free and live intervals. */
1419 static int total_free_intervals
, total_intervals
;
1421 /* List of free intervals. */
1423 INTERVAL interval_free_list
;
1425 /* Total number of interval blocks now in use. */
1427 int n_interval_blocks
;
1430 /* Initialize interval allocation. */
1435 interval_block
= NULL
;
1436 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1437 interval_free_list
= 0;
1438 n_interval_blocks
= 0;
1442 /* Return a new interval. */
1449 if (interval_free_list
)
1451 val
= interval_free_list
;
1452 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1456 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1458 register struct interval_block
*newi
;
1460 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1463 newi
->next
= interval_block
;
1464 interval_block
= newi
;
1465 interval_block_index
= 0;
1466 n_interval_blocks
++;
1468 val
= &interval_block
->intervals
[interval_block_index
++];
1470 consing_since_gc
+= sizeof (struct interval
);
1472 RESET_INTERVAL (val
);
1478 /* Mark Lisp objects in interval I. */
1481 mark_interval (i
, dummy
)
1482 register INTERVAL i
;
1485 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1487 mark_object (i
->plist
);
1491 /* Mark the interval tree rooted in TREE. Don't call this directly;
1492 use the macro MARK_INTERVAL_TREE instead. */
1495 mark_interval_tree (tree
)
1496 register INTERVAL tree
;
1498 /* No need to test if this tree has been marked already; this
1499 function is always called through the MARK_INTERVAL_TREE macro,
1500 which takes care of that. */
1502 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1506 /* Mark the interval tree rooted in I. */
1508 #define MARK_INTERVAL_TREE(i) \
1510 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1511 mark_interval_tree (i); \
1515 #define UNMARK_BALANCE_INTERVALS(i) \
1517 if (! NULL_INTERVAL_P (i)) \
1518 (i) = balance_intervals (i); \
1522 /* Number support. If NO_UNION_TYPE isn't in effect, we
1523 can't create number objects in macros. */
1531 obj
.s
.type
= Lisp_Int
;
1536 /***********************************************************************
1538 ***********************************************************************/
1540 /* Lisp_Strings are allocated in string_block structures. When a new
1541 string_block is allocated, all the Lisp_Strings it contains are
1542 added to a free-list string_free_list. When a new Lisp_String is
1543 needed, it is taken from that list. During the sweep phase of GC,
1544 string_blocks that are entirely free are freed, except two which
1547 String data is allocated from sblock structures. Strings larger
1548 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1549 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1551 Sblocks consist internally of sdata structures, one for each
1552 Lisp_String. The sdata structure points to the Lisp_String it
1553 belongs to. The Lisp_String points back to the `u.data' member of
1554 its sdata structure.
1556 When a Lisp_String is freed during GC, it is put back on
1557 string_free_list, and its `data' member and its sdata's `string'
1558 pointer is set to null. The size of the string is recorded in the
1559 `u.nbytes' member of the sdata. So, sdata structures that are no
1560 longer used, can be easily recognized, and it's easy to compact the
1561 sblocks of small strings which we do in compact_small_strings. */
1563 /* Size in bytes of an sblock structure used for small strings. This
1564 is 8192 minus malloc overhead. */
1566 #define SBLOCK_SIZE 8188
1568 /* Strings larger than this are considered large strings. String data
1569 for large strings is allocated from individual sblocks. */
1571 #define LARGE_STRING_BYTES 1024
1573 /* Structure describing string memory sub-allocated from an sblock.
1574 This is where the contents of Lisp strings are stored. */
1578 /* Back-pointer to the string this sdata belongs to. If null, this
1579 structure is free, and the NBYTES member of the union below
1580 contains the string's byte size (the same value that STRING_BYTES
1581 would return if STRING were non-null). If non-null, STRING_BYTES
1582 (STRING) is the size of the data, and DATA contains the string's
1584 struct Lisp_String
*string
;
1586 #ifdef GC_CHECK_STRING_BYTES
1589 unsigned char data
[1];
1591 #define SDATA_NBYTES(S) (S)->nbytes
1592 #define SDATA_DATA(S) (S)->data
1594 #else /* not GC_CHECK_STRING_BYTES */
1598 /* When STRING in non-null. */
1599 unsigned char data
[1];
1601 /* When STRING is null. */
1606 #define SDATA_NBYTES(S) (S)->u.nbytes
1607 #define SDATA_DATA(S) (S)->u.data
1609 #endif /* not GC_CHECK_STRING_BYTES */
1613 /* Structure describing a block of memory which is sub-allocated to
1614 obtain string data memory for strings. Blocks for small strings
1615 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1616 as large as needed. */
1621 struct sblock
*next
;
1623 /* Pointer to the next free sdata block. This points past the end
1624 of the sblock if there isn't any space left in this block. */
1625 struct sdata
*next_free
;
1627 /* Start of data. */
1628 struct sdata first_data
;
1631 /* Number of Lisp strings in a string_block structure. The 1020 is
1632 1024 minus malloc overhead. */
1634 #define STRING_BLOCK_SIZE \
1635 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1637 /* Structure describing a block from which Lisp_String structures
1642 /* Place `strings' first, to preserve alignment. */
1643 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1644 struct string_block
*next
;
1647 /* Head and tail of the list of sblock structures holding Lisp string
1648 data. We always allocate from current_sblock. The NEXT pointers
1649 in the sblock structures go from oldest_sblock to current_sblock. */
1651 static struct sblock
*oldest_sblock
, *current_sblock
;
1653 /* List of sblocks for large strings. */
1655 static struct sblock
*large_sblocks
;
1657 /* List of string_block structures, and how many there are. */
1659 static struct string_block
*string_blocks
;
1660 static int n_string_blocks
;
1662 /* Free-list of Lisp_Strings. */
1664 static struct Lisp_String
*string_free_list
;
1666 /* Number of live and free Lisp_Strings. */
1668 static int total_strings
, total_free_strings
;
1670 /* Number of bytes used by live strings. */
1672 static int total_string_size
;
1674 /* Given a pointer to a Lisp_String S which is on the free-list
1675 string_free_list, return a pointer to its successor in the
1678 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1680 /* Return a pointer to the sdata structure belonging to Lisp string S.
1681 S must be live, i.e. S->data must not be null. S->data is actually
1682 a pointer to the `u.data' member of its sdata structure; the
1683 structure starts at a constant offset in front of that. */
1685 #ifdef GC_CHECK_STRING_BYTES
1687 #define SDATA_OF_STRING(S) \
1688 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1689 - sizeof (EMACS_INT)))
1691 #else /* not GC_CHECK_STRING_BYTES */
1693 #define SDATA_OF_STRING(S) \
1694 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1696 #endif /* not GC_CHECK_STRING_BYTES */
1699 #ifdef GC_CHECK_STRING_OVERRUN
1701 /* We check for overrun in string data blocks by appending a small
1702 "cookie" after each allocated string data block, and check for the
1703 presence of this cookie during GC. */
1705 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1706 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1707 { 0xde, 0xad, 0xbe, 0xef };
1710 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1713 /* Value is the size of an sdata structure large enough to hold NBYTES
1714 bytes of string data. The value returned includes a terminating
1715 NUL byte, the size of the sdata structure, and padding. */
1717 #ifdef GC_CHECK_STRING_BYTES
1719 #define SDATA_SIZE(NBYTES) \
1720 ((sizeof (struct Lisp_String *) \
1722 + sizeof (EMACS_INT) \
1723 + sizeof (EMACS_INT) - 1) \
1724 & ~(sizeof (EMACS_INT) - 1))
1726 #else /* not GC_CHECK_STRING_BYTES */
1728 #define SDATA_SIZE(NBYTES) \
1729 ((sizeof (struct Lisp_String *) \
1731 + sizeof (EMACS_INT) - 1) \
1732 & ~(sizeof (EMACS_INT) - 1))
1734 #endif /* not GC_CHECK_STRING_BYTES */
1736 /* Extra bytes to allocate for each string. */
1738 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1740 /* Initialize string allocation. Called from init_alloc_once. */
1745 total_strings
= total_free_strings
= total_string_size
= 0;
1746 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1747 string_blocks
= NULL
;
1748 n_string_blocks
= 0;
1749 string_free_list
= NULL
;
1753 #ifdef GC_CHECK_STRING_BYTES
1755 static int check_string_bytes_count
;
1757 void check_string_bytes
P_ ((int));
1758 void check_sblock
P_ ((struct sblock
*));
1760 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1763 /* Like GC_STRING_BYTES, but with debugging check. */
1767 struct Lisp_String
*s
;
1769 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1770 if (!PURE_POINTER_P (s
)
1772 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1777 /* Check validity of Lisp strings' string_bytes member in B. */
1783 struct sdata
*from
, *end
, *from_end
;
1787 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1789 /* Compute the next FROM here because copying below may
1790 overwrite data we need to compute it. */
1793 /* Check that the string size recorded in the string is the
1794 same as the one recorded in the sdata structure. */
1796 CHECK_STRING_BYTES (from
->string
);
1799 nbytes
= GC_STRING_BYTES (from
->string
);
1801 nbytes
= SDATA_NBYTES (from
);
1803 nbytes
= SDATA_SIZE (nbytes
);
1804 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1809 /* Check validity of Lisp strings' string_bytes member. ALL_P
1810 non-zero means check all strings, otherwise check only most
1811 recently allocated strings. Used for hunting a bug. */
1814 check_string_bytes (all_p
)
1821 for (b
= large_sblocks
; b
; b
= b
->next
)
1823 struct Lisp_String
*s
= b
->first_data
.string
;
1825 CHECK_STRING_BYTES (s
);
1828 for (b
= oldest_sblock
; b
; b
= b
->next
)
1832 check_sblock (current_sblock
);
1835 #endif /* GC_CHECK_STRING_BYTES */
1837 #ifdef GC_CHECK_STRING_FREE_LIST
1839 /* Walk through the string free list looking for bogus next pointers.
1840 This may catch buffer overrun from a previous string. */
1843 check_string_free_list ()
1845 struct Lisp_String
*s
;
1847 /* Pop a Lisp_String off the free-list. */
1848 s
= string_free_list
;
1851 if ((unsigned)s
< 1024)
1853 s
= NEXT_FREE_LISP_STRING (s
);
1857 #define check_string_free_list()
1860 /* Return a new Lisp_String. */
1862 static struct Lisp_String
*
1865 struct Lisp_String
*s
;
1867 /* If the free-list is empty, allocate a new string_block, and
1868 add all the Lisp_Strings in it to the free-list. */
1869 if (string_free_list
== NULL
)
1871 struct string_block
*b
;
1874 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1875 bzero (b
, sizeof *b
);
1876 b
->next
= string_blocks
;
1880 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1883 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1884 string_free_list
= s
;
1887 total_free_strings
+= STRING_BLOCK_SIZE
;
1890 check_string_free_list ();
1892 /* Pop a Lisp_String off the free-list. */
1893 s
= string_free_list
;
1894 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1896 /* Probably not strictly necessary, but play it safe. */
1897 bzero (s
, sizeof *s
);
1899 --total_free_strings
;
1902 consing_since_gc
+= sizeof *s
;
1904 #ifdef GC_CHECK_STRING_BYTES
1911 if (++check_string_bytes_count
== 200)
1913 check_string_bytes_count
= 0;
1914 check_string_bytes (1);
1917 check_string_bytes (0);
1919 #endif /* GC_CHECK_STRING_BYTES */
1925 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1926 plus a NUL byte at the end. Allocate an sdata structure for S, and
1927 set S->data to its `u.data' member. Store a NUL byte at the end of
1928 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1929 S->data if it was initially non-null. */
1932 allocate_string_data (s
, nchars
, nbytes
)
1933 struct Lisp_String
*s
;
1936 struct sdata
*data
, *old_data
;
1938 int needed
, old_nbytes
;
1940 /* Determine the number of bytes needed to store NBYTES bytes
1942 needed
= SDATA_SIZE (nbytes
);
1944 if (nbytes
> LARGE_STRING_BYTES
)
1946 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1948 #ifdef DOUG_LEA_MALLOC
1949 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1950 because mapped region contents are not preserved in
1953 In case you think of allowing it in a dumped Emacs at the
1954 cost of not being able to re-dump, there's another reason:
1955 mmap'ed data typically have an address towards the top of the
1956 address space, which won't fit into an EMACS_INT (at least on
1957 32-bit systems with the current tagging scheme). --fx */
1959 mallopt (M_MMAP_MAX
, 0);
1963 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1965 #ifdef DOUG_LEA_MALLOC
1966 /* Back to a reasonable maximum of mmap'ed areas. */
1968 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1972 b
->next_free
= &b
->first_data
;
1973 b
->first_data
.string
= NULL
;
1974 b
->next
= large_sblocks
;
1977 else if (current_sblock
== NULL
1978 || (((char *) current_sblock
+ SBLOCK_SIZE
1979 - (char *) current_sblock
->next_free
)
1980 < (needed
+ GC_STRING_EXTRA
)))
1982 /* Not enough room in the current sblock. */
1983 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1984 b
->next_free
= &b
->first_data
;
1985 b
->first_data
.string
= NULL
;
1989 current_sblock
->next
= b
;
1997 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1998 old_nbytes
= GC_STRING_BYTES (s
);
2000 data
= b
->next_free
;
2002 s
->data
= SDATA_DATA (data
);
2003 #ifdef GC_CHECK_STRING_BYTES
2004 SDATA_NBYTES (data
) = nbytes
;
2007 s
->size_byte
= nbytes
;
2008 s
->data
[nbytes
] = '\0';
2009 #ifdef GC_CHECK_STRING_OVERRUN
2010 bcopy (string_overrun_cookie
, (char *) data
+ needed
,
2011 GC_STRING_OVERRUN_COOKIE_SIZE
);
2013 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2015 /* If S had already data assigned, mark that as free by setting its
2016 string back-pointer to null, and recording the size of the data
2020 SDATA_NBYTES (old_data
) = old_nbytes
;
2021 old_data
->string
= NULL
;
2024 consing_since_gc
+= needed
;
2028 /* Sweep and compact strings. */
2033 struct string_block
*b
, *next
;
2034 struct string_block
*live_blocks
= NULL
;
2036 string_free_list
= NULL
;
2037 total_strings
= total_free_strings
= 0;
2038 total_string_size
= 0;
2040 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2041 for (b
= string_blocks
; b
; b
= next
)
2044 struct Lisp_String
*free_list_before
= string_free_list
;
2048 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2050 struct Lisp_String
*s
= b
->strings
+ i
;
2054 /* String was not on free-list before. */
2055 if (STRING_MARKED_P (s
))
2057 /* String is live; unmark it and its intervals. */
2060 if (!NULL_INTERVAL_P (s
->intervals
))
2061 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2064 total_string_size
+= STRING_BYTES (s
);
2068 /* String is dead. Put it on the free-list. */
2069 struct sdata
*data
= SDATA_OF_STRING (s
);
2071 /* Save the size of S in its sdata so that we know
2072 how large that is. Reset the sdata's string
2073 back-pointer so that we know it's free. */
2074 #ifdef GC_CHECK_STRING_BYTES
2075 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2078 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2080 data
->string
= NULL
;
2082 /* Reset the strings's `data' member so that we
2086 /* Put the string on the free-list. */
2087 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2088 string_free_list
= s
;
2094 /* S was on the free-list before. Put it there again. */
2095 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2096 string_free_list
= s
;
2101 /* Free blocks that contain free Lisp_Strings only, except
2102 the first two of them. */
2103 if (nfree
== STRING_BLOCK_SIZE
2104 && total_free_strings
> STRING_BLOCK_SIZE
)
2108 string_free_list
= free_list_before
;
2112 total_free_strings
+= nfree
;
2113 b
->next
= live_blocks
;
2118 check_string_free_list ();
2120 string_blocks
= live_blocks
;
2121 free_large_strings ();
2122 compact_small_strings ();
2124 check_string_free_list ();
2128 /* Free dead large strings. */
2131 free_large_strings ()
2133 struct sblock
*b
, *next
;
2134 struct sblock
*live_blocks
= NULL
;
2136 for (b
= large_sblocks
; b
; b
= next
)
2140 if (b
->first_data
.string
== NULL
)
2144 b
->next
= live_blocks
;
2149 large_sblocks
= live_blocks
;
2153 /* Compact data of small strings. Free sblocks that don't contain
2154 data of live strings after compaction. */
2157 compact_small_strings ()
2159 struct sblock
*b
, *tb
, *next
;
2160 struct sdata
*from
, *to
, *end
, *tb_end
;
2161 struct sdata
*to_end
, *from_end
;
2163 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2164 to, and TB_END is the end of TB. */
2166 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2167 to
= &tb
->first_data
;
2169 /* Step through the blocks from the oldest to the youngest. We
2170 expect that old blocks will stabilize over time, so that less
2171 copying will happen this way. */
2172 for (b
= oldest_sblock
; b
; b
= b
->next
)
2175 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2177 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2179 /* Compute the next FROM here because copying below may
2180 overwrite data we need to compute it. */
2183 #ifdef GC_CHECK_STRING_BYTES
2184 /* Check that the string size recorded in the string is the
2185 same as the one recorded in the sdata structure. */
2187 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2189 #endif /* GC_CHECK_STRING_BYTES */
2192 nbytes
= GC_STRING_BYTES (from
->string
);
2194 nbytes
= SDATA_NBYTES (from
);
2196 if (nbytes
> LARGE_STRING_BYTES
)
2199 nbytes
= SDATA_SIZE (nbytes
);
2200 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2202 #ifdef GC_CHECK_STRING_OVERRUN
2203 if (bcmp (string_overrun_cookie
,
2204 ((char *) from_end
) - GC_STRING_OVERRUN_COOKIE_SIZE
,
2205 GC_STRING_OVERRUN_COOKIE_SIZE
))
2209 /* FROM->string non-null means it's alive. Copy its data. */
2212 /* If TB is full, proceed with the next sblock. */
2213 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2214 if (to_end
> tb_end
)
2218 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2219 to
= &tb
->first_data
;
2220 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2223 /* Copy, and update the string's `data' pointer. */
2226 xassert (tb
!= b
|| to
<= from
);
2227 safe_bcopy ((char *) from
, (char *) to
, nbytes
+ GC_STRING_EXTRA
);
2228 to
->string
->data
= SDATA_DATA (to
);
2231 /* Advance past the sdata we copied to. */
2237 /* The rest of the sblocks following TB don't contain live data, so
2238 we can free them. */
2239 for (b
= tb
->next
; b
; b
= next
)
2247 current_sblock
= tb
;
2251 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2252 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2253 LENGTH must be an integer.
2254 INIT must be an integer that represents a character. */)
2256 Lisp_Object length
, init
;
2258 register Lisp_Object val
;
2259 register unsigned char *p
, *end
;
2262 CHECK_NATNUM (length
);
2263 CHECK_NUMBER (init
);
2266 if (SINGLE_BYTE_CHAR_P (c
))
2268 nbytes
= XINT (length
);
2269 val
= make_uninit_string (nbytes
);
2271 end
= p
+ SCHARS (val
);
2277 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2278 int len
= CHAR_STRING (c
, str
);
2280 nbytes
= len
* XINT (length
);
2281 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
2286 bcopy (str
, p
, len
);
2296 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2297 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
2298 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2300 Lisp_Object length
, init
;
2302 register Lisp_Object val
;
2303 struct Lisp_Bool_Vector
*p
;
2305 int length_in_chars
, length_in_elts
, bits_per_value
;
2307 CHECK_NATNUM (length
);
2309 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2311 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2312 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2313 / BOOL_VECTOR_BITS_PER_CHAR
);
2315 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2316 slot `size' of the struct Lisp_Bool_Vector. */
2317 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2318 p
= XBOOL_VECTOR (val
);
2320 /* Get rid of any bits that would cause confusion. */
2322 XSETBOOL_VECTOR (val
, p
);
2323 p
->size
= XFASTINT (length
);
2325 real_init
= (NILP (init
) ? 0 : -1);
2326 for (i
= 0; i
< length_in_chars
; i
++)
2327 p
->data
[i
] = real_init
;
2329 /* Clear the extraneous bits in the last byte. */
2330 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2331 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
2332 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2338 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2339 of characters from the contents. This string may be unibyte or
2340 multibyte, depending on the contents. */
2343 make_string (contents
, nbytes
)
2344 const char *contents
;
2347 register Lisp_Object val
;
2348 int nchars
, multibyte_nbytes
;
2350 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
2351 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2352 /* CONTENTS contains no multibyte sequences or contains an invalid
2353 multibyte sequence. We must make unibyte string. */
2354 val
= make_unibyte_string (contents
, nbytes
);
2356 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2361 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2364 make_unibyte_string (contents
, length
)
2365 const char *contents
;
2368 register Lisp_Object val
;
2369 val
= make_uninit_string (length
);
2370 bcopy (contents
, SDATA (val
), length
);
2371 STRING_SET_UNIBYTE (val
);
2376 /* Make a multibyte string from NCHARS characters occupying NBYTES
2377 bytes at CONTENTS. */
2380 make_multibyte_string (contents
, nchars
, nbytes
)
2381 const char *contents
;
2384 register Lisp_Object val
;
2385 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2386 bcopy (contents
, SDATA (val
), nbytes
);
2391 /* Make a string from NCHARS characters occupying NBYTES bytes at
2392 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2395 make_string_from_bytes (contents
, nchars
, nbytes
)
2396 const char *contents
;
2399 register Lisp_Object val
;
2400 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2401 bcopy (contents
, SDATA (val
), nbytes
);
2402 if (SBYTES (val
) == SCHARS (val
))
2403 STRING_SET_UNIBYTE (val
);
2408 /* Make a string from NCHARS characters occupying NBYTES bytes at
2409 CONTENTS. The argument MULTIBYTE controls whether to label the
2410 string as multibyte. If NCHARS is negative, it counts the number of
2411 characters by itself. */
2414 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2415 const char *contents
;
2419 register Lisp_Object val
;
2424 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2428 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2429 bcopy (contents
, SDATA (val
), nbytes
);
2431 STRING_SET_UNIBYTE (val
);
2436 /* Make a string from the data at STR, treating it as multibyte if the
2443 return make_string (str
, strlen (str
));
2447 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2448 occupying LENGTH bytes. */
2451 make_uninit_string (length
)
2455 val
= make_uninit_multibyte_string (length
, length
);
2456 STRING_SET_UNIBYTE (val
);
2461 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2462 which occupy NBYTES bytes. */
2465 make_uninit_multibyte_string (nchars
, nbytes
)
2469 struct Lisp_String
*s
;
2474 s
= allocate_string ();
2475 allocate_string_data (s
, nchars
, nbytes
);
2476 XSETSTRING (string
, s
);
2477 string_chars_consed
+= nbytes
;
2483 /***********************************************************************
2485 ***********************************************************************/
2487 /* We store float cells inside of float_blocks, allocating a new
2488 float_block with malloc whenever necessary. Float cells reclaimed
2489 by GC are put on a free list to be reallocated before allocating
2490 any new float cells from the latest float_block. */
2492 #define FLOAT_BLOCK_SIZE \
2493 (((BLOCK_BYTES - sizeof (struct float_block *) \
2494 /* The compiler might add padding at the end. */ \
2495 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2496 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2498 #define GETMARKBIT(block,n) \
2499 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2500 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2503 #define SETMARKBIT(block,n) \
2504 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2505 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2507 #define UNSETMARKBIT(block,n) \
2508 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2509 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2511 #define FLOAT_BLOCK(fptr) \
2512 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2514 #define FLOAT_INDEX(fptr) \
2515 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2519 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2520 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2521 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2522 struct float_block
*next
;
2525 #define FLOAT_MARKED_P(fptr) \
2526 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2528 #define FLOAT_MARK(fptr) \
2529 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2531 #define FLOAT_UNMARK(fptr) \
2532 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2534 /* Current float_block. */
2536 struct float_block
*float_block
;
2538 /* Index of first unused Lisp_Float in the current float_block. */
2540 int float_block_index
;
2542 /* Total number of float blocks now in use. */
2546 /* Free-list of Lisp_Floats. */
2548 struct Lisp_Float
*float_free_list
;
2551 /* Initialize float allocation. */
2557 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2558 float_free_list
= 0;
2563 /* Explicitly free a float cell by putting it on the free-list. */
2567 struct Lisp_Float
*ptr
;
2569 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
2570 float_free_list
= ptr
;
2574 /* Return a new float object with value FLOAT_VALUE. */
2577 make_float (float_value
)
2580 register Lisp_Object val
;
2582 if (float_free_list
)
2584 /* We use the data field for chaining the free list
2585 so that we won't use the same field that has the mark bit. */
2586 XSETFLOAT (val
, float_free_list
);
2587 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
2591 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2593 register struct float_block
*new;
2595 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2597 new->next
= float_block
;
2598 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2600 float_block_index
= 0;
2603 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2604 float_block_index
++;
2607 XFLOAT_DATA (val
) = float_value
;
2608 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2609 consing_since_gc
+= sizeof (struct Lisp_Float
);
2616 /***********************************************************************
2618 ***********************************************************************/
2620 /* We store cons cells inside of cons_blocks, allocating a new
2621 cons_block with malloc whenever necessary. Cons cells reclaimed by
2622 GC are put on a free list to be reallocated before allocating
2623 any new cons cells from the latest cons_block. */
2625 #define CONS_BLOCK_SIZE \
2626 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2627 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2629 #define CONS_BLOCK(fptr) \
2630 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2632 #define CONS_INDEX(fptr) \
2633 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2637 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2638 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2639 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2640 struct cons_block
*next
;
2643 #define CONS_MARKED_P(fptr) \
2644 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2646 #define CONS_MARK(fptr) \
2647 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2649 #define CONS_UNMARK(fptr) \
2650 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2652 /* Current cons_block. */
2654 struct cons_block
*cons_block
;
2656 /* Index of first unused Lisp_Cons in the current block. */
2658 int cons_block_index
;
2660 /* Free-list of Lisp_Cons structures. */
2662 struct Lisp_Cons
*cons_free_list
;
2664 /* Total number of cons blocks now in use. */
2669 /* Initialize cons allocation. */
2675 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2681 /* Explicitly free a cons cell by putting it on the free-list. */
2685 struct Lisp_Cons
*ptr
;
2687 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2691 cons_free_list
= ptr
;
2694 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2695 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2697 Lisp_Object car
, cdr
;
2699 register Lisp_Object val
;
2703 /* We use the cdr for chaining the free list
2704 so that we won't use the same field that has the mark bit. */
2705 XSETCONS (val
, cons_free_list
);
2706 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2710 if (cons_block_index
== CONS_BLOCK_SIZE
)
2712 register struct cons_block
*new;
2713 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2715 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2716 new->next
= cons_block
;
2718 cons_block_index
= 0;
2721 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2727 eassert (!CONS_MARKED_P (XCONS (val
)));
2728 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2729 cons_cells_consed
++;
2733 /* Get an error now if there's any junk in the cons free list. */
2737 #ifdef GC_CHECK_CONS_LIST
2738 struct Lisp_Cons
*tail
= cons_free_list
;
2741 tail
= *(struct Lisp_Cons
**)&tail
->cdr
;
2745 /* Make a list of 2, 3, 4 or 5 specified objects. */
2749 Lisp_Object arg1
, arg2
;
2751 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2756 list3 (arg1
, arg2
, arg3
)
2757 Lisp_Object arg1
, arg2
, arg3
;
2759 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2764 list4 (arg1
, arg2
, arg3
, arg4
)
2765 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2767 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2772 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2773 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2775 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2776 Fcons (arg5
, Qnil
)))));
2780 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2781 doc
: /* Return a newly created list with specified arguments as elements.
2782 Any number of arguments, even zero arguments, are allowed.
2783 usage: (list &rest OBJECTS) */)
2786 register Lisp_Object
*args
;
2788 register Lisp_Object val
;
2794 val
= Fcons (args
[nargs
], val
);
2800 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2801 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2803 register Lisp_Object length
, init
;
2805 register Lisp_Object val
;
2808 CHECK_NATNUM (length
);
2809 size
= XFASTINT (length
);
2814 val
= Fcons (init
, val
);
2819 val
= Fcons (init
, val
);
2824 val
= Fcons (init
, val
);
2829 val
= Fcons (init
, val
);
2834 val
= Fcons (init
, val
);
2849 /***********************************************************************
2851 ***********************************************************************/
2853 /* Singly-linked list of all vectors. */
2855 struct Lisp_Vector
*all_vectors
;
2857 /* Total number of vector-like objects now in use. */
2862 /* Value is a pointer to a newly allocated Lisp_Vector structure
2863 with room for LEN Lisp_Objects. */
2865 static struct Lisp_Vector
*
2866 allocate_vectorlike (len
, type
)
2870 struct Lisp_Vector
*p
;
2873 #ifdef DOUG_LEA_MALLOC
2874 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2875 because mapped region contents are not preserved in
2878 mallopt (M_MMAP_MAX
, 0);
2882 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2883 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2885 #ifdef DOUG_LEA_MALLOC
2886 /* Back to a reasonable maximum of mmap'ed areas. */
2888 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2892 consing_since_gc
+= nbytes
;
2893 vector_cells_consed
+= len
;
2895 p
->next
= all_vectors
;
2902 /* Allocate a vector with NSLOTS slots. */
2904 struct Lisp_Vector
*
2905 allocate_vector (nslots
)
2908 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2914 /* Allocate other vector-like structures. */
2916 struct Lisp_Hash_Table
*
2917 allocate_hash_table ()
2919 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2920 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2924 for (i
= 0; i
< len
; ++i
)
2925 v
->contents
[i
] = Qnil
;
2927 return (struct Lisp_Hash_Table
*) v
;
2934 EMACS_INT len
= VECSIZE (struct window
);
2935 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2938 for (i
= 0; i
< len
; ++i
)
2939 v
->contents
[i
] = Qnil
;
2942 return (struct window
*) v
;
2949 EMACS_INT len
= VECSIZE (struct frame
);
2950 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2953 for (i
= 0; i
< len
; ++i
)
2954 v
->contents
[i
] = make_number (0);
2956 return (struct frame
*) v
;
2960 struct Lisp_Process
*
2963 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2964 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2967 for (i
= 0; i
< len
; ++i
)
2968 v
->contents
[i
] = Qnil
;
2971 return (struct Lisp_Process
*) v
;
2975 struct Lisp_Vector
*
2976 allocate_other_vector (len
)
2979 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2982 for (i
= 0; i
< len
; ++i
)
2983 v
->contents
[i
] = Qnil
;
2990 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2991 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2992 See also the function `vector'. */)
2994 register Lisp_Object length
, init
;
2997 register EMACS_INT sizei
;
2999 register struct Lisp_Vector
*p
;
3001 CHECK_NATNUM (length
);
3002 sizei
= XFASTINT (length
);
3004 p
= allocate_vector (sizei
);
3005 for (index
= 0; index
< sizei
; index
++)
3006 p
->contents
[index
] = init
;
3008 XSETVECTOR (vector
, p
);
3013 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
3014 doc
: /* Return a newly created char-table, with purpose PURPOSE.
3015 Each element is initialized to INIT, which defaults to nil.
3016 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
3017 The property's value should be an integer between 0 and 10. */)
3019 register Lisp_Object purpose
, init
;
3023 CHECK_SYMBOL (purpose
);
3024 n
= Fget (purpose
, Qchar_table_extra_slots
);
3026 if (XINT (n
) < 0 || XINT (n
) > 10)
3027 args_out_of_range (n
, Qnil
);
3028 /* Add 2 to the size for the defalt and parent slots. */
3029 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
3031 XCHAR_TABLE (vector
)->top
= Qt
;
3032 XCHAR_TABLE (vector
)->parent
= Qnil
;
3033 XCHAR_TABLE (vector
)->purpose
= purpose
;
3034 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3039 /* Return a newly created sub char table with slots initialized by INIT.
3040 Since a sub char table does not appear as a top level Emacs Lisp
3041 object, we don't need a Lisp interface to make it. */
3044 make_sub_char_table (init
)
3048 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), init
);
3049 XCHAR_TABLE (vector
)->top
= Qnil
;
3050 XCHAR_TABLE (vector
)->defalt
= Qnil
;
3051 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
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) */)
3064 register Lisp_Object len
, val
;
3066 register struct Lisp_Vector
*p
;
3068 XSETFASTINT (len
, nargs
);
3069 val
= Fmake_vector (len
, Qnil
);
3071 for (index
= 0; index
< nargs
; index
++)
3072 p
->contents
[index
] = args
[index
];
3077 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3078 doc
: /* Create a byte-code object with specified arguments as elements.
3079 The arguments should be the arglist, bytecode-string, constant vector,
3080 stack size, (optional) doc string, and (optional) interactive spec.
3081 The first four arguments are required; at most six have any
3083 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3088 register Lisp_Object len
, val
;
3090 register struct Lisp_Vector
*p
;
3092 XSETFASTINT (len
, nargs
);
3093 if (!NILP (Vpurify_flag
))
3094 val
= make_pure_vector ((EMACS_INT
) nargs
);
3096 val
= Fmake_vector (len
, Qnil
);
3098 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3099 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3100 earlier because they produced a raw 8-bit string for byte-code
3101 and now such a byte-code string is loaded as multibyte while
3102 raw 8-bit characters converted to multibyte form. Thus, now we
3103 must convert them back to the original unibyte form. */
3104 args
[1] = Fstring_as_unibyte (args
[1]);
3107 for (index
= 0; index
< nargs
; index
++)
3109 if (!NILP (Vpurify_flag
))
3110 args
[index
] = Fpurecopy (args
[index
]);
3111 p
->contents
[index
] = args
[index
];
3113 XSETCOMPILED (val
, p
);
3119 /***********************************************************************
3121 ***********************************************************************/
3123 /* Each symbol_block is just under 1020 bytes long, since malloc
3124 really allocates in units of powers of two and uses 4 bytes for its
3127 #define SYMBOL_BLOCK_SIZE \
3128 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3132 /* Place `symbols' first, to preserve alignment. */
3133 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3134 struct symbol_block
*next
;
3137 /* Current symbol block and index of first unused Lisp_Symbol
3140 struct symbol_block
*symbol_block
;
3141 int symbol_block_index
;
3143 /* List of free symbols. */
3145 struct Lisp_Symbol
*symbol_free_list
;
3147 /* Total number of symbol blocks now in use. */
3149 int n_symbol_blocks
;
3152 /* Initialize symbol allocation. */
3157 symbol_block
= NULL
;
3158 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3159 symbol_free_list
= 0;
3160 n_symbol_blocks
= 0;
3164 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3165 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3166 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 if (symbol_free_list
)
3177 XSETSYMBOL (val
, symbol_free_list
);
3178 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
3182 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3184 struct symbol_block
*new;
3185 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3187 new->next
= symbol_block
;
3189 symbol_block_index
= 0;
3192 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3193 symbol_block_index
++;
3199 p
->value
= Qunbound
;
3200 p
->function
= Qunbound
;
3203 p
->interned
= SYMBOL_UNINTERNED
;
3205 p
->indirect_variable
= 0;
3206 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3213 /***********************************************************************
3214 Marker (Misc) Allocation
3215 ***********************************************************************/
3217 /* Allocation of markers and other objects that share that structure.
3218 Works like allocation of conses. */
3220 #define MARKER_BLOCK_SIZE \
3221 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3225 /* Place `markers' first, to preserve alignment. */
3226 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3227 struct marker_block
*next
;
3230 struct marker_block
*marker_block
;
3231 int marker_block_index
;
3233 union Lisp_Misc
*marker_free_list
;
3235 /* Total number of marker blocks now in use. */
3237 int n_marker_blocks
;
3242 marker_block
= NULL
;
3243 marker_block_index
= MARKER_BLOCK_SIZE
;
3244 marker_free_list
= 0;
3245 n_marker_blocks
= 0;
3248 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3255 if (marker_free_list
)
3257 XSETMISC (val
, marker_free_list
);
3258 marker_free_list
= marker_free_list
->u_free
.chain
;
3262 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3264 struct marker_block
*new;
3265 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3267 new->next
= marker_block
;
3269 marker_block_index
= 0;
3271 total_free_markers
+= MARKER_BLOCK_SIZE
;
3273 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3274 marker_block_index
++;
3277 --total_free_markers
;
3278 consing_since_gc
+= sizeof (union Lisp_Misc
);
3279 misc_objects_consed
++;
3280 XMARKER (val
)->gcmarkbit
= 0;
3284 /* Free a Lisp_Misc object */
3290 XMISC (misc
)->u_marker
.type
= Lisp_Misc_Free
;
3291 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3292 marker_free_list
= XMISC (misc
);
3294 total_free_markers
++;
3297 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3298 INTEGER. This is used to package C values to call record_unwind_protect.
3299 The unwind function can get the C values back using XSAVE_VALUE. */
3302 make_save_value (pointer
, integer
)
3306 register Lisp_Object val
;
3307 register struct Lisp_Save_Value
*p
;
3309 val
= allocate_misc ();
3310 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3311 p
= XSAVE_VALUE (val
);
3312 p
->pointer
= pointer
;
3313 p
->integer
= integer
;
3318 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3319 doc
: /* Return a newly allocated marker which does not point at any place. */)
3322 register Lisp_Object val
;
3323 register struct Lisp_Marker
*p
;
3325 val
= allocate_misc ();
3326 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3332 p
->insertion_type
= 0;
3336 /* Put MARKER back on the free list after using it temporarily. */
3339 free_marker (marker
)
3342 unchain_marker (XMARKER (marker
));
3347 /* Return a newly created vector or string with specified arguments as
3348 elements. If all the arguments are characters that can fit
3349 in a string of events, make a string; otherwise, make a vector.
3351 Any number of arguments, even zero arguments, are allowed. */
3354 make_event_array (nargs
, 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 || (XUINT (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 /************************************************************************
3390 ************************************************************************/
3392 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3394 /* Conservative C stack marking requires a method to identify possibly
3395 live Lisp objects given a pointer value. We do this by keeping
3396 track of blocks of Lisp data that are allocated in a red-black tree
3397 (see also the comment of mem_node which is the type of nodes in
3398 that tree). Function lisp_malloc adds information for an allocated
3399 block to the red-black tree with calls to mem_insert, and function
3400 lisp_free removes it with mem_delete. Functions live_string_p etc
3401 call mem_find to lookup information about a given pointer in the
3402 tree, and use that to determine if the pointer points to a Lisp
3405 /* Initialize this part of alloc.c. */
3410 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3411 mem_z
.parent
= NULL
;
3412 mem_z
.color
= MEM_BLACK
;
3413 mem_z
.start
= mem_z
.end
= NULL
;
3418 /* Value is a pointer to the mem_node containing START. Value is
3419 MEM_NIL if there is no node in the tree containing START. */
3421 static INLINE
struct mem_node
*
3427 if (start
< min_heap_address
|| start
> max_heap_address
)
3430 /* Make the search always successful to speed up the loop below. */
3431 mem_z
.start
= start
;
3432 mem_z
.end
= (char *) start
+ 1;
3435 while (start
< p
->start
|| start
>= p
->end
)
3436 p
= start
< p
->start
? p
->left
: p
->right
;
3441 /* Insert a new node into the tree for a block of memory with start
3442 address START, end address END, and type TYPE. Value is a
3443 pointer to the node that was inserted. */
3445 static struct mem_node
*
3446 mem_insert (start
, end
, type
)
3450 struct mem_node
*c
, *parent
, *x
;
3452 if (start
< min_heap_address
)
3453 min_heap_address
= start
;
3454 if (end
> max_heap_address
)
3455 max_heap_address
= end
;
3457 /* See where in the tree a node for START belongs. In this
3458 particular application, it shouldn't happen that a node is already
3459 present. For debugging purposes, let's check that. */
3463 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3465 while (c
!= MEM_NIL
)
3467 if (start
>= c
->start
&& start
< c
->end
)
3470 c
= start
< c
->start
? c
->left
: c
->right
;
3473 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3475 while (c
!= MEM_NIL
)
3478 c
= start
< c
->start
? c
->left
: c
->right
;
3481 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3483 /* Create a new node. */
3484 #ifdef GC_MALLOC_CHECK
3485 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3489 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3495 x
->left
= x
->right
= MEM_NIL
;
3498 /* Insert it as child of PARENT or install it as root. */
3501 if (start
< parent
->start
)
3509 /* Re-establish red-black tree properties. */
3510 mem_insert_fixup (x
);
3516 /* Re-establish the red-black properties of the tree, and thereby
3517 balance the tree, after node X has been inserted; X is always red. */
3520 mem_insert_fixup (x
)
3523 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3525 /* X is red and its parent is red. This is a violation of
3526 red-black tree property #3. */
3528 if (x
->parent
== x
->parent
->parent
->left
)
3530 /* We're on the left side of our grandparent, and Y is our
3532 struct mem_node
*y
= x
->parent
->parent
->right
;
3534 if (y
->color
== MEM_RED
)
3536 /* Uncle and parent are red but should be black because
3537 X is red. Change the colors accordingly and proceed
3538 with the grandparent. */
3539 x
->parent
->color
= MEM_BLACK
;
3540 y
->color
= MEM_BLACK
;
3541 x
->parent
->parent
->color
= MEM_RED
;
3542 x
= x
->parent
->parent
;
3546 /* Parent and uncle have different colors; parent is
3547 red, uncle is black. */
3548 if (x
== x
->parent
->right
)
3551 mem_rotate_left (x
);
3554 x
->parent
->color
= MEM_BLACK
;
3555 x
->parent
->parent
->color
= MEM_RED
;
3556 mem_rotate_right (x
->parent
->parent
);
3561 /* This is the symmetrical case of above. */
3562 struct mem_node
*y
= x
->parent
->parent
->left
;
3564 if (y
->color
== MEM_RED
)
3566 x
->parent
->color
= MEM_BLACK
;
3567 y
->color
= MEM_BLACK
;
3568 x
->parent
->parent
->color
= MEM_RED
;
3569 x
= x
->parent
->parent
;
3573 if (x
== x
->parent
->left
)
3576 mem_rotate_right (x
);
3579 x
->parent
->color
= MEM_BLACK
;
3580 x
->parent
->parent
->color
= MEM_RED
;
3581 mem_rotate_left (x
->parent
->parent
);
3586 /* The root may have been changed to red due to the algorithm. Set
3587 it to black so that property #5 is satisfied. */
3588 mem_root
->color
= MEM_BLACK
;
3604 /* Turn y's left sub-tree into x's right sub-tree. */
3607 if (y
->left
!= MEM_NIL
)
3608 y
->left
->parent
= x
;
3610 /* Y's parent was x's parent. */
3612 y
->parent
= x
->parent
;
3614 /* Get the parent to point to y instead of x. */
3617 if (x
== x
->parent
->left
)
3618 x
->parent
->left
= y
;
3620 x
->parent
->right
= y
;
3625 /* Put x on y's left. */
3639 mem_rotate_right (x
)
3642 struct mem_node
*y
= x
->left
;
3645 if (y
->right
!= MEM_NIL
)
3646 y
->right
->parent
= x
;
3649 y
->parent
= x
->parent
;
3652 if (x
== x
->parent
->right
)
3653 x
->parent
->right
= y
;
3655 x
->parent
->left
= y
;
3666 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3672 struct mem_node
*x
, *y
;
3674 if (!z
|| z
== MEM_NIL
)
3677 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3682 while (y
->left
!= MEM_NIL
)
3686 if (y
->left
!= MEM_NIL
)
3691 x
->parent
= y
->parent
;
3694 if (y
== y
->parent
->left
)
3695 y
->parent
->left
= x
;
3697 y
->parent
->right
= x
;
3704 z
->start
= y
->start
;
3709 if (y
->color
== MEM_BLACK
)
3710 mem_delete_fixup (x
);
3712 #ifdef GC_MALLOC_CHECK
3720 /* Re-establish the red-black properties of the tree, after a
3724 mem_delete_fixup (x
)
3727 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3729 if (x
== x
->parent
->left
)
3731 struct mem_node
*w
= x
->parent
->right
;
3733 if (w
->color
== MEM_RED
)
3735 w
->color
= MEM_BLACK
;
3736 x
->parent
->color
= MEM_RED
;
3737 mem_rotate_left (x
->parent
);
3738 w
= x
->parent
->right
;
3741 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3748 if (w
->right
->color
== MEM_BLACK
)
3750 w
->left
->color
= MEM_BLACK
;
3752 mem_rotate_right (w
);
3753 w
= x
->parent
->right
;
3755 w
->color
= x
->parent
->color
;
3756 x
->parent
->color
= MEM_BLACK
;
3757 w
->right
->color
= MEM_BLACK
;
3758 mem_rotate_left (x
->parent
);
3764 struct mem_node
*w
= x
->parent
->left
;
3766 if (w
->color
== MEM_RED
)
3768 w
->color
= MEM_BLACK
;
3769 x
->parent
->color
= MEM_RED
;
3770 mem_rotate_right (x
->parent
);
3771 w
= x
->parent
->left
;
3774 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3781 if (w
->left
->color
== MEM_BLACK
)
3783 w
->right
->color
= MEM_BLACK
;
3785 mem_rotate_left (w
);
3786 w
= x
->parent
->left
;
3789 w
->color
= x
->parent
->color
;
3790 x
->parent
->color
= MEM_BLACK
;
3791 w
->left
->color
= MEM_BLACK
;
3792 mem_rotate_right (x
->parent
);
3798 x
->color
= MEM_BLACK
;
3802 /* Value is non-zero if P is a pointer to a live Lisp string on
3803 the heap. M is a pointer to the mem_block for P. */
3806 live_string_p (m
, p
)
3810 if (m
->type
== MEM_TYPE_STRING
)
3812 struct string_block
*b
= (struct string_block
*) m
->start
;
3813 int offset
= (char *) p
- (char *) &b
->strings
[0];
3815 /* P must point to the start of a Lisp_String structure, and it
3816 must not be on the free-list. */
3818 && offset
% sizeof b
->strings
[0] == 0
3819 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3820 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3827 /* Value is non-zero if P is a pointer to a live Lisp cons on
3828 the heap. M is a pointer to the mem_block for P. */
3835 if (m
->type
== MEM_TYPE_CONS
)
3837 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3838 int offset
= (char *) p
- (char *) &b
->conses
[0];
3840 /* P must point to the start of a Lisp_Cons, not be
3841 one of the unused cells in the current cons block,
3842 and not be on the free-list. */
3844 && offset
% sizeof b
->conses
[0] == 0
3845 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3847 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3848 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3855 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3856 the heap. M is a pointer to the mem_block for P. */
3859 live_symbol_p (m
, p
)
3863 if (m
->type
== MEM_TYPE_SYMBOL
)
3865 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3866 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3868 /* P must point to the start of a Lisp_Symbol, not be
3869 one of the unused cells in the current symbol block,
3870 and not be on the free-list. */
3872 && offset
% sizeof b
->symbols
[0] == 0
3873 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3874 && (b
!= symbol_block
3875 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3876 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3883 /* Value is non-zero if P is a pointer to a live Lisp float on
3884 the heap. M is a pointer to the mem_block for P. */
3891 if (m
->type
== MEM_TYPE_FLOAT
)
3893 struct float_block
*b
= (struct float_block
*) m
->start
;
3894 int offset
= (char *) p
- (char *) &b
->floats
[0];
3896 /* P must point to the start of a Lisp_Float and not be
3897 one of the unused cells in the current float block. */
3899 && offset
% sizeof b
->floats
[0] == 0
3900 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3901 && (b
!= float_block
3902 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3909 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3910 the heap. M is a pointer to the mem_block for P. */
3917 if (m
->type
== MEM_TYPE_MISC
)
3919 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3920 int offset
= (char *) p
- (char *) &b
->markers
[0];
3922 /* P must point to the start of a Lisp_Misc, not be
3923 one of the unused cells in the current misc block,
3924 and not be on the free-list. */
3926 && offset
% sizeof b
->markers
[0] == 0
3927 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3928 && (b
!= marker_block
3929 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3930 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3937 /* Value is non-zero if P is a pointer to a live vector-like object.
3938 M is a pointer to the mem_block for P. */
3941 live_vector_p (m
, p
)
3945 return (p
== m
->start
3946 && m
->type
>= MEM_TYPE_VECTOR
3947 && m
->type
<= MEM_TYPE_WINDOW
);
3951 /* Value is non-zero if P is a pointer to a live buffer. M is a
3952 pointer to the mem_block for P. */
3955 live_buffer_p (m
, p
)
3959 /* P must point to the start of the block, and the buffer
3960 must not have been killed. */
3961 return (m
->type
== MEM_TYPE_BUFFER
3963 && !NILP (((struct buffer
*) p
)->name
));
3966 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3970 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3972 /* Array of objects that are kept alive because the C stack contains
3973 a pattern that looks like a reference to them . */
3975 #define MAX_ZOMBIES 10
3976 static Lisp_Object zombies
[MAX_ZOMBIES
];
3978 /* Number of zombie objects. */
3980 static int nzombies
;
3982 /* Number of garbage collections. */
3986 /* Average percentage of zombies per collection. */
3988 static double avg_zombies
;
3990 /* Max. number of live and zombie objects. */
3992 static int max_live
, max_zombies
;
3994 /* Average number of live objects per GC. */
3996 static double avg_live
;
3998 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3999 doc
: /* Show information about live and zombie objects. */)
4002 Lisp_Object args
[8], zombie_list
= Qnil
;
4004 for (i
= 0; i
< nzombies
; i
++)
4005 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4006 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4007 args
[1] = make_number (ngcs
);
4008 args
[2] = make_float (avg_live
);
4009 args
[3] = make_float (avg_zombies
);
4010 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4011 args
[5] = make_number (max_live
);
4012 args
[6] = make_number (max_zombies
);
4013 args
[7] = zombie_list
;
4014 return Fmessage (8, args
);
4017 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4020 /* Mark OBJ if we can prove it's a Lisp_Object. */
4023 mark_maybe_object (obj
)
4026 void *po
= (void *) XPNTR (obj
);
4027 struct mem_node
*m
= mem_find (po
);
4033 switch (XGCTYPE (obj
))
4036 mark_p
= (live_string_p (m
, po
)
4037 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4041 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4045 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4049 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4052 case Lisp_Vectorlike
:
4053 /* Note: can't check GC_BUFFERP before we know it's a
4054 buffer because checking that dereferences the pointer
4055 PO which might point anywhere. */
4056 if (live_vector_p (m
, po
))
4057 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4058 else if (live_buffer_p (m
, po
))
4059 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4063 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
4067 case Lisp_Type_Limit
:
4073 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4074 if (nzombies
< MAX_ZOMBIES
)
4075 zombies
[nzombies
] = obj
;
4084 /* If P points to Lisp data, mark that as live if it isn't already
4088 mark_maybe_pointer (p
)
4093 /* Quickly rule out some values which can't point to Lisp data. We
4094 assume that Lisp data is aligned on even addresses. */
4095 if ((EMACS_INT
) p
& 1)
4101 Lisp_Object obj
= Qnil
;
4105 case MEM_TYPE_NON_LISP
:
4106 /* Nothing to do; not a pointer to Lisp memory. */
4109 case MEM_TYPE_BUFFER
:
4110 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4111 XSETVECTOR (obj
, p
);
4115 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4119 case MEM_TYPE_STRING
:
4120 if (live_string_p (m
, p
)
4121 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4122 XSETSTRING (obj
, p
);
4126 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4130 case MEM_TYPE_SYMBOL
:
4131 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4132 XSETSYMBOL (obj
, p
);
4135 case MEM_TYPE_FLOAT
:
4136 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4140 case MEM_TYPE_VECTOR
:
4141 case MEM_TYPE_PROCESS
:
4142 case MEM_TYPE_HASH_TABLE
:
4143 case MEM_TYPE_FRAME
:
4144 case MEM_TYPE_WINDOW
:
4145 if (live_vector_p (m
, p
))
4148 XSETVECTOR (tem
, p
);
4149 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4164 /* Mark Lisp objects referenced from the address range START..END. */
4167 mark_memory (start
, end
)
4173 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4177 /* Make START the pointer to the start of the memory region,
4178 if it isn't already. */
4186 /* Mark Lisp_Objects. */
4187 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
4188 mark_maybe_object (*p
);
4190 /* Mark Lisp data pointed to. This is necessary because, in some
4191 situations, the C compiler optimizes Lisp objects away, so that
4192 only a pointer to them remains. Example:
4194 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4197 Lisp_Object obj = build_string ("test");
4198 struct Lisp_String *s = XSTRING (obj);
4199 Fgarbage_collect ();
4200 fprintf (stderr, "test `%s'\n", s->data);
4204 Here, `obj' isn't really used, and the compiler optimizes it
4205 away. The only reference to the life string is through the
4208 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
4209 mark_maybe_pointer (*pp
);
4212 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4213 the GCC system configuration. In gcc 3.2, the only systems for
4214 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4215 by others?) and ns32k-pc532-min. */
4217 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4219 static int setjmp_tested_p
, longjmps_done
;
4221 #define SETJMP_WILL_LIKELY_WORK "\
4223 Emacs garbage collector has been changed to use conservative stack\n\
4224 marking. Emacs has determined that the method it uses to do the\n\
4225 marking will likely work on your system, but this isn't sure.\n\
4227 If you are a system-programmer, or can get the help of a local wizard\n\
4228 who is, please take a look at the function mark_stack in alloc.c, and\n\
4229 verify that the methods used are appropriate for your system.\n\
4231 Please mail the result to <emacs-devel@gnu.org>.\n\
4234 #define SETJMP_WILL_NOT_WORK "\
4236 Emacs garbage collector has been changed to use conservative stack\n\
4237 marking. Emacs has determined that the default method it uses to do the\n\
4238 marking will not work on your system. We will need a system-dependent\n\
4239 solution for your system.\n\
4241 Please take a look at the function mark_stack in alloc.c, and\n\
4242 try to find a way to make it work on your system.\n\
4244 Note that you may get false negatives, depending on the compiler.\n\
4245 In particular, you need to use -O with GCC for this test.\n\
4247 Please mail the result to <emacs-devel@gnu.org>.\n\
4251 /* Perform a quick check if it looks like setjmp saves registers in a
4252 jmp_buf. Print a message to stderr saying so. When this test
4253 succeeds, this is _not_ a proof that setjmp is sufficient for
4254 conservative stack marking. Only the sources or a disassembly
4265 /* Arrange for X to be put in a register. */
4271 if (longjmps_done
== 1)
4273 /* Came here after the longjmp at the end of the function.
4275 If x == 1, the longjmp has restored the register to its
4276 value before the setjmp, and we can hope that setjmp
4277 saves all such registers in the jmp_buf, although that
4280 For other values of X, either something really strange is
4281 taking place, or the setjmp just didn't save the register. */
4284 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4287 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4294 if (longjmps_done
== 1)
4298 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4301 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4303 /* Abort if anything GCPRO'd doesn't survive the GC. */
4311 for (p
= gcprolist
; p
; p
= p
->next
)
4312 for (i
= 0; i
< p
->nvars
; ++i
)
4313 if (!survives_gc_p (p
->var
[i
]))
4314 /* FIXME: It's not necessarily a bug. It might just be that the
4315 GCPRO is unnecessary or should release the object sooner. */
4319 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4326 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4327 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4329 fprintf (stderr
, " %d = ", i
);
4330 debug_print (zombies
[i
]);
4334 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4337 /* Mark live Lisp objects on the C stack.
4339 There are several system-dependent problems to consider when
4340 porting this to new architectures:
4344 We have to mark Lisp objects in CPU registers that can hold local
4345 variables or are used to pass parameters.
4347 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4348 something that either saves relevant registers on the stack, or
4349 calls mark_maybe_object passing it each register's contents.
4351 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4352 implementation assumes that calling setjmp saves registers we need
4353 to see in a jmp_buf which itself lies on the stack. This doesn't
4354 have to be true! It must be verified for each system, possibly
4355 by taking a look at the source code of setjmp.
4359 Architectures differ in the way their processor stack is organized.
4360 For example, the stack might look like this
4363 | Lisp_Object | size = 4
4365 | something else | size = 2
4367 | Lisp_Object | size = 4
4371 In such a case, not every Lisp_Object will be aligned equally. To
4372 find all Lisp_Object on the stack it won't be sufficient to walk
4373 the stack in steps of 4 bytes. Instead, two passes will be
4374 necessary, one starting at the start of the stack, and a second
4375 pass starting at the start of the stack + 2. Likewise, if the
4376 minimal alignment of Lisp_Objects on the stack is 1, four passes
4377 would be necessary, each one starting with one byte more offset
4378 from the stack start.
4380 The current code assumes by default that Lisp_Objects are aligned
4381 equally on the stack. */
4388 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4391 /* This trick flushes the register windows so that all the state of
4392 the process is contained in the stack. */
4393 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4394 needed on ia64 too. See mach_dep.c, where it also says inline
4395 assembler doesn't work with relevant proprietary compilers. */
4400 /* Save registers that we need to see on the stack. We need to see
4401 registers used to hold register variables and registers used to
4403 #ifdef GC_SAVE_REGISTERS_ON_STACK
4404 GC_SAVE_REGISTERS_ON_STACK (end
);
4405 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4407 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4408 setjmp will definitely work, test it
4409 and print a message with the result
4411 if (!setjmp_tested_p
)
4413 setjmp_tested_p
= 1;
4416 #endif /* GC_SETJMP_WORKS */
4419 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4420 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4422 /* This assumes that the stack is a contiguous region in memory. If
4423 that's not the case, something has to be done here to iterate
4424 over the stack segments. */
4425 #ifndef GC_LISP_OBJECT_ALIGNMENT
4427 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4429 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4432 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4433 mark_memory ((char *) stack_base
+ i
, end
);
4434 /* Allow for marking a secondary stack, like the register stack on the
4436 #ifdef GC_MARK_SECONDARY_STACK
4437 GC_MARK_SECONDARY_STACK ();
4440 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4446 #endif /* GC_MARK_STACK != 0 */
4450 /***********************************************************************
4451 Pure Storage Management
4452 ***********************************************************************/
4454 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4455 pointer to it. TYPE is the Lisp type for which the memory is
4456 allocated. TYPE < 0 means it's not used for a Lisp object.
4458 If store_pure_type_info is set and TYPE is >= 0, the type of
4459 the allocated object is recorded in pure_types. */
4461 static POINTER_TYPE
*
4462 pure_alloc (size
, type
)
4466 POINTER_TYPE
*result
;
4468 size_t alignment
= (1 << GCTYPEBITS
);
4470 size_t alignment
= sizeof (EMACS_INT
);
4472 /* Give Lisp_Floats an extra alignment. */
4473 if (type
== Lisp_Float
)
4475 #if defined __GNUC__ && __GNUC__ >= 2
4476 alignment
= __alignof (struct Lisp_Float
);
4478 alignment
= sizeof (struct Lisp_Float
);
4484 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4485 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4487 if (pure_bytes_used
<= pure_size
)
4490 /* Don't allocate a large amount here,
4491 because it might get mmap'd and then its address
4492 might not be usable. */
4493 purebeg
= (char *) xmalloc (10000);
4495 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4496 pure_bytes_used
= 0;
4501 /* Print a warning if PURESIZE is too small. */
4506 if (pure_bytes_used_before_overflow
)
4507 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4508 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4512 /* Return a string allocated in pure space. DATA is a buffer holding
4513 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4514 non-zero means make the result string multibyte.
4516 Must get an error if pure storage is full, since if it cannot hold
4517 a large string it may be able to hold conses that point to that
4518 string; then the string is not protected from gc. */
4521 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4527 struct Lisp_String
*s
;
4529 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4530 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4532 s
->size_byte
= multibyte
? nbytes
: -1;
4533 bcopy (data
, s
->data
, nbytes
);
4534 s
->data
[nbytes
] = '\0';
4535 s
->intervals
= NULL_INTERVAL
;
4536 XSETSTRING (string
, s
);
4541 /* Return a cons allocated from pure space. Give it pure copies
4542 of CAR as car and CDR as cdr. */
4545 pure_cons (car
, cdr
)
4546 Lisp_Object car
, cdr
;
4548 register Lisp_Object
new;
4549 struct Lisp_Cons
*p
;
4551 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4553 XSETCAR (new, Fpurecopy (car
));
4554 XSETCDR (new, Fpurecopy (cdr
));
4559 /* Value is a float object with value NUM allocated from pure space. */
4562 make_pure_float (num
)
4565 register Lisp_Object
new;
4566 struct Lisp_Float
*p
;
4568 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4570 XFLOAT_DATA (new) = num
;
4575 /* Return a vector with room for LEN Lisp_Objects allocated from
4579 make_pure_vector (len
)
4583 struct Lisp_Vector
*p
;
4584 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4586 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4587 XSETVECTOR (new, p
);
4588 XVECTOR (new)->size
= len
;
4593 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4594 doc
: /* Make a copy of OBJECT in pure storage.
4595 Recursively copies contents of vectors and cons cells.
4596 Does not copy symbols. Copies strings without text properties. */)
4598 register Lisp_Object obj
;
4600 if (NILP (Vpurify_flag
))
4603 if (PURE_POINTER_P (XPNTR (obj
)))
4607 return pure_cons (XCAR (obj
), XCDR (obj
));
4608 else if (FLOATP (obj
))
4609 return make_pure_float (XFLOAT_DATA (obj
));
4610 else if (STRINGP (obj
))
4611 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4613 STRING_MULTIBYTE (obj
));
4614 else if (COMPILEDP (obj
) || VECTORP (obj
))
4616 register struct Lisp_Vector
*vec
;
4620 size
= XVECTOR (obj
)->size
;
4621 if (size
& PSEUDOVECTOR_FLAG
)
4622 size
&= PSEUDOVECTOR_SIZE_MASK
;
4623 vec
= XVECTOR (make_pure_vector (size
));
4624 for (i
= 0; i
< size
; i
++)
4625 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4626 if (COMPILEDP (obj
))
4627 XSETCOMPILED (obj
, vec
);
4629 XSETVECTOR (obj
, vec
);
4632 else if (MARKERP (obj
))
4633 error ("Attempt to copy a marker to pure storage");
4640 /***********************************************************************
4642 ***********************************************************************/
4644 /* Put an entry in staticvec, pointing at the variable with address
4648 staticpro (varaddress
)
4649 Lisp_Object
*varaddress
;
4651 staticvec
[staticidx
++] = varaddress
;
4652 if (staticidx
>= NSTATICS
)
4660 struct catchtag
*next
;
4664 /***********************************************************************
4666 ***********************************************************************/
4668 /* Temporarily prevent garbage collection. */
4671 inhibit_garbage_collection ()
4673 int count
= SPECPDL_INDEX ();
4674 int nbits
= min (VALBITS
, BITS_PER_INT
);
4676 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4681 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4682 doc
: /* Reclaim storage for Lisp objects no longer needed.
4683 Garbage collection happens automatically if you cons more than
4684 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4685 `garbage-collect' normally returns a list with info on amount of space in use:
4686 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4687 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4688 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4689 (USED-STRINGS . FREE-STRINGS))
4690 However, if there was overflow in pure space, `garbage-collect'
4691 returns nil, because real GC can't be done. */)
4694 register struct specbinding
*bind
;
4695 struct catchtag
*catch;
4696 struct handler
*handler
;
4697 char stack_top_variable
;
4700 Lisp_Object total
[8];
4701 int count
= SPECPDL_INDEX ();
4702 EMACS_TIME t1
, t2
, t3
;
4707 /* Can't GC if pure storage overflowed because we can't determine
4708 if something is a pure object or not. */
4709 if (pure_bytes_used_before_overflow
)
4714 /* Don't keep undo information around forever.
4715 Do this early on, so it is no problem if the user quits. */
4717 register struct buffer
*nextb
= all_buffers
;
4721 /* If a buffer's undo list is Qt, that means that undo is
4722 turned off in that buffer. Calling truncate_undo_list on
4723 Qt tends to return NULL, which effectively turns undo back on.
4724 So don't call truncate_undo_list if undo_list is Qt. */
4725 if (! NILP (nextb
->name
) && ! EQ (nextb
->undo_list
, Qt
))
4726 truncate_undo_list (nextb
);
4728 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4729 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4731 /* If a buffer's gap size is more than 10% of the buffer
4732 size, or larger than 2000 bytes, then shrink it
4733 accordingly. Keep a minimum size of 20 bytes. */
4734 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4736 if (nextb
->text
->gap_size
> size
)
4738 struct buffer
*save_current
= current_buffer
;
4739 current_buffer
= nextb
;
4740 make_gap (-(nextb
->text
->gap_size
- size
));
4741 current_buffer
= save_current
;
4745 nextb
= nextb
->next
;
4749 EMACS_GET_TIME (t1
);
4751 /* In case user calls debug_print during GC,
4752 don't let that cause a recursive GC. */
4753 consing_since_gc
= 0;
4755 /* Save what's currently displayed in the echo area. */
4756 message_p
= push_message ();
4757 record_unwind_protect (pop_message_unwind
, Qnil
);
4759 /* Save a copy of the contents of the stack, for debugging. */
4760 #if MAX_SAVE_STACK > 0
4761 if (NILP (Vpurify_flag
))
4763 i
= &stack_top_variable
- stack_bottom
;
4765 if (i
< MAX_SAVE_STACK
)
4767 if (stack_copy
== 0)
4768 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4769 else if (stack_copy_size
< i
)
4770 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4773 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4774 bcopy (stack_bottom
, stack_copy
, i
);
4776 bcopy (&stack_top_variable
, stack_copy
, i
);
4780 #endif /* MAX_SAVE_STACK > 0 */
4782 if (garbage_collection_messages
)
4783 message1_nolog ("Garbage collecting...");
4787 shrink_regexp_cache ();
4791 /* clear_marks (); */
4793 /* Mark all the special slots that serve as the roots of accessibility. */
4795 for (i
= 0; i
< staticidx
; i
++)
4796 mark_object (*staticvec
[i
]);
4798 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4800 mark_object (bind
->symbol
);
4801 mark_object (bind
->old_value
);
4807 extern void xg_mark_data ();
4812 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4813 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4817 register struct gcpro
*tail
;
4818 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4819 for (i
= 0; i
< tail
->nvars
; i
++)
4820 mark_object (tail
->var
[i
]);
4825 for (catch = catchlist
; catch; catch = catch->next
)
4827 mark_object (catch->tag
);
4828 mark_object (catch->val
);
4830 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4832 mark_object (handler
->handler
);
4833 mark_object (handler
->var
);
4837 #ifdef HAVE_WINDOW_SYSTEM
4838 mark_fringe_data ();
4841 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4845 /* Everything is now marked, except for the things that require special
4846 finalization, i.e. the undo_list.
4847 Look thru every buffer's undo list
4848 for elements that update markers that were not marked,
4851 register struct buffer
*nextb
= all_buffers
;
4855 /* If a buffer's undo list is Qt, that means that undo is
4856 turned off in that buffer. Calling truncate_undo_list on
4857 Qt tends to return NULL, which effectively turns undo back on.
4858 So don't call truncate_undo_list if undo_list is Qt. */
4859 if (! EQ (nextb
->undo_list
, Qt
))
4861 Lisp_Object tail
, prev
;
4862 tail
= nextb
->undo_list
;
4864 while (CONSP (tail
))
4866 if (GC_CONSP (XCAR (tail
))
4867 && GC_MARKERP (XCAR (XCAR (tail
)))
4868 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
4871 nextb
->undo_list
= tail
= XCDR (tail
);
4875 XSETCDR (prev
, tail
);
4885 /* Now that we have stripped the elements that need not be in the
4886 undo_list any more, we can finally mark the list. */
4887 mark_object (nextb
->undo_list
);
4889 nextb
= nextb
->next
;
4895 /* Clear the mark bits that we set in certain root slots. */
4897 unmark_byte_stack ();
4898 VECTOR_UNMARK (&buffer_defaults
);
4899 VECTOR_UNMARK (&buffer_local_symbols
);
4901 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4909 /* clear_marks (); */
4912 consing_since_gc
= 0;
4913 if (gc_cons_threshold
< 10000)
4914 gc_cons_threshold
= 10000;
4916 if (FLOATP (Vgc_cons_percentage
))
4917 { /* Set gc_cons_combined_threshold. */
4918 EMACS_INT total
= 0;
4920 total
+= total_conses
* sizeof (struct Lisp_Cons
);
4921 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
4922 total
+= total_markers
* sizeof (union Lisp_Misc
);
4923 total
+= total_string_size
;
4924 total
+= total_vector_size
* sizeof (Lisp_Object
);
4925 total
+= total_floats
* sizeof (struct Lisp_Float
);
4926 total
+= total_intervals
* sizeof (struct interval
);
4927 total
+= total_strings
* sizeof (struct Lisp_String
);
4929 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
4932 gc_relative_threshold
= 0;
4934 if (garbage_collection_messages
)
4936 if (message_p
|| minibuf_level
> 0)
4939 message1_nolog ("Garbage collecting...done");
4942 unbind_to (count
, Qnil
);
4944 total
[0] = Fcons (make_number (total_conses
),
4945 make_number (total_free_conses
));
4946 total
[1] = Fcons (make_number (total_symbols
),
4947 make_number (total_free_symbols
));
4948 total
[2] = Fcons (make_number (total_markers
),
4949 make_number (total_free_markers
));
4950 total
[3] = make_number (total_string_size
);
4951 total
[4] = make_number (total_vector_size
);
4952 total
[5] = Fcons (make_number (total_floats
),
4953 make_number (total_free_floats
));
4954 total
[6] = Fcons (make_number (total_intervals
),
4955 make_number (total_free_intervals
));
4956 total
[7] = Fcons (make_number (total_strings
),
4957 make_number (total_free_strings
));
4959 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4961 /* Compute average percentage of zombies. */
4964 for (i
= 0; i
< 7; ++i
)
4965 if (CONSP (total
[i
]))
4966 nlive
+= XFASTINT (XCAR (total
[i
]));
4968 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4969 max_live
= max (nlive
, max_live
);
4970 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4971 max_zombies
= max (nzombies
, max_zombies
);
4976 if (!NILP (Vpost_gc_hook
))
4978 int count
= inhibit_garbage_collection ();
4979 safe_run_hooks (Qpost_gc_hook
);
4980 unbind_to (count
, Qnil
);
4983 /* Accumulate statistics. */
4984 EMACS_GET_TIME (t2
);
4985 EMACS_SUB_TIME (t3
, t2
, t1
);
4986 if (FLOATP (Vgc_elapsed
))
4987 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
4989 EMACS_USECS (t3
) * 1.0e-6);
4992 return Flist (sizeof total
/ sizeof *total
, total
);
4996 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4997 only interesting objects referenced from glyphs are strings. */
5000 mark_glyph_matrix (matrix
)
5001 struct glyph_matrix
*matrix
;
5003 struct glyph_row
*row
= matrix
->rows
;
5004 struct glyph_row
*end
= row
+ matrix
->nrows
;
5006 for (; row
< end
; ++row
)
5010 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5012 struct glyph
*glyph
= row
->glyphs
[area
];
5013 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5015 for (; glyph
< end_glyph
; ++glyph
)
5016 if (GC_STRINGP (glyph
->object
)
5017 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5018 mark_object (glyph
->object
);
5024 /* Mark Lisp faces in the face cache C. */
5028 struct face_cache
*c
;
5033 for (i
= 0; i
< c
->used
; ++i
)
5035 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5039 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5040 mark_object (face
->lface
[j
]);
5047 #ifdef HAVE_WINDOW_SYSTEM
5049 /* Mark Lisp objects in image IMG. */
5055 mark_object (img
->spec
);
5057 if (!NILP (img
->data
.lisp_val
))
5058 mark_object (img
->data
.lisp_val
);
5062 /* Mark Lisp objects in image cache of frame F. It's done this way so
5063 that we don't have to include xterm.h here. */
5066 mark_image_cache (f
)
5069 forall_images_in_image_cache (f
, mark_image
);
5072 #endif /* HAVE_X_WINDOWS */
5076 /* Mark reference to a Lisp_Object.
5077 If the object referred to has not been seen yet, recursively mark
5078 all the references contained in it. */
5080 #define LAST_MARKED_SIZE 500
5081 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5082 int last_marked_index
;
5084 /* For debugging--call abort when we cdr down this many
5085 links of a list, in mark_object. In debugging,
5086 the call to abort will hit a breakpoint.
5087 Normally this is zero and the check never goes off. */
5088 int mark_object_loop_halt
;
5094 register Lisp_Object obj
= arg
;
5095 #ifdef GC_CHECK_MARKED_OBJECTS
5103 if (PURE_POINTER_P (XPNTR (obj
)))
5106 last_marked
[last_marked_index
++] = obj
;
5107 if (last_marked_index
== LAST_MARKED_SIZE
)
5108 last_marked_index
= 0;
5110 /* Perform some sanity checks on the objects marked here. Abort if
5111 we encounter an object we know is bogus. This increases GC time
5112 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5113 #ifdef GC_CHECK_MARKED_OBJECTS
5115 po
= (void *) XPNTR (obj
);
5117 /* Check that the object pointed to by PO is known to be a Lisp
5118 structure allocated from the heap. */
5119 #define CHECK_ALLOCATED() \
5121 m = mem_find (po); \
5126 /* Check that the object pointed to by PO is live, using predicate
5128 #define CHECK_LIVE(LIVEP) \
5130 if (!LIVEP (m, po)) \
5134 /* Check both of the above conditions. */
5135 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5137 CHECK_ALLOCATED (); \
5138 CHECK_LIVE (LIVEP); \
5141 #else /* not GC_CHECK_MARKED_OBJECTS */
5143 #define CHECK_ALLOCATED() (void) 0
5144 #define CHECK_LIVE(LIVEP) (void) 0
5145 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5147 #endif /* not GC_CHECK_MARKED_OBJECTS */
5149 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
5153 register struct Lisp_String
*ptr
= XSTRING (obj
);
5154 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5155 MARK_INTERVAL_TREE (ptr
->intervals
);
5157 #ifdef GC_CHECK_STRING_BYTES
5158 /* Check that the string size recorded in the string is the
5159 same as the one recorded in the sdata structure. */
5160 CHECK_STRING_BYTES (ptr
);
5161 #endif /* GC_CHECK_STRING_BYTES */
5165 case Lisp_Vectorlike
:
5166 #ifdef GC_CHECK_MARKED_OBJECTS
5168 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
5169 && po
!= &buffer_defaults
5170 && po
!= &buffer_local_symbols
)
5172 #endif /* GC_CHECK_MARKED_OBJECTS */
5174 if (GC_BUFFERP (obj
))
5176 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
5178 #ifdef GC_CHECK_MARKED_OBJECTS
5179 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5182 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5187 #endif /* GC_CHECK_MARKED_OBJECTS */
5191 else if (GC_SUBRP (obj
))
5193 else if (GC_COMPILEDP (obj
))
5194 /* We could treat this just like a vector, but it is better to
5195 save the COMPILED_CONSTANTS element for last and avoid
5198 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5199 register EMACS_INT size
= ptr
->size
;
5202 if (VECTOR_MARKED_P (ptr
))
5203 break; /* Already marked */
5205 CHECK_LIVE (live_vector_p
);
5206 VECTOR_MARK (ptr
); /* Else mark it */
5207 size
&= PSEUDOVECTOR_SIZE_MASK
;
5208 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5210 if (i
!= COMPILED_CONSTANTS
)
5211 mark_object (ptr
->contents
[i
]);
5213 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5216 else if (GC_FRAMEP (obj
))
5218 register struct frame
*ptr
= XFRAME (obj
);
5220 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5221 VECTOR_MARK (ptr
); /* Else mark it */
5223 CHECK_LIVE (live_vector_p
);
5224 mark_object (ptr
->name
);
5225 mark_object (ptr
->icon_name
);
5226 mark_object (ptr
->title
);
5227 mark_object (ptr
->focus_frame
);
5228 mark_object (ptr
->selected_window
);
5229 mark_object (ptr
->minibuffer_window
);
5230 mark_object (ptr
->param_alist
);
5231 mark_object (ptr
->scroll_bars
);
5232 mark_object (ptr
->condemned_scroll_bars
);
5233 mark_object (ptr
->menu_bar_items
);
5234 mark_object (ptr
->face_alist
);
5235 mark_object (ptr
->menu_bar_vector
);
5236 mark_object (ptr
->buffer_predicate
);
5237 mark_object (ptr
->buffer_list
);
5238 mark_object (ptr
->menu_bar_window
);
5239 mark_object (ptr
->tool_bar_window
);
5240 mark_face_cache (ptr
->face_cache
);
5241 #ifdef HAVE_WINDOW_SYSTEM
5242 mark_image_cache (ptr
);
5243 mark_object (ptr
->tool_bar_items
);
5244 mark_object (ptr
->desired_tool_bar_string
);
5245 mark_object (ptr
->current_tool_bar_string
);
5246 #endif /* HAVE_WINDOW_SYSTEM */
5248 else if (GC_BOOL_VECTOR_P (obj
))
5250 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5252 if (VECTOR_MARKED_P (ptr
))
5253 break; /* Already marked */
5254 CHECK_LIVE (live_vector_p
);
5255 VECTOR_MARK (ptr
); /* Else mark it */
5257 else if (GC_WINDOWP (obj
))
5259 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5260 struct window
*w
= XWINDOW (obj
);
5263 /* Stop if already marked. */
5264 if (VECTOR_MARKED_P (ptr
))
5268 CHECK_LIVE (live_vector_p
);
5271 /* There is no Lisp data above The member CURRENT_MATRIX in
5272 struct WINDOW. Stop marking when that slot is reached. */
5274 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
5276 mark_object (ptr
->contents
[i
]);
5278 /* Mark glyphs for leaf windows. Marking window matrices is
5279 sufficient because frame matrices use the same glyph
5281 if (NILP (w
->hchild
)
5283 && w
->current_matrix
)
5285 mark_glyph_matrix (w
->current_matrix
);
5286 mark_glyph_matrix (w
->desired_matrix
);
5289 else if (GC_HASH_TABLE_P (obj
))
5291 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5293 /* Stop if already marked. */
5294 if (VECTOR_MARKED_P (h
))
5298 CHECK_LIVE (live_vector_p
);
5301 /* Mark contents. */
5302 /* Do not mark next_free or next_weak.
5303 Being in the next_weak chain
5304 should not keep the hash table alive.
5305 No need to mark `count' since it is an integer. */
5306 mark_object (h
->test
);
5307 mark_object (h
->weak
);
5308 mark_object (h
->rehash_size
);
5309 mark_object (h
->rehash_threshold
);
5310 mark_object (h
->hash
);
5311 mark_object (h
->next
);
5312 mark_object (h
->index
);
5313 mark_object (h
->user_hash_function
);
5314 mark_object (h
->user_cmp_function
);
5316 /* If hash table is not weak, mark all keys and values.
5317 For weak tables, mark only the vector. */
5318 if (GC_NILP (h
->weak
))
5319 mark_object (h
->key_and_value
);
5321 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5325 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5326 register EMACS_INT size
= ptr
->size
;
5329 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5330 CHECK_LIVE (live_vector_p
);
5331 VECTOR_MARK (ptr
); /* Else mark it */
5332 if (size
& PSEUDOVECTOR_FLAG
)
5333 size
&= PSEUDOVECTOR_SIZE_MASK
;
5335 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5336 mark_object (ptr
->contents
[i
]);
5342 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5343 struct Lisp_Symbol
*ptrx
;
5345 if (ptr
->gcmarkbit
) break;
5346 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5348 mark_object (ptr
->value
);
5349 mark_object (ptr
->function
);
5350 mark_object (ptr
->plist
);
5352 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5353 MARK_STRING (XSTRING (ptr
->xname
));
5354 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5356 /* Note that we do not mark the obarray of the symbol.
5357 It is safe not to do so because nothing accesses that
5358 slot except to check whether it is nil. */
5362 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5363 XSETSYMBOL (obj
, ptrx
);
5370 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5371 if (XMARKER (obj
)->gcmarkbit
)
5373 XMARKER (obj
)->gcmarkbit
= 1;
5375 switch (XMISCTYPE (obj
))
5377 case Lisp_Misc_Buffer_Local_Value
:
5378 case Lisp_Misc_Some_Buffer_Local_Value
:
5380 register struct Lisp_Buffer_Local_Value
*ptr
5381 = XBUFFER_LOCAL_VALUE (obj
);
5382 /* If the cdr is nil, avoid recursion for the car. */
5383 if (EQ (ptr
->cdr
, Qnil
))
5385 obj
= ptr
->realvalue
;
5388 mark_object (ptr
->realvalue
);
5389 mark_object (ptr
->buffer
);
5390 mark_object (ptr
->frame
);
5395 case Lisp_Misc_Marker
:
5396 /* DO NOT mark thru the marker's chain.
5397 The buffer's markers chain does not preserve markers from gc;
5398 instead, markers are removed from the chain when freed by gc. */
5401 case Lisp_Misc_Intfwd
:
5402 case Lisp_Misc_Boolfwd
:
5403 case Lisp_Misc_Objfwd
:
5404 case Lisp_Misc_Buffer_Objfwd
:
5405 case Lisp_Misc_Kboard_Objfwd
:
5406 /* Don't bother with Lisp_Buffer_Objfwd,
5407 since all markable slots in current buffer marked anyway. */
5408 /* Don't need to do Lisp_Objfwd, since the places they point
5409 are protected with staticpro. */
5412 case Lisp_Misc_Save_Value
:
5415 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5416 /* If DOGC is set, POINTER is the address of a memory
5417 area containing INTEGER potential Lisp_Objects. */
5420 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5422 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5423 mark_maybe_object (*p
);
5429 case Lisp_Misc_Overlay
:
5431 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5432 mark_object (ptr
->start
);
5433 mark_object (ptr
->end
);
5434 mark_object (ptr
->plist
);
5437 XSETMISC (obj
, ptr
->next
);
5450 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5451 if (CONS_MARKED_P (ptr
)) break;
5452 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5454 /* If the cdr is nil, avoid recursion for the car. */
5455 if (EQ (ptr
->cdr
, Qnil
))
5461 mark_object (ptr
->car
);
5464 if (cdr_count
== mark_object_loop_halt
)
5470 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5471 FLOAT_MARK (XFLOAT (obj
));
5482 #undef CHECK_ALLOCATED
5483 #undef CHECK_ALLOCATED_AND_LIVE
5486 /* Mark the pointers in a buffer structure. */
5492 register struct buffer
*buffer
= XBUFFER (buf
);
5493 register Lisp_Object
*ptr
, tmp
;
5494 Lisp_Object base_buffer
;
5496 VECTOR_MARK (buffer
);
5498 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5500 /* For now, we just don't mark the undo_list. It's done later in
5501 a special way just before the sweep phase, and after stripping
5502 some of its elements that are not needed any more. */
5504 if (buffer
->overlays_before
)
5506 XSETMISC (tmp
, buffer
->overlays_before
);
5509 if (buffer
->overlays_after
)
5511 XSETMISC (tmp
, buffer
->overlays_after
);
5515 for (ptr
= &buffer
->name
;
5516 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5520 /* If this is an indirect buffer, mark its base buffer. */
5521 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5523 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5524 mark_buffer (base_buffer
);
5529 /* Value is non-zero if OBJ will survive the current GC because it's
5530 either marked or does not need to be marked to survive. */
5538 switch (XGCTYPE (obj
))
5545 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5549 survives_p
= XMARKER (obj
)->gcmarkbit
;
5553 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5556 case Lisp_Vectorlike
:
5557 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5561 survives_p
= CONS_MARKED_P (XCONS (obj
));
5565 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5572 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5577 /* Sweep: find all structures not marked, and free them. */
5582 /* Remove or mark entries in weak hash tables.
5583 This must be done before any object is unmarked. */
5584 sweep_weak_hash_tables ();
5587 #ifdef GC_CHECK_STRING_BYTES
5588 if (!noninteractive
)
5589 check_string_bytes (1);
5592 /* Put all unmarked conses on free list */
5594 register struct cons_block
*cblk
;
5595 struct cons_block
**cprev
= &cons_block
;
5596 register int lim
= cons_block_index
;
5597 register int num_free
= 0, num_used
= 0;
5601 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5605 for (i
= 0; i
< lim
; i
++)
5606 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5609 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
5610 cons_free_list
= &cblk
->conses
[i
];
5612 cons_free_list
->car
= Vdead
;
5618 CONS_UNMARK (&cblk
->conses
[i
]);
5620 lim
= CONS_BLOCK_SIZE
;
5621 /* If this block contains only free conses and we have already
5622 seen more than two blocks worth of free conses then deallocate
5624 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5626 *cprev
= cblk
->next
;
5627 /* Unhook from the free list. */
5628 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
5629 lisp_align_free (cblk
);
5634 num_free
+= this_free
;
5635 cprev
= &cblk
->next
;
5638 total_conses
= num_used
;
5639 total_free_conses
= num_free
;
5642 /* Put all unmarked floats on free list */
5644 register struct float_block
*fblk
;
5645 struct float_block
**fprev
= &float_block
;
5646 register int lim
= float_block_index
;
5647 register int num_free
= 0, num_used
= 0;
5649 float_free_list
= 0;
5651 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5655 for (i
= 0; i
< lim
; i
++)
5656 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5659 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
5660 float_free_list
= &fblk
->floats
[i
];
5665 FLOAT_UNMARK (&fblk
->floats
[i
]);
5667 lim
= FLOAT_BLOCK_SIZE
;
5668 /* If this block contains only free floats and we have already
5669 seen more than two blocks worth of free floats then deallocate
5671 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5673 *fprev
= fblk
->next
;
5674 /* Unhook from the free list. */
5675 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5676 lisp_align_free (fblk
);
5681 num_free
+= this_free
;
5682 fprev
= &fblk
->next
;
5685 total_floats
= num_used
;
5686 total_free_floats
= num_free
;
5689 /* Put all unmarked intervals on free list */
5691 register struct interval_block
*iblk
;
5692 struct interval_block
**iprev
= &interval_block
;
5693 register int lim
= interval_block_index
;
5694 register int num_free
= 0, num_used
= 0;
5696 interval_free_list
= 0;
5698 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5703 for (i
= 0; i
< lim
; i
++)
5705 if (!iblk
->intervals
[i
].gcmarkbit
)
5707 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5708 interval_free_list
= &iblk
->intervals
[i
];
5714 iblk
->intervals
[i
].gcmarkbit
= 0;
5717 lim
= INTERVAL_BLOCK_SIZE
;
5718 /* If this block contains only free intervals and we have already
5719 seen more than two blocks worth of free intervals then
5720 deallocate this block. */
5721 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5723 *iprev
= iblk
->next
;
5724 /* Unhook from the free list. */
5725 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5727 n_interval_blocks
--;
5731 num_free
+= this_free
;
5732 iprev
= &iblk
->next
;
5735 total_intervals
= num_used
;
5736 total_free_intervals
= num_free
;
5739 /* Put all unmarked symbols on free list */
5741 register struct symbol_block
*sblk
;
5742 struct symbol_block
**sprev
= &symbol_block
;
5743 register int lim
= symbol_block_index
;
5744 register int num_free
= 0, num_used
= 0;
5746 symbol_free_list
= NULL
;
5748 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5751 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5752 struct Lisp_Symbol
*end
= sym
+ lim
;
5754 for (; sym
< end
; ++sym
)
5756 /* Check if the symbol was created during loadup. In such a case
5757 it might be pointed to by pure bytecode which we don't trace,
5758 so we conservatively assume that it is live. */
5759 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5761 if (!sym
->gcmarkbit
&& !pure_p
)
5763 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5764 symbol_free_list
= sym
;
5766 symbol_free_list
->function
= Vdead
;
5774 UNMARK_STRING (XSTRING (sym
->xname
));
5779 lim
= SYMBOL_BLOCK_SIZE
;
5780 /* If this block contains only free symbols and we have already
5781 seen more than two blocks worth of free symbols then deallocate
5783 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5785 *sprev
= sblk
->next
;
5786 /* Unhook from the free list. */
5787 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5793 num_free
+= this_free
;
5794 sprev
= &sblk
->next
;
5797 total_symbols
= num_used
;
5798 total_free_symbols
= num_free
;
5801 /* Put all unmarked misc's on free list.
5802 For a marker, first unchain it from the buffer it points into. */
5804 register struct marker_block
*mblk
;
5805 struct marker_block
**mprev
= &marker_block
;
5806 register int lim
= marker_block_index
;
5807 register int num_free
= 0, num_used
= 0;
5809 marker_free_list
= 0;
5811 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5816 for (i
= 0; i
< lim
; i
++)
5818 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5820 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5821 unchain_marker (&mblk
->markers
[i
].u_marker
);
5822 /* Set the type of the freed object to Lisp_Misc_Free.
5823 We could leave the type alone, since nobody checks it,
5824 but this might catch bugs faster. */
5825 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5826 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5827 marker_free_list
= &mblk
->markers
[i
];
5833 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5836 lim
= MARKER_BLOCK_SIZE
;
5837 /* If this block contains only free markers and we have already
5838 seen more than two blocks worth of free markers then deallocate
5840 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5842 *mprev
= mblk
->next
;
5843 /* Unhook from the free list. */
5844 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5850 num_free
+= this_free
;
5851 mprev
= &mblk
->next
;
5855 total_markers
= num_used
;
5856 total_free_markers
= num_free
;
5859 /* Free all unmarked buffers */
5861 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5864 if (!VECTOR_MARKED_P (buffer
))
5867 prev
->next
= buffer
->next
;
5869 all_buffers
= buffer
->next
;
5870 next
= buffer
->next
;
5876 VECTOR_UNMARK (buffer
);
5877 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5878 prev
= buffer
, buffer
= buffer
->next
;
5882 /* Free all unmarked vectors */
5884 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5885 total_vector_size
= 0;
5888 if (!VECTOR_MARKED_P (vector
))
5891 prev
->next
= vector
->next
;
5893 all_vectors
= vector
->next
;
5894 next
= vector
->next
;
5902 VECTOR_UNMARK (vector
);
5903 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5904 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5906 total_vector_size
+= vector
->size
;
5907 prev
= vector
, vector
= vector
->next
;
5911 #ifdef GC_CHECK_STRING_BYTES
5912 if (!noninteractive
)
5913 check_string_bytes (1);
5920 /* Debugging aids. */
5922 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5923 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
5924 This may be helpful in debugging Emacs's memory usage.
5925 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
5930 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5935 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5936 doc
: /* Return a list of counters that measure how much consing there has been.
5937 Each of these counters increments for a certain kind of object.
5938 The counters wrap around from the largest positive integer to zero.
5939 Garbage collection does not decrease them.
5940 The elements of the value are as follows:
5941 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
5942 All are in units of 1 = one object consed
5943 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
5945 MISCS include overlays, markers, and some internal types.
5946 Frames, windows, buffers, and subprocesses count as vectors
5947 (but the contents of a buffer's text do not count here). */)
5950 Lisp_Object consed
[8];
5952 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
5953 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
5954 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
5955 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
5956 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
5957 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
5958 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
5959 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
5961 return Flist (8, consed
);
5964 int suppress_checking
;
5966 die (msg
, file
, line
)
5971 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5976 /* Initialization */
5981 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5983 pure_size
= PURESIZE
;
5984 pure_bytes_used
= 0;
5985 pure_bytes_used_before_overflow
= 0;
5987 /* Initialize the list of free aligned blocks. */
5990 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5992 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5996 ignore_warnings
= 1;
5997 #ifdef DOUG_LEA_MALLOC
5998 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5999 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6000 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6010 malloc_hysteresis
= 32;
6012 malloc_hysteresis
= 0;
6015 spare_memory
= (char *) malloc (SPARE_MEMORY
);
6017 ignore_warnings
= 0;
6019 byte_stack_list
= 0;
6021 consing_since_gc
= 0;
6022 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6023 gc_relative_threshold
= 0;
6025 #ifdef VIRT_ADDR_VARIES
6026 malloc_sbrk_unused
= 1<<22; /* A large number */
6027 malloc_sbrk_used
= 100000; /* as reasonable as any number */
6028 #endif /* VIRT_ADDR_VARIES */
6035 byte_stack_list
= 0;
6037 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6038 setjmp_tested_p
= longjmps_done
= 0;
6041 Vgc_elapsed
= make_float (0.0);
6048 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
6049 doc
: /* *Number of bytes of consing between garbage collections.
6050 Garbage collection can happen automatically once this many bytes have been
6051 allocated since the last garbage collection. All data types count.
6053 Garbage collection happens automatically only when `eval' is called.
6055 By binding this temporarily to a large number, you can effectively
6056 prevent garbage collection during a part of the program.
6057 See also `gc-cons-percentage'. */);
6059 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage
,
6060 doc
: /* *Portion of the heap used for allocation.
6061 Garbage collection can happen automatically once this portion of the heap
6062 has been allocated since the last garbage collection.
6063 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6064 Vgc_cons_percentage
= make_float (0.1);
6066 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
6067 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6069 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
6070 doc
: /* Number of cons cells that have been consed so far. */);
6072 DEFVAR_INT ("floats-consed", &floats_consed
,
6073 doc
: /* Number of floats that have been consed so far. */);
6075 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
6076 doc
: /* Number of vector cells that have been consed so far. */);
6078 DEFVAR_INT ("symbols-consed", &symbols_consed
,
6079 doc
: /* Number of symbols that have been consed so far. */);
6081 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
6082 doc
: /* Number of string characters that have been consed so far. */);
6084 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
6085 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6087 DEFVAR_INT ("intervals-consed", &intervals_consed
,
6088 doc
: /* Number of intervals that have been consed so far. */);
6090 DEFVAR_INT ("strings-consed", &strings_consed
,
6091 doc
: /* Number of strings that have been consed so far. */);
6093 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
6094 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6095 This means that certain objects should be allocated in shared (pure) space. */);
6097 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
6098 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6099 garbage_collection_messages
= 0;
6101 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
6102 doc
: /* Hook run after garbage collection has finished. */);
6103 Vpost_gc_hook
= Qnil
;
6104 Qpost_gc_hook
= intern ("post-gc-hook");
6105 staticpro (&Qpost_gc_hook
);
6107 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
6108 doc
: /* Precomputed `signal' argument for memory-full error. */);
6109 /* We build this in advance because if we wait until we need it, we might
6110 not be able to allocate the memory to hold it. */
6113 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6115 DEFVAR_LISP ("memory-full", &Vmemory_full
,
6116 doc
: /* Non-nil means we are handling a memory-full error. */);
6117 Vmemory_full
= Qnil
;
6119 staticpro (&Qgc_cons_threshold
);
6120 Qgc_cons_threshold
= intern ("gc-cons-threshold");
6122 staticpro (&Qchar_table_extra_slots
);
6123 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
6125 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
6126 doc
: /* Accumulated time elapsed in garbage collections.
6127 The time is in seconds as a floating point value. */);
6128 DEFVAR_INT ("gcs-done", &gcs_done
,
6129 doc
: /* Accumulated number of garbage collections done. */);
6131 defsubr (&Smemory_full_p
);
6135 defsubr (&Smake_byte_code
);
6136 defsubr (&Smake_list
);
6137 defsubr (&Smake_vector
);
6138 defsubr (&Smake_char_table
);
6139 defsubr (&Smake_string
);
6140 defsubr (&Smake_bool_vector
);
6141 defsubr (&Smake_symbol
);
6142 defsubr (&Smake_marker
);
6143 defsubr (&Spurecopy
);
6144 defsubr (&Sgarbage_collect
);
6145 defsubr (&Smemory_limit
);
6146 defsubr (&Smemory_use_counts
);
6148 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6149 defsubr (&Sgc_status
);
6153 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6154 (do not change this comment) */