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
218 static char *spare_memory
;
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 /* Called if we can't allocate relocatable space for a buffer. */
553 buffer_memory_full ()
555 /* If buffers use the relocating allocator, no need to free
556 spare_memory, because we may have plenty of malloc space left
557 that we could get, and if we don't, the malloc that fails will
558 itself cause spare_memory to be freed. If buffers don't use the
559 relocating allocator, treat this like any other failing
568 /* This used to call error, but if we've run out of memory, we could
569 get infinite recursion trying to build the string. */
571 Fsignal (Qnil
, Vmemory_signal_data
);
575 #ifdef XMALLOC_OVERRUN_CHECK
577 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
578 and a 16 byte trailer around each block.
580 The header consists of 12 fixed bytes + a 4 byte integer contaning the
581 original block size, while the trailer consists of 16 fixed bytes.
583 The header is used to detect whether this block has been allocated
584 through these functions -- as it seems that some low-level libc
585 functions may bypass the malloc hooks.
589 #define XMALLOC_OVERRUN_CHECK_SIZE 16
591 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
592 { 0x9a, 0x9b, 0xae, 0xaf,
593 0xbf, 0xbe, 0xce, 0xcf,
594 0xea, 0xeb, 0xec, 0xed };
596 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
597 { 0xaa, 0xab, 0xac, 0xad,
598 0xba, 0xbb, 0xbc, 0xbd,
599 0xca, 0xcb, 0xcc, 0xcd,
600 0xda, 0xdb, 0xdc, 0xdd };
602 /* Macros to insert and extract the block size in the header. */
604 #define XMALLOC_PUT_SIZE(ptr, size) \
605 (ptr[-1] = (size & 0xff), \
606 ptr[-2] = ((size >> 8) & 0xff), \
607 ptr[-3] = ((size >> 16) & 0xff), \
608 ptr[-4] = ((size >> 24) & 0xff))
610 #define XMALLOC_GET_SIZE(ptr) \
611 (size_t)((unsigned)(ptr[-1]) | \
612 ((unsigned)(ptr[-2]) << 8) | \
613 ((unsigned)(ptr[-3]) << 16) | \
614 ((unsigned)(ptr[-4]) << 24))
617 /* The call depth in overrun_check functions. For example, this might happen:
619 overrun_check_malloc()
620 -> malloc -> (via hook)_-> emacs_blocked_malloc
621 -> overrun_check_malloc
622 call malloc (hooks are NULL, so real malloc is called).
623 malloc returns 10000.
624 add overhead, return 10016.
625 <- (back in overrun_check_malloc)
626 add overhead again, return 10032
627 xmalloc returns 10032.
632 overrun_check_free(10032)
634 free(10016) <- crash, because 10000 is the original pointer. */
636 static int check_depth
;
638 /* Like malloc, but wraps allocated block with header and trailer. */
641 overrun_check_malloc (size
)
644 register unsigned char *val
;
645 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
647 val
= (unsigned char *) malloc (size
+ overhead
);
648 if (val
&& check_depth
== 1)
650 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
651 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
652 XMALLOC_PUT_SIZE(val
, size
);
653 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
656 return (POINTER_TYPE
*)val
;
660 /* Like realloc, but checks old block for overrun, and wraps new block
661 with header and trailer. */
664 overrun_check_realloc (block
, size
)
668 register unsigned char *val
= (unsigned char *)block
;
669 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
673 && bcmp (xmalloc_overrun_check_header
,
674 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
675 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
677 size_t osize
= XMALLOC_GET_SIZE (val
);
678 if (bcmp (xmalloc_overrun_check_trailer
,
680 XMALLOC_OVERRUN_CHECK_SIZE
))
682 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
683 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
684 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
687 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
689 if (val
&& check_depth
== 1)
691 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
692 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
693 XMALLOC_PUT_SIZE(val
, size
);
694 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
697 return (POINTER_TYPE
*)val
;
700 /* Like free, but checks block for overrun. */
703 overrun_check_free (block
)
706 unsigned char *val
= (unsigned char *)block
;
711 && bcmp (xmalloc_overrun_check_header
,
712 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
713 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
715 size_t osize
= XMALLOC_GET_SIZE (val
);
716 if (bcmp (xmalloc_overrun_check_trailer
,
718 XMALLOC_OVERRUN_CHECK_SIZE
))
720 #ifdef XMALLOC_CLEAR_FREE_MEMORY
721 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
722 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
724 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
725 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
726 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
737 #define malloc overrun_check_malloc
738 #define realloc overrun_check_realloc
739 #define free overrun_check_free
743 /* Like malloc but check for no memory and block interrupt input.. */
749 register POINTER_TYPE
*val
;
752 val
= (POINTER_TYPE
*) malloc (size
);
761 /* Like realloc but check for no memory and block interrupt input.. */
764 xrealloc (block
, size
)
768 register POINTER_TYPE
*val
;
771 /* We must call malloc explicitly when BLOCK is 0, since some
772 reallocs don't do this. */
774 val
= (POINTER_TYPE
*) malloc (size
);
776 val
= (POINTER_TYPE
*) realloc (block
, size
);
779 if (!val
&& size
) memory_full ();
784 /* Like free but block interrupt input. */
796 /* Like strdup, but uses xmalloc. */
802 size_t len
= strlen (s
) + 1;
803 char *p
= (char *) xmalloc (len
);
809 /* Unwind for SAFE_ALLOCA */
812 safe_alloca_unwind (arg
)
815 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
825 /* Like malloc but used for allocating Lisp data. NBYTES is the
826 number of bytes to allocate, TYPE describes the intended use of the
827 allcated memory block (for strings, for conses, ...). */
830 static void *lisp_malloc_loser
;
833 static POINTER_TYPE
*
834 lisp_malloc (nbytes
, type
)
842 #ifdef GC_MALLOC_CHECK
843 allocated_mem_type
= type
;
846 val
= (void *) malloc (nbytes
);
849 /* If the memory just allocated cannot be addressed thru a Lisp
850 object's pointer, and it needs to be,
851 that's equivalent to running out of memory. */
852 if (val
&& type
!= MEM_TYPE_NON_LISP
)
855 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
856 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
858 lisp_malloc_loser
= val
;
865 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
866 if (val
&& type
!= MEM_TYPE_NON_LISP
)
867 mem_insert (val
, (char *) val
+ nbytes
, type
);
876 /* Free BLOCK. This must be called to free memory allocated with a
877 call to lisp_malloc. */
885 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
886 mem_delete (mem_find (block
));
891 /* Allocation of aligned blocks of memory to store Lisp data. */
892 /* The entry point is lisp_align_malloc which returns blocks of at most */
893 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
896 /* BLOCK_ALIGN has to be a power of 2. */
897 #define BLOCK_ALIGN (1 << 10)
899 /* Padding to leave at the end of a malloc'd block. This is to give
900 malloc a chance to minimize the amount of memory wasted to alignment.
901 It should be tuned to the particular malloc library used.
902 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
903 posix_memalign on the other hand would ideally prefer a value of 4
904 because otherwise, there's 1020 bytes wasted between each ablocks.
905 In Emacs, testing shows that those 1020 can most of the time be
906 efficiently used by malloc to place other objects, so a value of 0 can
907 still preferable unless you have a lot of aligned blocks and virtually
909 #define BLOCK_PADDING 0
910 #define BLOCK_BYTES \
911 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
913 /* Internal data structures and constants. */
915 #define ABLOCKS_SIZE 16
917 /* An aligned block of memory. */
922 char payload
[BLOCK_BYTES
];
923 struct ablock
*next_free
;
925 /* `abase' is the aligned base of the ablocks. */
926 /* It is overloaded to hold the virtual `busy' field that counts
927 the number of used ablock in the parent ablocks.
928 The first ablock has the `busy' field, the others have the `abase'
929 field. To tell the difference, we assume that pointers will have
930 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
931 is used to tell whether the real base of the parent ablocks is `abase'
932 (if not, the word before the first ablock holds a pointer to the
934 struct ablocks
*abase
;
935 /* The padding of all but the last ablock is unused. The padding of
936 the last ablock in an ablocks is not allocated. */
938 char padding
[BLOCK_PADDING
];
942 /* A bunch of consecutive aligned blocks. */
945 struct ablock blocks
[ABLOCKS_SIZE
];
948 /* Size of the block requested from malloc or memalign. */
949 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
951 #define ABLOCK_ABASE(block) \
952 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
953 ? (struct ablocks *)(block) \
956 /* Virtual `busy' field. */
957 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
959 /* Pointer to the (not necessarily aligned) malloc block. */
960 #ifdef HAVE_POSIX_MEMALIGN
961 #define ABLOCKS_BASE(abase) (abase)
963 #define ABLOCKS_BASE(abase) \
964 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
967 /* The list of free ablock. */
968 static struct ablock
*free_ablock
;
970 /* Allocate an aligned block of nbytes.
971 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
972 smaller or equal to BLOCK_BYTES. */
973 static POINTER_TYPE
*
974 lisp_align_malloc (nbytes
, type
)
979 struct ablocks
*abase
;
981 eassert (nbytes
<= BLOCK_BYTES
);
985 #ifdef GC_MALLOC_CHECK
986 allocated_mem_type
= type
;
992 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
994 #ifdef DOUG_LEA_MALLOC
995 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
996 because mapped region contents are not preserved in
998 mallopt (M_MMAP_MAX
, 0);
1001 #ifdef HAVE_POSIX_MEMALIGN
1003 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1009 base
= malloc (ABLOCKS_BYTES
);
1010 abase
= ALIGN (base
, BLOCK_ALIGN
);
1019 aligned
= (base
== abase
);
1021 ((void**)abase
)[-1] = base
;
1023 #ifdef DOUG_LEA_MALLOC
1024 /* Back to a reasonable maximum of mmap'ed areas. */
1025 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1029 /* If the memory just allocated cannot be addressed thru a Lisp
1030 object's pointer, and it needs to be, that's equivalent to
1031 running out of memory. */
1032 if (type
!= MEM_TYPE_NON_LISP
)
1035 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1036 XSETCONS (tem
, end
);
1037 if ((char *) XCONS (tem
) != end
)
1039 lisp_malloc_loser
= base
;
1047 /* Initialize the blocks and put them on the free list.
1048 Is `base' was not properly aligned, we can't use the last block. */
1049 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1051 abase
->blocks
[i
].abase
= abase
;
1052 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1053 free_ablock
= &abase
->blocks
[i
];
1055 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
1057 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
1058 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1059 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1060 eassert (ABLOCKS_BASE (abase
) == base
);
1061 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1064 abase
= ABLOCK_ABASE (free_ablock
);
1065 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1067 free_ablock
= free_ablock
->x
.next_free
;
1069 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1070 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1071 mem_insert (val
, (char *) val
+ nbytes
, type
);
1078 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1083 lisp_align_free (block
)
1084 POINTER_TYPE
*block
;
1086 struct ablock
*ablock
= block
;
1087 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1090 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1091 mem_delete (mem_find (block
));
1093 /* Put on free list. */
1094 ablock
->x
.next_free
= free_ablock
;
1095 free_ablock
= ablock
;
1096 /* Update busy count. */
1097 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1099 if (2 > (long) ABLOCKS_BUSY (abase
))
1100 { /* All the blocks are free. */
1101 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1102 struct ablock
**tem
= &free_ablock
;
1103 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1107 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1110 *tem
= (*tem
)->x
.next_free
;
1113 tem
= &(*tem
)->x
.next_free
;
1115 eassert ((aligned
& 1) == aligned
);
1116 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1117 free (ABLOCKS_BASE (abase
));
1122 /* Return a new buffer structure allocated from the heap with
1123 a call to lisp_malloc. */
1129 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1135 #ifndef SYSTEM_MALLOC
1137 /* If we released our reserve (due to running out of memory),
1138 and we have a fair amount free once again,
1139 try to set aside another reserve in case we run out once more.
1141 This is called when a relocatable block is freed in ralloc.c. */
1144 refill_memory_reserve ()
1146 if (spare_memory
== 0)
1147 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
1151 /* Arranging to disable input signals while we're in malloc.
1153 This only works with GNU malloc. To help out systems which can't
1154 use GNU malloc, all the calls to malloc, realloc, and free
1155 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1156 pair; unfortunately, we have no idea what C library functions
1157 might call malloc, so we can't really protect them unless you're
1158 using GNU malloc. Fortunately, most of the major operating systems
1159 can use GNU malloc. */
1163 #ifndef DOUG_LEA_MALLOC
1164 extern void * (*__malloc_hook
) P_ ((size_t, const void *));
1165 extern void * (*__realloc_hook
) P_ ((void *, size_t, const void *));
1166 extern void (*__free_hook
) P_ ((void *, const void *));
1167 /* Else declared in malloc.h, perhaps with an extra arg. */
1168 #endif /* DOUG_LEA_MALLOC */
1169 static void * (*old_malloc_hook
) P_ ((size_t, const void *));
1170 static void * (*old_realloc_hook
) P_ ((void *, size_t, const void*));
1171 static void (*old_free_hook
) P_ ((void*, const void*));
1173 /* This function is used as the hook for free to call. */
1176 emacs_blocked_free (ptr
, ptr2
)
1182 #ifdef GC_MALLOC_CHECK
1188 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1191 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1196 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1200 #endif /* GC_MALLOC_CHECK */
1202 __free_hook
= old_free_hook
;
1205 /* If we released our reserve (due to running out of memory),
1206 and we have a fair amount free once again,
1207 try to set aside another reserve in case we run out once more. */
1208 if (spare_memory
== 0
1209 /* Verify there is enough space that even with the malloc
1210 hysteresis this call won't run out again.
1211 The code here is correct as long as SPARE_MEMORY
1212 is substantially larger than the block size malloc uses. */
1213 && (bytes_used_when_full
1214 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
1215 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
1217 __free_hook
= emacs_blocked_free
;
1218 UNBLOCK_INPUT_ALLOC
;
1222 /* This function is the malloc hook that Emacs uses. */
1225 emacs_blocked_malloc (size
, ptr
)
1232 __malloc_hook
= old_malloc_hook
;
1233 #ifdef DOUG_LEA_MALLOC
1234 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
1236 __malloc_extra_blocks
= malloc_hysteresis
;
1239 value
= (void *) malloc (size
);
1241 #ifdef GC_MALLOC_CHECK
1243 struct mem_node
*m
= mem_find (value
);
1246 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1248 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1249 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1254 if (!dont_register_blocks
)
1256 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1257 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1260 #endif /* GC_MALLOC_CHECK */
1262 __malloc_hook
= emacs_blocked_malloc
;
1263 UNBLOCK_INPUT_ALLOC
;
1265 /* fprintf (stderr, "%p malloc\n", value); */
1270 /* This function is the realloc hook that Emacs uses. */
1273 emacs_blocked_realloc (ptr
, size
, ptr2
)
1281 __realloc_hook
= old_realloc_hook
;
1283 #ifdef GC_MALLOC_CHECK
1286 struct mem_node
*m
= mem_find (ptr
);
1287 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1290 "Realloc of %p which wasn't allocated with malloc\n",
1298 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1300 /* Prevent malloc from registering blocks. */
1301 dont_register_blocks
= 1;
1302 #endif /* GC_MALLOC_CHECK */
1304 value
= (void *) realloc (ptr
, size
);
1306 #ifdef GC_MALLOC_CHECK
1307 dont_register_blocks
= 0;
1310 struct mem_node
*m
= mem_find (value
);
1313 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1317 /* Can't handle zero size regions in the red-black tree. */
1318 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1321 /* fprintf (stderr, "%p <- realloc\n", value); */
1322 #endif /* GC_MALLOC_CHECK */
1324 __realloc_hook
= emacs_blocked_realloc
;
1325 UNBLOCK_INPUT_ALLOC
;
1331 #ifdef HAVE_GTK_AND_PTHREAD
1332 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1333 normal malloc. Some thread implementations need this as they call
1334 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1335 calls malloc because it is the first call, and we have an endless loop. */
1338 reset_malloc_hooks ()
1344 #endif /* HAVE_GTK_AND_PTHREAD */
1347 /* Called from main to set up malloc to use our hooks. */
1350 uninterrupt_malloc ()
1352 #ifdef HAVE_GTK_AND_PTHREAD
1353 pthread_mutexattr_t attr
;
1355 /* GLIBC has a faster way to do this, but lets keep it portable.
1356 This is according to the Single UNIX Specification. */
1357 pthread_mutexattr_init (&attr
);
1358 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1359 pthread_mutex_init (&alloc_mutex
, &attr
);
1360 #endif /* HAVE_GTK_AND_PTHREAD */
1362 if (__free_hook
!= emacs_blocked_free
)
1363 old_free_hook
= __free_hook
;
1364 __free_hook
= emacs_blocked_free
;
1366 if (__malloc_hook
!= emacs_blocked_malloc
)
1367 old_malloc_hook
= __malloc_hook
;
1368 __malloc_hook
= emacs_blocked_malloc
;
1370 if (__realloc_hook
!= emacs_blocked_realloc
)
1371 old_realloc_hook
= __realloc_hook
;
1372 __realloc_hook
= emacs_blocked_realloc
;
1375 #endif /* not SYNC_INPUT */
1376 #endif /* not SYSTEM_MALLOC */
1380 /***********************************************************************
1382 ***********************************************************************/
1384 /* Number of intervals allocated in an interval_block structure.
1385 The 1020 is 1024 minus malloc overhead. */
1387 #define INTERVAL_BLOCK_SIZE \
1388 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1390 /* Intervals are allocated in chunks in form of an interval_block
1393 struct interval_block
1395 /* Place `intervals' first, to preserve alignment. */
1396 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1397 struct interval_block
*next
;
1400 /* Current interval block. Its `next' pointer points to older
1403 struct interval_block
*interval_block
;
1405 /* Index in interval_block above of the next unused interval
1408 static int interval_block_index
;
1410 /* Number of free and live intervals. */
1412 static int total_free_intervals
, total_intervals
;
1414 /* List of free intervals. */
1416 INTERVAL interval_free_list
;
1418 /* Total number of interval blocks now in use. */
1420 int n_interval_blocks
;
1423 /* Initialize interval allocation. */
1428 interval_block
= NULL
;
1429 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1430 interval_free_list
= 0;
1431 n_interval_blocks
= 0;
1435 /* Return a new interval. */
1442 if (interval_free_list
)
1444 val
= interval_free_list
;
1445 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1449 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1451 register struct interval_block
*newi
;
1453 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1456 newi
->next
= interval_block
;
1457 interval_block
= newi
;
1458 interval_block_index
= 0;
1459 n_interval_blocks
++;
1461 val
= &interval_block
->intervals
[interval_block_index
++];
1463 consing_since_gc
+= sizeof (struct interval
);
1465 RESET_INTERVAL (val
);
1471 /* Mark Lisp objects in interval I. */
1474 mark_interval (i
, dummy
)
1475 register INTERVAL i
;
1478 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1480 mark_object (i
->plist
);
1484 /* Mark the interval tree rooted in TREE. Don't call this directly;
1485 use the macro MARK_INTERVAL_TREE instead. */
1488 mark_interval_tree (tree
)
1489 register INTERVAL tree
;
1491 /* No need to test if this tree has been marked already; this
1492 function is always called through the MARK_INTERVAL_TREE macro,
1493 which takes care of that. */
1495 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1499 /* Mark the interval tree rooted in I. */
1501 #define MARK_INTERVAL_TREE(i) \
1503 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1504 mark_interval_tree (i); \
1508 #define UNMARK_BALANCE_INTERVALS(i) \
1510 if (! NULL_INTERVAL_P (i)) \
1511 (i) = balance_intervals (i); \
1515 /* Number support. If NO_UNION_TYPE isn't in effect, we
1516 can't create number objects in macros. */
1524 obj
.s
.type
= Lisp_Int
;
1529 /***********************************************************************
1531 ***********************************************************************/
1533 /* Lisp_Strings are allocated in string_block structures. When a new
1534 string_block is allocated, all the Lisp_Strings it contains are
1535 added to a free-list string_free_list. When a new Lisp_String is
1536 needed, it is taken from that list. During the sweep phase of GC,
1537 string_blocks that are entirely free are freed, except two which
1540 String data is allocated from sblock structures. Strings larger
1541 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1542 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1544 Sblocks consist internally of sdata structures, one for each
1545 Lisp_String. The sdata structure points to the Lisp_String it
1546 belongs to. The Lisp_String points back to the `u.data' member of
1547 its sdata structure.
1549 When a Lisp_String is freed during GC, it is put back on
1550 string_free_list, and its `data' member and its sdata's `string'
1551 pointer is set to null. The size of the string is recorded in the
1552 `u.nbytes' member of the sdata. So, sdata structures that are no
1553 longer used, can be easily recognized, and it's easy to compact the
1554 sblocks of small strings which we do in compact_small_strings. */
1556 /* Size in bytes of an sblock structure used for small strings. This
1557 is 8192 minus malloc overhead. */
1559 #define SBLOCK_SIZE 8188
1561 /* Strings larger than this are considered large strings. String data
1562 for large strings is allocated from individual sblocks. */
1564 #define LARGE_STRING_BYTES 1024
1566 /* Structure describing string memory sub-allocated from an sblock.
1567 This is where the contents of Lisp strings are stored. */
1571 /* Back-pointer to the string this sdata belongs to. If null, this
1572 structure is free, and the NBYTES member of the union below
1573 contains the string's byte size (the same value that STRING_BYTES
1574 would return if STRING were non-null). If non-null, STRING_BYTES
1575 (STRING) is the size of the data, and DATA contains the string's
1577 struct Lisp_String
*string
;
1579 #ifdef GC_CHECK_STRING_BYTES
1582 unsigned char data
[1];
1584 #define SDATA_NBYTES(S) (S)->nbytes
1585 #define SDATA_DATA(S) (S)->data
1587 #else /* not GC_CHECK_STRING_BYTES */
1591 /* When STRING in non-null. */
1592 unsigned char data
[1];
1594 /* When STRING is null. */
1599 #define SDATA_NBYTES(S) (S)->u.nbytes
1600 #define SDATA_DATA(S) (S)->u.data
1602 #endif /* not GC_CHECK_STRING_BYTES */
1606 /* Structure describing a block of memory which is sub-allocated to
1607 obtain string data memory for strings. Blocks for small strings
1608 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1609 as large as needed. */
1614 struct sblock
*next
;
1616 /* Pointer to the next free sdata block. This points past the end
1617 of the sblock if there isn't any space left in this block. */
1618 struct sdata
*next_free
;
1620 /* Start of data. */
1621 struct sdata first_data
;
1624 /* Number of Lisp strings in a string_block structure. The 1020 is
1625 1024 minus malloc overhead. */
1627 #define STRING_BLOCK_SIZE \
1628 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1630 /* Structure describing a block from which Lisp_String structures
1635 /* Place `strings' first, to preserve alignment. */
1636 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1637 struct string_block
*next
;
1640 /* Head and tail of the list of sblock structures holding Lisp string
1641 data. We always allocate from current_sblock. The NEXT pointers
1642 in the sblock structures go from oldest_sblock to current_sblock. */
1644 static struct sblock
*oldest_sblock
, *current_sblock
;
1646 /* List of sblocks for large strings. */
1648 static struct sblock
*large_sblocks
;
1650 /* List of string_block structures, and how many there are. */
1652 static struct string_block
*string_blocks
;
1653 static int n_string_blocks
;
1655 /* Free-list of Lisp_Strings. */
1657 static struct Lisp_String
*string_free_list
;
1659 /* Number of live and free Lisp_Strings. */
1661 static int total_strings
, total_free_strings
;
1663 /* Number of bytes used by live strings. */
1665 static int total_string_size
;
1667 /* Given a pointer to a Lisp_String S which is on the free-list
1668 string_free_list, return a pointer to its successor in the
1671 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1673 /* Return a pointer to the sdata structure belonging to Lisp string S.
1674 S must be live, i.e. S->data must not be null. S->data is actually
1675 a pointer to the `u.data' member of its sdata structure; the
1676 structure starts at a constant offset in front of that. */
1678 #ifdef GC_CHECK_STRING_BYTES
1680 #define SDATA_OF_STRING(S) \
1681 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1682 - sizeof (EMACS_INT)))
1684 #else /* not GC_CHECK_STRING_BYTES */
1686 #define SDATA_OF_STRING(S) \
1687 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1689 #endif /* not GC_CHECK_STRING_BYTES */
1692 #ifdef GC_CHECK_STRING_OVERRUN
1694 /* We check for overrun in string data blocks by appending a small
1695 "cookie" after each allocated string data block, and check for the
1696 presence of this cookie during GC. */
1698 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1699 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1700 { 0xde, 0xad, 0xbe, 0xef };
1703 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1706 /* Value is the size of an sdata structure large enough to hold NBYTES
1707 bytes of string data. The value returned includes a terminating
1708 NUL byte, the size of the sdata structure, and padding. */
1710 #ifdef GC_CHECK_STRING_BYTES
1712 #define SDATA_SIZE(NBYTES) \
1713 ((sizeof (struct Lisp_String *) \
1715 + sizeof (EMACS_INT) \
1716 + sizeof (EMACS_INT) - 1) \
1717 & ~(sizeof (EMACS_INT) - 1))
1719 #else /* not GC_CHECK_STRING_BYTES */
1721 #define SDATA_SIZE(NBYTES) \
1722 ((sizeof (struct Lisp_String *) \
1724 + sizeof (EMACS_INT) - 1) \
1725 & ~(sizeof (EMACS_INT) - 1))
1727 #endif /* not GC_CHECK_STRING_BYTES */
1729 /* Extra bytes to allocate for each string. */
1731 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1733 /* Initialize string allocation. Called from init_alloc_once. */
1738 total_strings
= total_free_strings
= total_string_size
= 0;
1739 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1740 string_blocks
= NULL
;
1741 n_string_blocks
= 0;
1742 string_free_list
= NULL
;
1746 #ifdef GC_CHECK_STRING_BYTES
1748 static int check_string_bytes_count
;
1750 void check_string_bytes
P_ ((int));
1751 void check_sblock
P_ ((struct sblock
*));
1753 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1756 /* Like GC_STRING_BYTES, but with debugging check. */
1760 struct Lisp_String
*s
;
1762 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1763 if (!PURE_POINTER_P (s
)
1765 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1770 /* Check validity of Lisp strings' string_bytes member in B. */
1776 struct sdata
*from
, *end
, *from_end
;
1780 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1782 /* Compute the next FROM here because copying below may
1783 overwrite data we need to compute it. */
1786 /* Check that the string size recorded in the string is the
1787 same as the one recorded in the sdata structure. */
1789 CHECK_STRING_BYTES (from
->string
);
1792 nbytes
= GC_STRING_BYTES (from
->string
);
1794 nbytes
= SDATA_NBYTES (from
);
1796 nbytes
= SDATA_SIZE (nbytes
);
1797 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1802 /* Check validity of Lisp strings' string_bytes member. ALL_P
1803 non-zero means check all strings, otherwise check only most
1804 recently allocated strings. Used for hunting a bug. */
1807 check_string_bytes (all_p
)
1814 for (b
= large_sblocks
; b
; b
= b
->next
)
1816 struct Lisp_String
*s
= b
->first_data
.string
;
1818 CHECK_STRING_BYTES (s
);
1821 for (b
= oldest_sblock
; b
; b
= b
->next
)
1825 check_sblock (current_sblock
);
1828 #endif /* GC_CHECK_STRING_BYTES */
1830 #ifdef GC_CHECK_STRING_FREE_LIST
1832 /* Walk through the string free list looking for bogus next pointers.
1833 This may catch buffer overrun from a previous string. */
1836 check_string_free_list ()
1838 struct Lisp_String
*s
;
1840 /* Pop a Lisp_String off the free-list. */
1841 s
= string_free_list
;
1844 if ((unsigned)s
< 1024)
1846 s
= NEXT_FREE_LISP_STRING (s
);
1850 #define check_string_free_list()
1853 /* Return a new Lisp_String. */
1855 static struct Lisp_String
*
1858 struct Lisp_String
*s
;
1860 /* If the free-list is empty, allocate a new string_block, and
1861 add all the Lisp_Strings in it to the free-list. */
1862 if (string_free_list
== NULL
)
1864 struct string_block
*b
;
1867 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1868 bzero (b
, sizeof *b
);
1869 b
->next
= string_blocks
;
1873 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1876 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1877 string_free_list
= s
;
1880 total_free_strings
+= STRING_BLOCK_SIZE
;
1883 check_string_free_list ();
1885 /* Pop a Lisp_String off the free-list. */
1886 s
= string_free_list
;
1887 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1889 /* Probably not strictly necessary, but play it safe. */
1890 bzero (s
, sizeof *s
);
1892 --total_free_strings
;
1895 consing_since_gc
+= sizeof *s
;
1897 #ifdef GC_CHECK_STRING_BYTES
1904 if (++check_string_bytes_count
== 200)
1906 check_string_bytes_count
= 0;
1907 check_string_bytes (1);
1910 check_string_bytes (0);
1912 #endif /* GC_CHECK_STRING_BYTES */
1918 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1919 plus a NUL byte at the end. Allocate an sdata structure for S, and
1920 set S->data to its `u.data' member. Store a NUL byte at the end of
1921 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1922 S->data if it was initially non-null. */
1925 allocate_string_data (s
, nchars
, nbytes
)
1926 struct Lisp_String
*s
;
1929 struct sdata
*data
, *old_data
;
1931 int needed
, old_nbytes
;
1933 /* Determine the number of bytes needed to store NBYTES bytes
1935 needed
= SDATA_SIZE (nbytes
);
1937 if (nbytes
> LARGE_STRING_BYTES
)
1939 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1941 #ifdef DOUG_LEA_MALLOC
1942 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1943 because mapped region contents are not preserved in
1946 In case you think of allowing it in a dumped Emacs at the
1947 cost of not being able to re-dump, there's another reason:
1948 mmap'ed data typically have an address towards the top of the
1949 address space, which won't fit into an EMACS_INT (at least on
1950 32-bit systems with the current tagging scheme). --fx */
1952 mallopt (M_MMAP_MAX
, 0);
1956 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1958 #ifdef DOUG_LEA_MALLOC
1959 /* Back to a reasonable maximum of mmap'ed areas. */
1961 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1965 b
->next_free
= &b
->first_data
;
1966 b
->first_data
.string
= NULL
;
1967 b
->next
= large_sblocks
;
1970 else if (current_sblock
== NULL
1971 || (((char *) current_sblock
+ SBLOCK_SIZE
1972 - (char *) current_sblock
->next_free
)
1973 < (needed
+ GC_STRING_EXTRA
)))
1975 /* Not enough room in the current sblock. */
1976 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1977 b
->next_free
= &b
->first_data
;
1978 b
->first_data
.string
= NULL
;
1982 current_sblock
->next
= b
;
1990 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1991 old_nbytes
= GC_STRING_BYTES (s
);
1993 data
= b
->next_free
;
1995 s
->data
= SDATA_DATA (data
);
1996 #ifdef GC_CHECK_STRING_BYTES
1997 SDATA_NBYTES (data
) = nbytes
;
2000 s
->size_byte
= nbytes
;
2001 s
->data
[nbytes
] = '\0';
2002 #ifdef GC_CHECK_STRING_OVERRUN
2003 bcopy (string_overrun_cookie
, (char *) data
+ needed
,
2004 GC_STRING_OVERRUN_COOKIE_SIZE
);
2006 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2008 /* If S had already data assigned, mark that as free by setting its
2009 string back-pointer to null, and recording the size of the data
2013 SDATA_NBYTES (old_data
) = old_nbytes
;
2014 old_data
->string
= NULL
;
2017 consing_since_gc
+= needed
;
2021 /* Sweep and compact strings. */
2026 struct string_block
*b
, *next
;
2027 struct string_block
*live_blocks
= NULL
;
2029 string_free_list
= NULL
;
2030 total_strings
= total_free_strings
= 0;
2031 total_string_size
= 0;
2033 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2034 for (b
= string_blocks
; b
; b
= next
)
2037 struct Lisp_String
*free_list_before
= string_free_list
;
2041 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2043 struct Lisp_String
*s
= b
->strings
+ i
;
2047 /* String was not on free-list before. */
2048 if (STRING_MARKED_P (s
))
2050 /* String is live; unmark it and its intervals. */
2053 if (!NULL_INTERVAL_P (s
->intervals
))
2054 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2057 total_string_size
+= STRING_BYTES (s
);
2061 /* String is dead. Put it on the free-list. */
2062 struct sdata
*data
= SDATA_OF_STRING (s
);
2064 /* Save the size of S in its sdata so that we know
2065 how large that is. Reset the sdata's string
2066 back-pointer so that we know it's free. */
2067 #ifdef GC_CHECK_STRING_BYTES
2068 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2071 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2073 data
->string
= NULL
;
2075 /* Reset the strings's `data' member so that we
2079 /* Put the string on the free-list. */
2080 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2081 string_free_list
= s
;
2087 /* S was on the free-list before. Put it there again. */
2088 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2089 string_free_list
= s
;
2094 /* Free blocks that contain free Lisp_Strings only, except
2095 the first two of them. */
2096 if (nfree
== STRING_BLOCK_SIZE
2097 && total_free_strings
> STRING_BLOCK_SIZE
)
2101 string_free_list
= free_list_before
;
2105 total_free_strings
+= nfree
;
2106 b
->next
= live_blocks
;
2111 check_string_free_list ();
2113 string_blocks
= live_blocks
;
2114 free_large_strings ();
2115 compact_small_strings ();
2117 check_string_free_list ();
2121 /* Free dead large strings. */
2124 free_large_strings ()
2126 struct sblock
*b
, *next
;
2127 struct sblock
*live_blocks
= NULL
;
2129 for (b
= large_sblocks
; b
; b
= next
)
2133 if (b
->first_data
.string
== NULL
)
2137 b
->next
= live_blocks
;
2142 large_sblocks
= live_blocks
;
2146 /* Compact data of small strings. Free sblocks that don't contain
2147 data of live strings after compaction. */
2150 compact_small_strings ()
2152 struct sblock
*b
, *tb
, *next
;
2153 struct sdata
*from
, *to
, *end
, *tb_end
;
2154 struct sdata
*to_end
, *from_end
;
2156 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2157 to, and TB_END is the end of TB. */
2159 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2160 to
= &tb
->first_data
;
2162 /* Step through the blocks from the oldest to the youngest. We
2163 expect that old blocks will stabilize over time, so that less
2164 copying will happen this way. */
2165 for (b
= oldest_sblock
; b
; b
= b
->next
)
2168 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2170 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2172 /* Compute the next FROM here because copying below may
2173 overwrite data we need to compute it. */
2176 #ifdef GC_CHECK_STRING_BYTES
2177 /* Check that the string size recorded in the string is the
2178 same as the one recorded in the sdata structure. */
2180 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2182 #endif /* GC_CHECK_STRING_BYTES */
2185 nbytes
= GC_STRING_BYTES (from
->string
);
2187 nbytes
= SDATA_NBYTES (from
);
2189 if (nbytes
> LARGE_STRING_BYTES
)
2192 nbytes
= SDATA_SIZE (nbytes
);
2193 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2195 #ifdef GC_CHECK_STRING_OVERRUN
2196 if (bcmp (string_overrun_cookie
,
2197 ((char *) from_end
) - GC_STRING_OVERRUN_COOKIE_SIZE
,
2198 GC_STRING_OVERRUN_COOKIE_SIZE
))
2202 /* FROM->string non-null means it's alive. Copy its data. */
2205 /* If TB is full, proceed with the next sblock. */
2206 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2207 if (to_end
> tb_end
)
2211 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2212 to
= &tb
->first_data
;
2213 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2216 /* Copy, and update the string's `data' pointer. */
2219 xassert (tb
!= b
|| to
<= from
);
2220 safe_bcopy ((char *) from
, (char *) to
, nbytes
+ GC_STRING_EXTRA
);
2221 to
->string
->data
= SDATA_DATA (to
);
2224 /* Advance past the sdata we copied to. */
2230 /* The rest of the sblocks following TB don't contain live data, so
2231 we can free them. */
2232 for (b
= tb
->next
; b
; b
= next
)
2240 current_sblock
= tb
;
2244 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2245 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2246 LENGTH must be an integer.
2247 INIT must be an integer that represents a character. */)
2249 Lisp_Object length
, init
;
2251 register Lisp_Object val
;
2252 register unsigned char *p
, *end
;
2255 CHECK_NATNUM (length
);
2256 CHECK_NUMBER (init
);
2259 if (SINGLE_BYTE_CHAR_P (c
))
2261 nbytes
= XINT (length
);
2262 val
= make_uninit_string (nbytes
);
2264 end
= p
+ SCHARS (val
);
2270 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2271 int len
= CHAR_STRING (c
, str
);
2273 nbytes
= len
* XINT (length
);
2274 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
2279 bcopy (str
, p
, len
);
2289 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2290 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
2291 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2293 Lisp_Object length
, init
;
2295 register Lisp_Object val
;
2296 struct Lisp_Bool_Vector
*p
;
2298 int length_in_chars
, length_in_elts
, bits_per_value
;
2300 CHECK_NATNUM (length
);
2302 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2304 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2305 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2306 / BOOL_VECTOR_BITS_PER_CHAR
);
2308 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2309 slot `size' of the struct Lisp_Bool_Vector. */
2310 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2311 p
= XBOOL_VECTOR (val
);
2313 /* Get rid of any bits that would cause confusion. */
2315 XSETBOOL_VECTOR (val
, p
);
2316 p
->size
= XFASTINT (length
);
2318 real_init
= (NILP (init
) ? 0 : -1);
2319 for (i
= 0; i
< length_in_chars
; i
++)
2320 p
->data
[i
] = real_init
;
2322 /* Clear the extraneous bits in the last byte. */
2323 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2324 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
2325 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2331 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2332 of characters from the contents. This string may be unibyte or
2333 multibyte, depending on the contents. */
2336 make_string (contents
, nbytes
)
2337 const char *contents
;
2340 register Lisp_Object val
;
2341 int nchars
, multibyte_nbytes
;
2343 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
2344 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2345 /* CONTENTS contains no multibyte sequences or contains an invalid
2346 multibyte sequence. We must make unibyte string. */
2347 val
= make_unibyte_string (contents
, nbytes
);
2349 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2354 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2357 make_unibyte_string (contents
, length
)
2358 const char *contents
;
2361 register Lisp_Object val
;
2362 val
= make_uninit_string (length
);
2363 bcopy (contents
, SDATA (val
), length
);
2364 STRING_SET_UNIBYTE (val
);
2369 /* Make a multibyte string from NCHARS characters occupying NBYTES
2370 bytes at CONTENTS. */
2373 make_multibyte_string (contents
, nchars
, nbytes
)
2374 const char *contents
;
2377 register Lisp_Object val
;
2378 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2379 bcopy (contents
, SDATA (val
), nbytes
);
2384 /* Make a string from NCHARS characters occupying NBYTES bytes at
2385 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2388 make_string_from_bytes (contents
, nchars
, nbytes
)
2389 const char *contents
;
2392 register Lisp_Object val
;
2393 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2394 bcopy (contents
, SDATA (val
), nbytes
);
2395 if (SBYTES (val
) == SCHARS (val
))
2396 STRING_SET_UNIBYTE (val
);
2401 /* Make a string from NCHARS characters occupying NBYTES bytes at
2402 CONTENTS. The argument MULTIBYTE controls whether to label the
2403 string as multibyte. If NCHARS is negative, it counts the number of
2404 characters by itself. */
2407 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2408 const char *contents
;
2412 register Lisp_Object val
;
2417 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2421 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2422 bcopy (contents
, SDATA (val
), nbytes
);
2424 STRING_SET_UNIBYTE (val
);
2429 /* Make a string from the data at STR, treating it as multibyte if the
2436 return make_string (str
, strlen (str
));
2440 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2441 occupying LENGTH bytes. */
2444 make_uninit_string (length
)
2448 val
= make_uninit_multibyte_string (length
, length
);
2449 STRING_SET_UNIBYTE (val
);
2454 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2455 which occupy NBYTES bytes. */
2458 make_uninit_multibyte_string (nchars
, nbytes
)
2462 struct Lisp_String
*s
;
2467 s
= allocate_string ();
2468 allocate_string_data (s
, nchars
, nbytes
);
2469 XSETSTRING (string
, s
);
2470 string_chars_consed
+= nbytes
;
2476 /***********************************************************************
2478 ***********************************************************************/
2480 /* We store float cells inside of float_blocks, allocating a new
2481 float_block with malloc whenever necessary. Float cells reclaimed
2482 by GC are put on a free list to be reallocated before allocating
2483 any new float cells from the latest float_block. */
2485 #define FLOAT_BLOCK_SIZE \
2486 (((BLOCK_BYTES - sizeof (struct float_block *) \
2487 /* The compiler might add padding at the end. */ \
2488 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2489 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2491 #define GETMARKBIT(block,n) \
2492 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2493 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2496 #define SETMARKBIT(block,n) \
2497 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2498 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2500 #define UNSETMARKBIT(block,n) \
2501 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2502 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2504 #define FLOAT_BLOCK(fptr) \
2505 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2507 #define FLOAT_INDEX(fptr) \
2508 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2512 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2513 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2514 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2515 struct float_block
*next
;
2518 #define FLOAT_MARKED_P(fptr) \
2519 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2521 #define FLOAT_MARK(fptr) \
2522 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2524 #define FLOAT_UNMARK(fptr) \
2525 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2527 /* Current float_block. */
2529 struct float_block
*float_block
;
2531 /* Index of first unused Lisp_Float in the current float_block. */
2533 int float_block_index
;
2535 /* Total number of float blocks now in use. */
2539 /* Free-list of Lisp_Floats. */
2541 struct Lisp_Float
*float_free_list
;
2544 /* Initialize float allocation. */
2550 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2551 float_free_list
= 0;
2556 /* Explicitly free a float cell by putting it on the free-list. */
2560 struct Lisp_Float
*ptr
;
2562 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
2563 float_free_list
= ptr
;
2567 /* Return a new float object with value FLOAT_VALUE. */
2570 make_float (float_value
)
2573 register Lisp_Object val
;
2575 if (float_free_list
)
2577 /* We use the data field for chaining the free list
2578 so that we won't use the same field that has the mark bit. */
2579 XSETFLOAT (val
, float_free_list
);
2580 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
2584 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2586 register struct float_block
*new;
2588 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2590 new->next
= float_block
;
2591 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2593 float_block_index
= 0;
2596 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2597 float_block_index
++;
2600 XFLOAT_DATA (val
) = float_value
;
2601 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2602 consing_since_gc
+= sizeof (struct Lisp_Float
);
2609 /***********************************************************************
2611 ***********************************************************************/
2613 /* We store cons cells inside of cons_blocks, allocating a new
2614 cons_block with malloc whenever necessary. Cons cells reclaimed by
2615 GC are put on a free list to be reallocated before allocating
2616 any new cons cells from the latest cons_block. */
2618 #define CONS_BLOCK_SIZE \
2619 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2620 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2622 #define CONS_BLOCK(fptr) \
2623 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2625 #define CONS_INDEX(fptr) \
2626 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2630 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2631 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2632 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2633 struct cons_block
*next
;
2636 #define CONS_MARKED_P(fptr) \
2637 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2639 #define CONS_MARK(fptr) \
2640 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2642 #define CONS_UNMARK(fptr) \
2643 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2645 /* Current cons_block. */
2647 struct cons_block
*cons_block
;
2649 /* Index of first unused Lisp_Cons in the current block. */
2651 int cons_block_index
;
2653 /* Free-list of Lisp_Cons structures. */
2655 struct Lisp_Cons
*cons_free_list
;
2657 /* Total number of cons blocks now in use. */
2662 /* Initialize cons allocation. */
2668 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2674 /* Explicitly free a cons cell by putting it on the free-list. */
2678 struct Lisp_Cons
*ptr
;
2680 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2684 cons_free_list
= ptr
;
2687 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2688 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2690 Lisp_Object car
, cdr
;
2692 register Lisp_Object val
;
2696 /* We use the cdr for chaining the free list
2697 so that we won't use the same field that has the mark bit. */
2698 XSETCONS (val
, cons_free_list
);
2699 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2703 if (cons_block_index
== CONS_BLOCK_SIZE
)
2705 register struct cons_block
*new;
2706 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2708 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2709 new->next
= cons_block
;
2711 cons_block_index
= 0;
2714 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2720 eassert (!CONS_MARKED_P (XCONS (val
)));
2721 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2722 cons_cells_consed
++;
2726 /* Get an error now if there's any junk in the cons free list. */
2730 #ifdef GC_CHECK_CONS_LIST
2731 struct Lisp_Cons
*tail
= cons_free_list
;
2734 tail
= *(struct Lisp_Cons
**)&tail
->cdr
;
2738 /* Make a list of 2, 3, 4 or 5 specified objects. */
2742 Lisp_Object arg1
, arg2
;
2744 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2749 list3 (arg1
, arg2
, arg3
)
2750 Lisp_Object arg1
, arg2
, arg3
;
2752 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2757 list4 (arg1
, arg2
, arg3
, arg4
)
2758 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2760 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2765 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2766 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2768 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2769 Fcons (arg5
, Qnil
)))));
2773 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2774 doc
: /* Return a newly created list with specified arguments as elements.
2775 Any number of arguments, even zero arguments, are allowed.
2776 usage: (list &rest OBJECTS) */)
2779 register Lisp_Object
*args
;
2781 register Lisp_Object val
;
2787 val
= Fcons (args
[nargs
], val
);
2793 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2794 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2796 register Lisp_Object length
, init
;
2798 register Lisp_Object val
;
2801 CHECK_NATNUM (length
);
2802 size
= XFASTINT (length
);
2807 val
= Fcons (init
, val
);
2812 val
= Fcons (init
, val
);
2817 val
= Fcons (init
, val
);
2822 val
= Fcons (init
, val
);
2827 val
= Fcons (init
, val
);
2842 /***********************************************************************
2844 ***********************************************************************/
2846 /* Singly-linked list of all vectors. */
2848 struct Lisp_Vector
*all_vectors
;
2850 /* Total number of vector-like objects now in use. */
2855 /* Value is a pointer to a newly allocated Lisp_Vector structure
2856 with room for LEN Lisp_Objects. */
2858 static struct Lisp_Vector
*
2859 allocate_vectorlike (len
, type
)
2863 struct Lisp_Vector
*p
;
2866 #ifdef DOUG_LEA_MALLOC
2867 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2868 because mapped region contents are not preserved in
2871 mallopt (M_MMAP_MAX
, 0);
2875 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2876 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2878 #ifdef DOUG_LEA_MALLOC
2879 /* Back to a reasonable maximum of mmap'ed areas. */
2881 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2885 consing_since_gc
+= nbytes
;
2886 vector_cells_consed
+= len
;
2888 p
->next
= all_vectors
;
2895 /* Allocate a vector with NSLOTS slots. */
2897 struct Lisp_Vector
*
2898 allocate_vector (nslots
)
2901 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2907 /* Allocate other vector-like structures. */
2909 struct Lisp_Hash_Table
*
2910 allocate_hash_table ()
2912 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2913 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2917 for (i
= 0; i
< len
; ++i
)
2918 v
->contents
[i
] = Qnil
;
2920 return (struct Lisp_Hash_Table
*) v
;
2927 EMACS_INT len
= VECSIZE (struct window
);
2928 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2931 for (i
= 0; i
< len
; ++i
)
2932 v
->contents
[i
] = Qnil
;
2935 return (struct window
*) v
;
2942 EMACS_INT len
= VECSIZE (struct frame
);
2943 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2946 for (i
= 0; i
< len
; ++i
)
2947 v
->contents
[i
] = make_number (0);
2949 return (struct frame
*) v
;
2953 struct Lisp_Process
*
2956 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2957 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2960 for (i
= 0; i
< len
; ++i
)
2961 v
->contents
[i
] = Qnil
;
2964 return (struct Lisp_Process
*) v
;
2968 struct Lisp_Vector
*
2969 allocate_other_vector (len
)
2972 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2975 for (i
= 0; i
< len
; ++i
)
2976 v
->contents
[i
] = Qnil
;
2983 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2984 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2985 See also the function `vector'. */)
2987 register Lisp_Object length
, init
;
2990 register EMACS_INT sizei
;
2992 register struct Lisp_Vector
*p
;
2994 CHECK_NATNUM (length
);
2995 sizei
= XFASTINT (length
);
2997 p
= allocate_vector (sizei
);
2998 for (index
= 0; index
< sizei
; index
++)
2999 p
->contents
[index
] = init
;
3001 XSETVECTOR (vector
, p
);
3006 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
3007 doc
: /* Return a newly created char-table, with purpose PURPOSE.
3008 Each element is initialized to INIT, which defaults to nil.
3009 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
3010 The property's value should be an integer between 0 and 10. */)
3012 register Lisp_Object purpose
, init
;
3016 CHECK_SYMBOL (purpose
);
3017 n
= Fget (purpose
, Qchar_table_extra_slots
);
3019 if (XINT (n
) < 0 || XINT (n
) > 10)
3020 args_out_of_range (n
, Qnil
);
3021 /* Add 2 to the size for the defalt and parent slots. */
3022 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
3024 XCHAR_TABLE (vector
)->top
= Qt
;
3025 XCHAR_TABLE (vector
)->parent
= Qnil
;
3026 XCHAR_TABLE (vector
)->purpose
= purpose
;
3027 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3032 /* Return a newly created sub char table with slots initialized by INIT.
3033 Since a sub char table does not appear as a top level Emacs Lisp
3034 object, we don't need a Lisp interface to make it. */
3037 make_sub_char_table (init
)
3041 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), init
);
3042 XCHAR_TABLE (vector
)->top
= Qnil
;
3043 XCHAR_TABLE (vector
)->defalt
= Qnil
;
3044 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3049 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3050 doc
: /* Return a newly created vector with specified arguments as elements.
3051 Any number of arguments, even zero arguments, are allowed.
3052 usage: (vector &rest OBJECTS) */)
3057 register Lisp_Object len
, val
;
3059 register struct Lisp_Vector
*p
;
3061 XSETFASTINT (len
, nargs
);
3062 val
= Fmake_vector (len
, Qnil
);
3064 for (index
= 0; index
< nargs
; index
++)
3065 p
->contents
[index
] = args
[index
];
3070 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3071 doc
: /* Create a byte-code object with specified arguments as elements.
3072 The arguments should be the arglist, bytecode-string, constant vector,
3073 stack size, (optional) doc string, and (optional) interactive spec.
3074 The first four arguments are required; at most six have any
3076 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3081 register Lisp_Object len
, val
;
3083 register struct Lisp_Vector
*p
;
3085 XSETFASTINT (len
, nargs
);
3086 if (!NILP (Vpurify_flag
))
3087 val
= make_pure_vector ((EMACS_INT
) nargs
);
3089 val
= Fmake_vector (len
, Qnil
);
3091 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3092 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3093 earlier because they produced a raw 8-bit string for byte-code
3094 and now such a byte-code string is loaded as multibyte while
3095 raw 8-bit characters converted to multibyte form. Thus, now we
3096 must convert them back to the original unibyte form. */
3097 args
[1] = Fstring_as_unibyte (args
[1]);
3100 for (index
= 0; index
< nargs
; index
++)
3102 if (!NILP (Vpurify_flag
))
3103 args
[index
] = Fpurecopy (args
[index
]);
3104 p
->contents
[index
] = args
[index
];
3106 XSETCOMPILED (val
, p
);
3112 /***********************************************************************
3114 ***********************************************************************/
3116 /* Each symbol_block is just under 1020 bytes long, since malloc
3117 really allocates in units of powers of two and uses 4 bytes for its
3120 #define SYMBOL_BLOCK_SIZE \
3121 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3125 /* Place `symbols' first, to preserve alignment. */
3126 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3127 struct symbol_block
*next
;
3130 /* Current symbol block and index of first unused Lisp_Symbol
3133 struct symbol_block
*symbol_block
;
3134 int symbol_block_index
;
3136 /* List of free symbols. */
3138 struct Lisp_Symbol
*symbol_free_list
;
3140 /* Total number of symbol blocks now in use. */
3142 int n_symbol_blocks
;
3145 /* Initialize symbol allocation. */
3150 symbol_block
= NULL
;
3151 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3152 symbol_free_list
= 0;
3153 n_symbol_blocks
= 0;
3157 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3158 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3159 Its value and function definition are void, and its property list is nil. */)
3163 register Lisp_Object val
;
3164 register struct Lisp_Symbol
*p
;
3166 CHECK_STRING (name
);
3168 if (symbol_free_list
)
3170 XSETSYMBOL (val
, symbol_free_list
);
3171 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
3175 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3177 struct symbol_block
*new;
3178 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3180 new->next
= symbol_block
;
3182 symbol_block_index
= 0;
3185 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3186 symbol_block_index
++;
3192 p
->value
= Qunbound
;
3193 p
->function
= Qunbound
;
3196 p
->interned
= SYMBOL_UNINTERNED
;
3198 p
->indirect_variable
= 0;
3199 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3206 /***********************************************************************
3207 Marker (Misc) Allocation
3208 ***********************************************************************/
3210 /* Allocation of markers and other objects that share that structure.
3211 Works like allocation of conses. */
3213 #define MARKER_BLOCK_SIZE \
3214 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3218 /* Place `markers' first, to preserve alignment. */
3219 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3220 struct marker_block
*next
;
3223 struct marker_block
*marker_block
;
3224 int marker_block_index
;
3226 union Lisp_Misc
*marker_free_list
;
3228 /* Total number of marker blocks now in use. */
3230 int n_marker_blocks
;
3235 marker_block
= NULL
;
3236 marker_block_index
= MARKER_BLOCK_SIZE
;
3237 marker_free_list
= 0;
3238 n_marker_blocks
= 0;
3241 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3248 if (marker_free_list
)
3250 XSETMISC (val
, marker_free_list
);
3251 marker_free_list
= marker_free_list
->u_free
.chain
;
3255 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3257 struct marker_block
*new;
3258 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3260 new->next
= marker_block
;
3262 marker_block_index
= 0;
3264 total_free_markers
+= MARKER_BLOCK_SIZE
;
3266 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3267 marker_block_index
++;
3270 --total_free_markers
;
3271 consing_since_gc
+= sizeof (union Lisp_Misc
);
3272 misc_objects_consed
++;
3273 XMARKER (val
)->gcmarkbit
= 0;
3277 /* Free a Lisp_Misc object */
3283 XMISC (misc
)->u_marker
.type
= Lisp_Misc_Free
;
3284 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3285 marker_free_list
= XMISC (misc
);
3287 total_free_markers
++;
3290 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3291 INTEGER. This is used to package C values to call record_unwind_protect.
3292 The unwind function can get the C values back using XSAVE_VALUE. */
3295 make_save_value (pointer
, integer
)
3299 register Lisp_Object val
;
3300 register struct Lisp_Save_Value
*p
;
3302 val
= allocate_misc ();
3303 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3304 p
= XSAVE_VALUE (val
);
3305 p
->pointer
= pointer
;
3306 p
->integer
= integer
;
3311 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3312 doc
: /* Return a newly allocated marker which does not point at any place. */)
3315 register Lisp_Object val
;
3316 register struct Lisp_Marker
*p
;
3318 val
= allocate_misc ();
3319 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3325 p
->insertion_type
= 0;
3329 /* Put MARKER back on the free list after using it temporarily. */
3332 free_marker (marker
)
3335 unchain_marker (XMARKER (marker
));
3340 /* Return a newly created vector or string with specified arguments as
3341 elements. If all the arguments are characters that can fit
3342 in a string of events, make a string; otherwise, make a vector.
3344 Any number of arguments, even zero arguments, are allowed. */
3347 make_event_array (nargs
, args
)
3353 for (i
= 0; i
< nargs
; i
++)
3354 /* The things that fit in a string
3355 are characters that are in 0...127,
3356 after discarding the meta bit and all the bits above it. */
3357 if (!INTEGERP (args
[i
])
3358 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3359 return Fvector (nargs
, args
);
3361 /* Since the loop exited, we know that all the things in it are
3362 characters, so we can make a string. */
3366 result
= Fmake_string (make_number (nargs
), make_number (0));
3367 for (i
= 0; i
< nargs
; i
++)
3369 SSET (result
, i
, XINT (args
[i
]));
3370 /* Move the meta bit to the right place for a string char. */
3371 if (XINT (args
[i
]) & CHAR_META
)
3372 SSET (result
, i
, SREF (result
, i
) | 0x80);
3381 /************************************************************************
3383 ************************************************************************/
3385 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3387 /* Conservative C stack marking requires a method to identify possibly
3388 live Lisp objects given a pointer value. We do this by keeping
3389 track of blocks of Lisp data that are allocated in a red-black tree
3390 (see also the comment of mem_node which is the type of nodes in
3391 that tree). Function lisp_malloc adds information for an allocated
3392 block to the red-black tree with calls to mem_insert, and function
3393 lisp_free removes it with mem_delete. Functions live_string_p etc
3394 call mem_find to lookup information about a given pointer in the
3395 tree, and use that to determine if the pointer points to a Lisp
3398 /* Initialize this part of alloc.c. */
3403 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3404 mem_z
.parent
= NULL
;
3405 mem_z
.color
= MEM_BLACK
;
3406 mem_z
.start
= mem_z
.end
= NULL
;
3411 /* Value is a pointer to the mem_node containing START. Value is
3412 MEM_NIL if there is no node in the tree containing START. */
3414 static INLINE
struct mem_node
*
3420 if (start
< min_heap_address
|| start
> max_heap_address
)
3423 /* Make the search always successful to speed up the loop below. */
3424 mem_z
.start
= start
;
3425 mem_z
.end
= (char *) start
+ 1;
3428 while (start
< p
->start
|| start
>= p
->end
)
3429 p
= start
< p
->start
? p
->left
: p
->right
;
3434 /* Insert a new node into the tree for a block of memory with start
3435 address START, end address END, and type TYPE. Value is a
3436 pointer to the node that was inserted. */
3438 static struct mem_node
*
3439 mem_insert (start
, end
, type
)
3443 struct mem_node
*c
, *parent
, *x
;
3445 if (start
< min_heap_address
)
3446 min_heap_address
= start
;
3447 if (end
> max_heap_address
)
3448 max_heap_address
= end
;
3450 /* See where in the tree a node for START belongs. In this
3451 particular application, it shouldn't happen that a node is already
3452 present. For debugging purposes, let's check that. */
3456 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3458 while (c
!= MEM_NIL
)
3460 if (start
>= c
->start
&& start
< c
->end
)
3463 c
= start
< c
->start
? c
->left
: c
->right
;
3466 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3468 while (c
!= MEM_NIL
)
3471 c
= start
< c
->start
? c
->left
: c
->right
;
3474 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3476 /* Create a new node. */
3477 #ifdef GC_MALLOC_CHECK
3478 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3482 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3488 x
->left
= x
->right
= MEM_NIL
;
3491 /* Insert it as child of PARENT or install it as root. */
3494 if (start
< parent
->start
)
3502 /* Re-establish red-black tree properties. */
3503 mem_insert_fixup (x
);
3509 /* Re-establish the red-black properties of the tree, and thereby
3510 balance the tree, after node X has been inserted; X is always red. */
3513 mem_insert_fixup (x
)
3516 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3518 /* X is red and its parent is red. This is a violation of
3519 red-black tree property #3. */
3521 if (x
->parent
== x
->parent
->parent
->left
)
3523 /* We're on the left side of our grandparent, and Y is our
3525 struct mem_node
*y
= x
->parent
->parent
->right
;
3527 if (y
->color
== MEM_RED
)
3529 /* Uncle and parent are red but should be black because
3530 X is red. Change the colors accordingly and proceed
3531 with the grandparent. */
3532 x
->parent
->color
= MEM_BLACK
;
3533 y
->color
= MEM_BLACK
;
3534 x
->parent
->parent
->color
= MEM_RED
;
3535 x
= x
->parent
->parent
;
3539 /* Parent and uncle have different colors; parent is
3540 red, uncle is black. */
3541 if (x
== x
->parent
->right
)
3544 mem_rotate_left (x
);
3547 x
->parent
->color
= MEM_BLACK
;
3548 x
->parent
->parent
->color
= MEM_RED
;
3549 mem_rotate_right (x
->parent
->parent
);
3554 /* This is the symmetrical case of above. */
3555 struct mem_node
*y
= x
->parent
->parent
->left
;
3557 if (y
->color
== MEM_RED
)
3559 x
->parent
->color
= MEM_BLACK
;
3560 y
->color
= MEM_BLACK
;
3561 x
->parent
->parent
->color
= MEM_RED
;
3562 x
= x
->parent
->parent
;
3566 if (x
== x
->parent
->left
)
3569 mem_rotate_right (x
);
3572 x
->parent
->color
= MEM_BLACK
;
3573 x
->parent
->parent
->color
= MEM_RED
;
3574 mem_rotate_left (x
->parent
->parent
);
3579 /* The root may have been changed to red due to the algorithm. Set
3580 it to black so that property #5 is satisfied. */
3581 mem_root
->color
= MEM_BLACK
;
3597 /* Turn y's left sub-tree into x's right sub-tree. */
3600 if (y
->left
!= MEM_NIL
)
3601 y
->left
->parent
= x
;
3603 /* Y's parent was x's parent. */
3605 y
->parent
= x
->parent
;
3607 /* Get the parent to point to y instead of x. */
3610 if (x
== x
->parent
->left
)
3611 x
->parent
->left
= y
;
3613 x
->parent
->right
= y
;
3618 /* Put x on y's left. */
3632 mem_rotate_right (x
)
3635 struct mem_node
*y
= x
->left
;
3638 if (y
->right
!= MEM_NIL
)
3639 y
->right
->parent
= x
;
3642 y
->parent
= x
->parent
;
3645 if (x
== x
->parent
->right
)
3646 x
->parent
->right
= y
;
3648 x
->parent
->left
= y
;
3659 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3665 struct mem_node
*x
, *y
;
3667 if (!z
|| z
== MEM_NIL
)
3670 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3675 while (y
->left
!= MEM_NIL
)
3679 if (y
->left
!= MEM_NIL
)
3684 x
->parent
= y
->parent
;
3687 if (y
== y
->parent
->left
)
3688 y
->parent
->left
= x
;
3690 y
->parent
->right
= x
;
3697 z
->start
= y
->start
;
3702 if (y
->color
== MEM_BLACK
)
3703 mem_delete_fixup (x
);
3705 #ifdef GC_MALLOC_CHECK
3713 /* Re-establish the red-black properties of the tree, after a
3717 mem_delete_fixup (x
)
3720 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3722 if (x
== x
->parent
->left
)
3724 struct mem_node
*w
= x
->parent
->right
;
3726 if (w
->color
== MEM_RED
)
3728 w
->color
= MEM_BLACK
;
3729 x
->parent
->color
= MEM_RED
;
3730 mem_rotate_left (x
->parent
);
3731 w
= x
->parent
->right
;
3734 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3741 if (w
->right
->color
== MEM_BLACK
)
3743 w
->left
->color
= MEM_BLACK
;
3745 mem_rotate_right (w
);
3746 w
= x
->parent
->right
;
3748 w
->color
= x
->parent
->color
;
3749 x
->parent
->color
= MEM_BLACK
;
3750 w
->right
->color
= MEM_BLACK
;
3751 mem_rotate_left (x
->parent
);
3757 struct mem_node
*w
= x
->parent
->left
;
3759 if (w
->color
== MEM_RED
)
3761 w
->color
= MEM_BLACK
;
3762 x
->parent
->color
= MEM_RED
;
3763 mem_rotate_right (x
->parent
);
3764 w
= x
->parent
->left
;
3767 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3774 if (w
->left
->color
== MEM_BLACK
)
3776 w
->right
->color
= MEM_BLACK
;
3778 mem_rotate_left (w
);
3779 w
= x
->parent
->left
;
3782 w
->color
= x
->parent
->color
;
3783 x
->parent
->color
= MEM_BLACK
;
3784 w
->left
->color
= MEM_BLACK
;
3785 mem_rotate_right (x
->parent
);
3791 x
->color
= MEM_BLACK
;
3795 /* Value is non-zero if P is a pointer to a live Lisp string on
3796 the heap. M is a pointer to the mem_block for P. */
3799 live_string_p (m
, p
)
3803 if (m
->type
== MEM_TYPE_STRING
)
3805 struct string_block
*b
= (struct string_block
*) m
->start
;
3806 int offset
= (char *) p
- (char *) &b
->strings
[0];
3808 /* P must point to the start of a Lisp_String structure, and it
3809 must not be on the free-list. */
3811 && offset
% sizeof b
->strings
[0] == 0
3812 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3813 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3820 /* Value is non-zero if P is a pointer to a live Lisp cons on
3821 the heap. M is a pointer to the mem_block for P. */
3828 if (m
->type
== MEM_TYPE_CONS
)
3830 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3831 int offset
= (char *) p
- (char *) &b
->conses
[0];
3833 /* P must point to the start of a Lisp_Cons, not be
3834 one of the unused cells in the current cons block,
3835 and not be on the free-list. */
3837 && offset
% sizeof b
->conses
[0] == 0
3838 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3840 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3841 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3848 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3849 the heap. M is a pointer to the mem_block for P. */
3852 live_symbol_p (m
, p
)
3856 if (m
->type
== MEM_TYPE_SYMBOL
)
3858 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3859 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3861 /* P must point to the start of a Lisp_Symbol, not be
3862 one of the unused cells in the current symbol block,
3863 and not be on the free-list. */
3865 && offset
% sizeof b
->symbols
[0] == 0
3866 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3867 && (b
!= symbol_block
3868 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3869 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3876 /* Value is non-zero if P is a pointer to a live Lisp float on
3877 the heap. M is a pointer to the mem_block for P. */
3884 if (m
->type
== MEM_TYPE_FLOAT
)
3886 struct float_block
*b
= (struct float_block
*) m
->start
;
3887 int offset
= (char *) p
- (char *) &b
->floats
[0];
3889 /* P must point to the start of a Lisp_Float and not be
3890 one of the unused cells in the current float block. */
3892 && offset
% sizeof b
->floats
[0] == 0
3893 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3894 && (b
!= float_block
3895 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3902 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3903 the heap. M is a pointer to the mem_block for P. */
3910 if (m
->type
== MEM_TYPE_MISC
)
3912 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3913 int offset
= (char *) p
- (char *) &b
->markers
[0];
3915 /* P must point to the start of a Lisp_Misc, not be
3916 one of the unused cells in the current misc block,
3917 and not be on the free-list. */
3919 && offset
% sizeof b
->markers
[0] == 0
3920 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3921 && (b
!= marker_block
3922 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3923 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3930 /* Value is non-zero if P is a pointer to a live vector-like object.
3931 M is a pointer to the mem_block for P. */
3934 live_vector_p (m
, p
)
3938 return (p
== m
->start
3939 && m
->type
>= MEM_TYPE_VECTOR
3940 && m
->type
<= MEM_TYPE_WINDOW
);
3944 /* Value is non-zero if P is a pointer to a live buffer. M is a
3945 pointer to the mem_block for P. */
3948 live_buffer_p (m
, p
)
3952 /* P must point to the start of the block, and the buffer
3953 must not have been killed. */
3954 return (m
->type
== MEM_TYPE_BUFFER
3956 && !NILP (((struct buffer
*) p
)->name
));
3959 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3963 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3965 /* Array of objects that are kept alive because the C stack contains
3966 a pattern that looks like a reference to them . */
3968 #define MAX_ZOMBIES 10
3969 static Lisp_Object zombies
[MAX_ZOMBIES
];
3971 /* Number of zombie objects. */
3973 static int nzombies
;
3975 /* Number of garbage collections. */
3979 /* Average percentage of zombies per collection. */
3981 static double avg_zombies
;
3983 /* Max. number of live and zombie objects. */
3985 static int max_live
, max_zombies
;
3987 /* Average number of live objects per GC. */
3989 static double avg_live
;
3991 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3992 doc
: /* Show information about live and zombie objects. */)
3995 Lisp_Object args
[8], zombie_list
= Qnil
;
3997 for (i
= 0; i
< nzombies
; i
++)
3998 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3999 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4000 args
[1] = make_number (ngcs
);
4001 args
[2] = make_float (avg_live
);
4002 args
[3] = make_float (avg_zombies
);
4003 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4004 args
[5] = make_number (max_live
);
4005 args
[6] = make_number (max_zombies
);
4006 args
[7] = zombie_list
;
4007 return Fmessage (8, args
);
4010 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4013 /* Mark OBJ if we can prove it's a Lisp_Object. */
4016 mark_maybe_object (obj
)
4019 void *po
= (void *) XPNTR (obj
);
4020 struct mem_node
*m
= mem_find (po
);
4026 switch (XGCTYPE (obj
))
4029 mark_p
= (live_string_p (m
, po
)
4030 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4034 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4038 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4042 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4045 case Lisp_Vectorlike
:
4046 /* Note: can't check GC_BUFFERP before we know it's a
4047 buffer because checking that dereferences the pointer
4048 PO which might point anywhere. */
4049 if (live_vector_p (m
, po
))
4050 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4051 else if (live_buffer_p (m
, po
))
4052 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4056 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
4060 case Lisp_Type_Limit
:
4066 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4067 if (nzombies
< MAX_ZOMBIES
)
4068 zombies
[nzombies
] = obj
;
4077 /* If P points to Lisp data, mark that as live if it isn't already
4081 mark_maybe_pointer (p
)
4086 /* Quickly rule out some values which can't point to Lisp data. We
4087 assume that Lisp data is aligned on even addresses. */
4088 if ((EMACS_INT
) p
& 1)
4094 Lisp_Object obj
= Qnil
;
4098 case MEM_TYPE_NON_LISP
:
4099 /* Nothing to do; not a pointer to Lisp memory. */
4102 case MEM_TYPE_BUFFER
:
4103 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4104 XSETVECTOR (obj
, p
);
4108 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4112 case MEM_TYPE_STRING
:
4113 if (live_string_p (m
, p
)
4114 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4115 XSETSTRING (obj
, p
);
4119 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4123 case MEM_TYPE_SYMBOL
:
4124 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4125 XSETSYMBOL (obj
, p
);
4128 case MEM_TYPE_FLOAT
:
4129 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4133 case MEM_TYPE_VECTOR
:
4134 case MEM_TYPE_PROCESS
:
4135 case MEM_TYPE_HASH_TABLE
:
4136 case MEM_TYPE_FRAME
:
4137 case MEM_TYPE_WINDOW
:
4138 if (live_vector_p (m
, p
))
4141 XSETVECTOR (tem
, p
);
4142 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4157 /* Mark Lisp objects referenced from the address range START..END. */
4160 mark_memory (start
, end
)
4166 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4170 /* Make START the pointer to the start of the memory region,
4171 if it isn't already. */
4179 /* Mark Lisp_Objects. */
4180 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
4181 mark_maybe_object (*p
);
4183 /* Mark Lisp data pointed to. This is necessary because, in some
4184 situations, the C compiler optimizes Lisp objects away, so that
4185 only a pointer to them remains. Example:
4187 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4190 Lisp_Object obj = build_string ("test");
4191 struct Lisp_String *s = XSTRING (obj);
4192 Fgarbage_collect ();
4193 fprintf (stderr, "test `%s'\n", s->data);
4197 Here, `obj' isn't really used, and the compiler optimizes it
4198 away. The only reference to the life string is through the
4201 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
4202 mark_maybe_pointer (*pp
);
4205 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4206 the GCC system configuration. In gcc 3.2, the only systems for
4207 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4208 by others?) and ns32k-pc532-min. */
4210 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4212 static int setjmp_tested_p
, longjmps_done
;
4214 #define SETJMP_WILL_LIKELY_WORK "\
4216 Emacs garbage collector has been changed to use conservative stack\n\
4217 marking. Emacs has determined that the method it uses to do the\n\
4218 marking will likely work on your system, but this isn't sure.\n\
4220 If you are a system-programmer, or can get the help of a local wizard\n\
4221 who is, please take a look at the function mark_stack in alloc.c, and\n\
4222 verify that the methods used are appropriate for your system.\n\
4224 Please mail the result to <emacs-devel@gnu.org>.\n\
4227 #define SETJMP_WILL_NOT_WORK "\
4229 Emacs garbage collector has been changed to use conservative stack\n\
4230 marking. Emacs has determined that the default method it uses to do the\n\
4231 marking will not work on your system. We will need a system-dependent\n\
4232 solution for your system.\n\
4234 Please take a look at the function mark_stack in alloc.c, and\n\
4235 try to find a way to make it work on your system.\n\
4237 Note that you may get false negatives, depending on the compiler.\n\
4238 In particular, you need to use -O with GCC for this test.\n\
4240 Please mail the result to <emacs-devel@gnu.org>.\n\
4244 /* Perform a quick check if it looks like setjmp saves registers in a
4245 jmp_buf. Print a message to stderr saying so. When this test
4246 succeeds, this is _not_ a proof that setjmp is sufficient for
4247 conservative stack marking. Only the sources or a disassembly
4258 /* Arrange for X to be put in a register. */
4264 if (longjmps_done
== 1)
4266 /* Came here after the longjmp at the end of the function.
4268 If x == 1, the longjmp has restored the register to its
4269 value before the setjmp, and we can hope that setjmp
4270 saves all such registers in the jmp_buf, although that
4273 For other values of X, either something really strange is
4274 taking place, or the setjmp just didn't save the register. */
4277 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4280 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4287 if (longjmps_done
== 1)
4291 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4294 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4296 /* Abort if anything GCPRO'd doesn't survive the GC. */
4304 for (p
= gcprolist
; p
; p
= p
->next
)
4305 for (i
= 0; i
< p
->nvars
; ++i
)
4306 if (!survives_gc_p (p
->var
[i
]))
4307 /* FIXME: It's not necessarily a bug. It might just be that the
4308 GCPRO is unnecessary or should release the object sooner. */
4312 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4319 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4320 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4322 fprintf (stderr
, " %d = ", i
);
4323 debug_print (zombies
[i
]);
4327 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4330 /* Mark live Lisp objects on the C stack.
4332 There are several system-dependent problems to consider when
4333 porting this to new architectures:
4337 We have to mark Lisp objects in CPU registers that can hold local
4338 variables or are used to pass parameters.
4340 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4341 something that either saves relevant registers on the stack, or
4342 calls mark_maybe_object passing it each register's contents.
4344 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4345 implementation assumes that calling setjmp saves registers we need
4346 to see in a jmp_buf which itself lies on the stack. This doesn't
4347 have to be true! It must be verified for each system, possibly
4348 by taking a look at the source code of setjmp.
4352 Architectures differ in the way their processor stack is organized.
4353 For example, the stack might look like this
4356 | Lisp_Object | size = 4
4358 | something else | size = 2
4360 | Lisp_Object | size = 4
4364 In such a case, not every Lisp_Object will be aligned equally. To
4365 find all Lisp_Object on the stack it won't be sufficient to walk
4366 the stack in steps of 4 bytes. Instead, two passes will be
4367 necessary, one starting at the start of the stack, and a second
4368 pass starting at the start of the stack + 2. Likewise, if the
4369 minimal alignment of Lisp_Objects on the stack is 1, four passes
4370 would be necessary, each one starting with one byte more offset
4371 from the stack start.
4373 The current code assumes by default that Lisp_Objects are aligned
4374 equally on the stack. */
4381 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4384 /* This trick flushes the register windows so that all the state of
4385 the process is contained in the stack. */
4386 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4387 needed on ia64 too. See mach_dep.c, where it also says inline
4388 assembler doesn't work with relevant proprietary compilers. */
4393 /* Save registers that we need to see on the stack. We need to see
4394 registers used to hold register variables and registers used to
4396 #ifdef GC_SAVE_REGISTERS_ON_STACK
4397 GC_SAVE_REGISTERS_ON_STACK (end
);
4398 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4400 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4401 setjmp will definitely work, test it
4402 and print a message with the result
4404 if (!setjmp_tested_p
)
4406 setjmp_tested_p
= 1;
4409 #endif /* GC_SETJMP_WORKS */
4412 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4413 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4415 /* This assumes that the stack is a contiguous region in memory. If
4416 that's not the case, something has to be done here to iterate
4417 over the stack segments. */
4418 #ifndef GC_LISP_OBJECT_ALIGNMENT
4420 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4422 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4425 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4426 mark_memory ((char *) stack_base
+ i
, end
);
4427 /* Allow for marking a secondary stack, like the register stack on the
4429 #ifdef GC_MARK_SECONDARY_STACK
4430 GC_MARK_SECONDARY_STACK ();
4433 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4439 #endif /* GC_MARK_STACK != 0 */
4443 /***********************************************************************
4444 Pure Storage Management
4445 ***********************************************************************/
4447 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4448 pointer to it. TYPE is the Lisp type for which the memory is
4449 allocated. TYPE < 0 means it's not used for a Lisp object.
4451 If store_pure_type_info is set and TYPE is >= 0, the type of
4452 the allocated object is recorded in pure_types. */
4454 static POINTER_TYPE
*
4455 pure_alloc (size
, type
)
4459 POINTER_TYPE
*result
;
4461 size_t alignment
= (1 << GCTYPEBITS
);
4463 size_t alignment
= sizeof (EMACS_INT
);
4465 /* Give Lisp_Floats an extra alignment. */
4466 if (type
== Lisp_Float
)
4468 #if defined __GNUC__ && __GNUC__ >= 2
4469 alignment
= __alignof (struct Lisp_Float
);
4471 alignment
= sizeof (struct Lisp_Float
);
4477 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4478 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4480 if (pure_bytes_used
<= pure_size
)
4483 /* Don't allocate a large amount here,
4484 because it might get mmap'd and then its address
4485 might not be usable. */
4486 purebeg
= (char *) xmalloc (10000);
4488 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4489 pure_bytes_used
= 0;
4494 /* Print a warning if PURESIZE is too small. */
4499 if (pure_bytes_used_before_overflow
)
4500 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4501 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4505 /* Return a string allocated in pure space. DATA is a buffer holding
4506 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4507 non-zero means make the result string multibyte.
4509 Must get an error if pure storage is full, since if it cannot hold
4510 a large string it may be able to hold conses that point to that
4511 string; then the string is not protected from gc. */
4514 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4520 struct Lisp_String
*s
;
4522 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4523 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4525 s
->size_byte
= multibyte
? nbytes
: -1;
4526 bcopy (data
, s
->data
, nbytes
);
4527 s
->data
[nbytes
] = '\0';
4528 s
->intervals
= NULL_INTERVAL
;
4529 XSETSTRING (string
, s
);
4534 /* Return a cons allocated from pure space. Give it pure copies
4535 of CAR as car and CDR as cdr. */
4538 pure_cons (car
, cdr
)
4539 Lisp_Object car
, cdr
;
4541 register Lisp_Object
new;
4542 struct Lisp_Cons
*p
;
4544 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4546 XSETCAR (new, Fpurecopy (car
));
4547 XSETCDR (new, Fpurecopy (cdr
));
4552 /* Value is a float object with value NUM allocated from pure space. */
4555 make_pure_float (num
)
4558 register Lisp_Object
new;
4559 struct Lisp_Float
*p
;
4561 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4563 XFLOAT_DATA (new) = num
;
4568 /* Return a vector with room for LEN Lisp_Objects allocated from
4572 make_pure_vector (len
)
4576 struct Lisp_Vector
*p
;
4577 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4579 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4580 XSETVECTOR (new, p
);
4581 XVECTOR (new)->size
= len
;
4586 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4587 doc
: /* Make a copy of OBJECT in pure storage.
4588 Recursively copies contents of vectors and cons cells.
4589 Does not copy symbols. Copies strings without text properties. */)
4591 register Lisp_Object obj
;
4593 if (NILP (Vpurify_flag
))
4596 if (PURE_POINTER_P (XPNTR (obj
)))
4600 return pure_cons (XCAR (obj
), XCDR (obj
));
4601 else if (FLOATP (obj
))
4602 return make_pure_float (XFLOAT_DATA (obj
));
4603 else if (STRINGP (obj
))
4604 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4606 STRING_MULTIBYTE (obj
));
4607 else if (COMPILEDP (obj
) || VECTORP (obj
))
4609 register struct Lisp_Vector
*vec
;
4613 size
= XVECTOR (obj
)->size
;
4614 if (size
& PSEUDOVECTOR_FLAG
)
4615 size
&= PSEUDOVECTOR_SIZE_MASK
;
4616 vec
= XVECTOR (make_pure_vector (size
));
4617 for (i
= 0; i
< size
; i
++)
4618 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4619 if (COMPILEDP (obj
))
4620 XSETCOMPILED (obj
, vec
);
4622 XSETVECTOR (obj
, vec
);
4625 else if (MARKERP (obj
))
4626 error ("Attempt to copy a marker to pure storage");
4633 /***********************************************************************
4635 ***********************************************************************/
4637 /* Put an entry in staticvec, pointing at the variable with address
4641 staticpro (varaddress
)
4642 Lisp_Object
*varaddress
;
4644 staticvec
[staticidx
++] = varaddress
;
4645 if (staticidx
>= NSTATICS
)
4653 struct catchtag
*next
;
4657 /***********************************************************************
4659 ***********************************************************************/
4661 /* Temporarily prevent garbage collection. */
4664 inhibit_garbage_collection ()
4666 int count
= SPECPDL_INDEX ();
4667 int nbits
= min (VALBITS
, BITS_PER_INT
);
4669 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4674 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4675 doc
: /* Reclaim storage for Lisp objects no longer needed.
4676 Garbage collection happens automatically if you cons more than
4677 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4678 `garbage-collect' normally returns a list with info on amount of space in use:
4679 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4680 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4681 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4682 (USED-STRINGS . FREE-STRINGS))
4683 However, if there was overflow in pure space, `garbage-collect'
4684 returns nil, because real GC can't be done. */)
4687 register struct specbinding
*bind
;
4688 struct catchtag
*catch;
4689 struct handler
*handler
;
4690 char stack_top_variable
;
4693 Lisp_Object total
[8];
4694 int count
= SPECPDL_INDEX ();
4695 EMACS_TIME t1
, t2
, t3
;
4700 /* Can't GC if pure storage overflowed because we can't determine
4701 if something is a pure object or not. */
4702 if (pure_bytes_used_before_overflow
)
4707 /* Don't keep undo information around forever.
4708 Do this early on, so it is no problem if the user quits. */
4710 register struct buffer
*nextb
= all_buffers
;
4714 /* If a buffer's undo list is Qt, that means that undo is
4715 turned off in that buffer. Calling truncate_undo_list on
4716 Qt tends to return NULL, which effectively turns undo back on.
4717 So don't call truncate_undo_list if undo_list is Qt. */
4718 if (! NILP (nextb
->name
) && ! EQ (nextb
->undo_list
, Qt
))
4719 truncate_undo_list (nextb
);
4721 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4722 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4724 /* If a buffer's gap size is more than 10% of the buffer
4725 size, or larger than 2000 bytes, then shrink it
4726 accordingly. Keep a minimum size of 20 bytes. */
4727 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4729 if (nextb
->text
->gap_size
> size
)
4731 struct buffer
*save_current
= current_buffer
;
4732 current_buffer
= nextb
;
4733 make_gap (-(nextb
->text
->gap_size
- size
));
4734 current_buffer
= save_current
;
4738 nextb
= nextb
->next
;
4742 EMACS_GET_TIME (t1
);
4744 /* In case user calls debug_print during GC,
4745 don't let that cause a recursive GC. */
4746 consing_since_gc
= 0;
4748 /* Save what's currently displayed in the echo area. */
4749 message_p
= push_message ();
4750 record_unwind_protect (pop_message_unwind
, Qnil
);
4752 /* Save a copy of the contents of the stack, for debugging. */
4753 #if MAX_SAVE_STACK > 0
4754 if (NILP (Vpurify_flag
))
4756 i
= &stack_top_variable
- stack_bottom
;
4758 if (i
< MAX_SAVE_STACK
)
4760 if (stack_copy
== 0)
4761 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4762 else if (stack_copy_size
< i
)
4763 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4766 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4767 bcopy (stack_bottom
, stack_copy
, i
);
4769 bcopy (&stack_top_variable
, stack_copy
, i
);
4773 #endif /* MAX_SAVE_STACK > 0 */
4775 if (garbage_collection_messages
)
4776 message1_nolog ("Garbage collecting...");
4780 shrink_regexp_cache ();
4784 /* clear_marks (); */
4786 /* Mark all the special slots that serve as the roots of accessibility. */
4788 for (i
= 0; i
< staticidx
; i
++)
4789 mark_object (*staticvec
[i
]);
4791 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4793 mark_object (bind
->symbol
);
4794 mark_object (bind
->old_value
);
4800 extern void xg_mark_data ();
4805 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4806 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4810 register struct gcpro
*tail
;
4811 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4812 for (i
= 0; i
< tail
->nvars
; i
++)
4813 mark_object (tail
->var
[i
]);
4818 for (catch = catchlist
; catch; catch = catch->next
)
4820 mark_object (catch->tag
);
4821 mark_object (catch->val
);
4823 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4825 mark_object (handler
->handler
);
4826 mark_object (handler
->var
);
4830 #ifdef HAVE_WINDOW_SYSTEM
4831 mark_fringe_data ();
4834 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4838 /* Everything is now marked, except for the things that require special
4839 finalization, i.e. the undo_list.
4840 Look thru every buffer's undo list
4841 for elements that update markers that were not marked,
4844 register struct buffer
*nextb
= all_buffers
;
4848 /* If a buffer's undo list is Qt, that means that undo is
4849 turned off in that buffer. Calling truncate_undo_list on
4850 Qt tends to return NULL, which effectively turns undo back on.
4851 So don't call truncate_undo_list if undo_list is Qt. */
4852 if (! EQ (nextb
->undo_list
, Qt
))
4854 Lisp_Object tail
, prev
;
4855 tail
= nextb
->undo_list
;
4857 while (CONSP (tail
))
4859 if (GC_CONSP (XCAR (tail
))
4860 && GC_MARKERP (XCAR (XCAR (tail
)))
4861 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
4864 nextb
->undo_list
= tail
= XCDR (tail
);
4868 XSETCDR (prev
, tail
);
4878 /* Now that we have stripped the elements that need not be in the
4879 undo_list any more, we can finally mark the list. */
4880 mark_object (nextb
->undo_list
);
4882 nextb
= nextb
->next
;
4888 /* Clear the mark bits that we set in certain root slots. */
4890 unmark_byte_stack ();
4891 VECTOR_UNMARK (&buffer_defaults
);
4892 VECTOR_UNMARK (&buffer_local_symbols
);
4894 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4902 /* clear_marks (); */
4905 consing_since_gc
= 0;
4906 if (gc_cons_threshold
< 10000)
4907 gc_cons_threshold
= 10000;
4909 if (FLOATP (Vgc_cons_percentage
))
4910 { /* Set gc_cons_combined_threshold. */
4911 EMACS_INT total
= 0;
4913 total
+= total_conses
* sizeof (struct Lisp_Cons
);
4914 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
4915 total
+= total_markers
* sizeof (union Lisp_Misc
);
4916 total
+= total_string_size
;
4917 total
+= total_vector_size
* sizeof (Lisp_Object
);
4918 total
+= total_floats
* sizeof (struct Lisp_Float
);
4919 total
+= total_intervals
* sizeof (struct interval
);
4920 total
+= total_strings
* sizeof (struct Lisp_String
);
4922 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
4925 gc_relative_threshold
= 0;
4927 if (garbage_collection_messages
)
4929 if (message_p
|| minibuf_level
> 0)
4932 message1_nolog ("Garbage collecting...done");
4935 unbind_to (count
, Qnil
);
4937 total
[0] = Fcons (make_number (total_conses
),
4938 make_number (total_free_conses
));
4939 total
[1] = Fcons (make_number (total_symbols
),
4940 make_number (total_free_symbols
));
4941 total
[2] = Fcons (make_number (total_markers
),
4942 make_number (total_free_markers
));
4943 total
[3] = make_number (total_string_size
);
4944 total
[4] = make_number (total_vector_size
);
4945 total
[5] = Fcons (make_number (total_floats
),
4946 make_number (total_free_floats
));
4947 total
[6] = Fcons (make_number (total_intervals
),
4948 make_number (total_free_intervals
));
4949 total
[7] = Fcons (make_number (total_strings
),
4950 make_number (total_free_strings
));
4952 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4954 /* Compute average percentage of zombies. */
4957 for (i
= 0; i
< 7; ++i
)
4958 if (CONSP (total
[i
]))
4959 nlive
+= XFASTINT (XCAR (total
[i
]));
4961 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4962 max_live
= max (nlive
, max_live
);
4963 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4964 max_zombies
= max (nzombies
, max_zombies
);
4969 if (!NILP (Vpost_gc_hook
))
4971 int count
= inhibit_garbage_collection ();
4972 safe_run_hooks (Qpost_gc_hook
);
4973 unbind_to (count
, Qnil
);
4976 /* Accumulate statistics. */
4977 EMACS_GET_TIME (t2
);
4978 EMACS_SUB_TIME (t3
, t2
, t1
);
4979 if (FLOATP (Vgc_elapsed
))
4980 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
4982 EMACS_USECS (t3
) * 1.0e-6);
4985 return Flist (sizeof total
/ sizeof *total
, total
);
4989 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4990 only interesting objects referenced from glyphs are strings. */
4993 mark_glyph_matrix (matrix
)
4994 struct glyph_matrix
*matrix
;
4996 struct glyph_row
*row
= matrix
->rows
;
4997 struct glyph_row
*end
= row
+ matrix
->nrows
;
4999 for (; row
< end
; ++row
)
5003 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5005 struct glyph
*glyph
= row
->glyphs
[area
];
5006 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5008 for (; glyph
< end_glyph
; ++glyph
)
5009 if (GC_STRINGP (glyph
->object
)
5010 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5011 mark_object (glyph
->object
);
5017 /* Mark Lisp faces in the face cache C. */
5021 struct face_cache
*c
;
5026 for (i
= 0; i
< c
->used
; ++i
)
5028 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5032 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5033 mark_object (face
->lface
[j
]);
5040 #ifdef HAVE_WINDOW_SYSTEM
5042 /* Mark Lisp objects in image IMG. */
5048 mark_object (img
->spec
);
5050 if (!NILP (img
->data
.lisp_val
))
5051 mark_object (img
->data
.lisp_val
);
5055 /* Mark Lisp objects in image cache of frame F. It's done this way so
5056 that we don't have to include xterm.h here. */
5059 mark_image_cache (f
)
5062 forall_images_in_image_cache (f
, mark_image
);
5065 #endif /* HAVE_X_WINDOWS */
5069 /* Mark reference to a Lisp_Object.
5070 If the object referred to has not been seen yet, recursively mark
5071 all the references contained in it. */
5073 #define LAST_MARKED_SIZE 500
5074 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5075 int last_marked_index
;
5077 /* For debugging--call abort when we cdr down this many
5078 links of a list, in mark_object. In debugging,
5079 the call to abort will hit a breakpoint.
5080 Normally this is zero and the check never goes off. */
5081 int mark_object_loop_halt
;
5087 register Lisp_Object obj
= arg
;
5088 #ifdef GC_CHECK_MARKED_OBJECTS
5096 if (PURE_POINTER_P (XPNTR (obj
)))
5099 last_marked
[last_marked_index
++] = obj
;
5100 if (last_marked_index
== LAST_MARKED_SIZE
)
5101 last_marked_index
= 0;
5103 /* Perform some sanity checks on the objects marked here. Abort if
5104 we encounter an object we know is bogus. This increases GC time
5105 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5106 #ifdef GC_CHECK_MARKED_OBJECTS
5108 po
= (void *) XPNTR (obj
);
5110 /* Check that the object pointed to by PO is known to be a Lisp
5111 structure allocated from the heap. */
5112 #define CHECK_ALLOCATED() \
5114 m = mem_find (po); \
5119 /* Check that the object pointed to by PO is live, using predicate
5121 #define CHECK_LIVE(LIVEP) \
5123 if (!LIVEP (m, po)) \
5127 /* Check both of the above conditions. */
5128 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5130 CHECK_ALLOCATED (); \
5131 CHECK_LIVE (LIVEP); \
5134 #else /* not GC_CHECK_MARKED_OBJECTS */
5136 #define CHECK_ALLOCATED() (void) 0
5137 #define CHECK_LIVE(LIVEP) (void) 0
5138 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5140 #endif /* not GC_CHECK_MARKED_OBJECTS */
5142 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
5146 register struct Lisp_String
*ptr
= XSTRING (obj
);
5147 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5148 MARK_INTERVAL_TREE (ptr
->intervals
);
5150 #ifdef GC_CHECK_STRING_BYTES
5151 /* Check that the string size recorded in the string is the
5152 same as the one recorded in the sdata structure. */
5153 CHECK_STRING_BYTES (ptr
);
5154 #endif /* GC_CHECK_STRING_BYTES */
5158 case Lisp_Vectorlike
:
5159 #ifdef GC_CHECK_MARKED_OBJECTS
5161 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
5162 && po
!= &buffer_defaults
5163 && po
!= &buffer_local_symbols
)
5165 #endif /* GC_CHECK_MARKED_OBJECTS */
5167 if (GC_BUFFERP (obj
))
5169 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
5171 #ifdef GC_CHECK_MARKED_OBJECTS
5172 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5175 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5180 #endif /* GC_CHECK_MARKED_OBJECTS */
5184 else if (GC_SUBRP (obj
))
5186 else if (GC_COMPILEDP (obj
))
5187 /* We could treat this just like a vector, but it is better to
5188 save the COMPILED_CONSTANTS element for last and avoid
5191 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5192 register EMACS_INT size
= ptr
->size
;
5195 if (VECTOR_MARKED_P (ptr
))
5196 break; /* Already marked */
5198 CHECK_LIVE (live_vector_p
);
5199 VECTOR_MARK (ptr
); /* Else mark it */
5200 size
&= PSEUDOVECTOR_SIZE_MASK
;
5201 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5203 if (i
!= COMPILED_CONSTANTS
)
5204 mark_object (ptr
->contents
[i
]);
5206 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5209 else if (GC_FRAMEP (obj
))
5211 register struct frame
*ptr
= XFRAME (obj
);
5213 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5214 VECTOR_MARK (ptr
); /* Else mark it */
5216 CHECK_LIVE (live_vector_p
);
5217 mark_object (ptr
->name
);
5218 mark_object (ptr
->icon_name
);
5219 mark_object (ptr
->title
);
5220 mark_object (ptr
->focus_frame
);
5221 mark_object (ptr
->selected_window
);
5222 mark_object (ptr
->minibuffer_window
);
5223 mark_object (ptr
->param_alist
);
5224 mark_object (ptr
->scroll_bars
);
5225 mark_object (ptr
->condemned_scroll_bars
);
5226 mark_object (ptr
->menu_bar_items
);
5227 mark_object (ptr
->face_alist
);
5228 mark_object (ptr
->menu_bar_vector
);
5229 mark_object (ptr
->buffer_predicate
);
5230 mark_object (ptr
->buffer_list
);
5231 mark_object (ptr
->menu_bar_window
);
5232 mark_object (ptr
->tool_bar_window
);
5233 mark_face_cache (ptr
->face_cache
);
5234 #ifdef HAVE_WINDOW_SYSTEM
5235 mark_image_cache (ptr
);
5236 mark_object (ptr
->tool_bar_items
);
5237 mark_object (ptr
->desired_tool_bar_string
);
5238 mark_object (ptr
->current_tool_bar_string
);
5239 #endif /* HAVE_WINDOW_SYSTEM */
5241 else if (GC_BOOL_VECTOR_P (obj
))
5243 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5245 if (VECTOR_MARKED_P (ptr
))
5246 break; /* Already marked */
5247 CHECK_LIVE (live_vector_p
);
5248 VECTOR_MARK (ptr
); /* Else mark it */
5250 else if (GC_WINDOWP (obj
))
5252 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5253 struct window
*w
= XWINDOW (obj
);
5256 /* Stop if already marked. */
5257 if (VECTOR_MARKED_P (ptr
))
5261 CHECK_LIVE (live_vector_p
);
5264 /* There is no Lisp data above The member CURRENT_MATRIX in
5265 struct WINDOW. Stop marking when that slot is reached. */
5267 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
5269 mark_object (ptr
->contents
[i
]);
5271 /* Mark glyphs for leaf windows. Marking window matrices is
5272 sufficient because frame matrices use the same glyph
5274 if (NILP (w
->hchild
)
5276 && w
->current_matrix
)
5278 mark_glyph_matrix (w
->current_matrix
);
5279 mark_glyph_matrix (w
->desired_matrix
);
5282 else if (GC_HASH_TABLE_P (obj
))
5284 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5286 /* Stop if already marked. */
5287 if (VECTOR_MARKED_P (h
))
5291 CHECK_LIVE (live_vector_p
);
5294 /* Mark contents. */
5295 /* Do not mark next_free or next_weak.
5296 Being in the next_weak chain
5297 should not keep the hash table alive.
5298 No need to mark `count' since it is an integer. */
5299 mark_object (h
->test
);
5300 mark_object (h
->weak
);
5301 mark_object (h
->rehash_size
);
5302 mark_object (h
->rehash_threshold
);
5303 mark_object (h
->hash
);
5304 mark_object (h
->next
);
5305 mark_object (h
->index
);
5306 mark_object (h
->user_hash_function
);
5307 mark_object (h
->user_cmp_function
);
5309 /* If hash table is not weak, mark all keys and values.
5310 For weak tables, mark only the vector. */
5311 if (GC_NILP (h
->weak
))
5312 mark_object (h
->key_and_value
);
5314 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5318 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5319 register EMACS_INT size
= ptr
->size
;
5322 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5323 CHECK_LIVE (live_vector_p
);
5324 VECTOR_MARK (ptr
); /* Else mark it */
5325 if (size
& PSEUDOVECTOR_FLAG
)
5326 size
&= PSEUDOVECTOR_SIZE_MASK
;
5328 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5329 mark_object (ptr
->contents
[i
]);
5335 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5336 struct Lisp_Symbol
*ptrx
;
5338 if (ptr
->gcmarkbit
) break;
5339 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5341 mark_object (ptr
->value
);
5342 mark_object (ptr
->function
);
5343 mark_object (ptr
->plist
);
5345 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5346 MARK_STRING (XSTRING (ptr
->xname
));
5347 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5349 /* Note that we do not mark the obarray of the symbol.
5350 It is safe not to do so because nothing accesses that
5351 slot except to check whether it is nil. */
5355 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5356 XSETSYMBOL (obj
, ptrx
);
5363 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5364 if (XMARKER (obj
)->gcmarkbit
)
5366 XMARKER (obj
)->gcmarkbit
= 1;
5368 switch (XMISCTYPE (obj
))
5370 case Lisp_Misc_Buffer_Local_Value
:
5371 case Lisp_Misc_Some_Buffer_Local_Value
:
5373 register struct Lisp_Buffer_Local_Value
*ptr
5374 = XBUFFER_LOCAL_VALUE (obj
);
5375 /* If the cdr is nil, avoid recursion for the car. */
5376 if (EQ (ptr
->cdr
, Qnil
))
5378 obj
= ptr
->realvalue
;
5381 mark_object (ptr
->realvalue
);
5382 mark_object (ptr
->buffer
);
5383 mark_object (ptr
->frame
);
5388 case Lisp_Misc_Marker
:
5389 /* DO NOT mark thru the marker's chain.
5390 The buffer's markers chain does not preserve markers from gc;
5391 instead, markers are removed from the chain when freed by gc. */
5394 case Lisp_Misc_Intfwd
:
5395 case Lisp_Misc_Boolfwd
:
5396 case Lisp_Misc_Objfwd
:
5397 case Lisp_Misc_Buffer_Objfwd
:
5398 case Lisp_Misc_Kboard_Objfwd
:
5399 /* Don't bother with Lisp_Buffer_Objfwd,
5400 since all markable slots in current buffer marked anyway. */
5401 /* Don't need to do Lisp_Objfwd, since the places they point
5402 are protected with staticpro. */
5405 case Lisp_Misc_Save_Value
:
5408 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5409 /* If DOGC is set, POINTER is the address of a memory
5410 area containing INTEGER potential Lisp_Objects. */
5413 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5415 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5416 mark_maybe_object (*p
);
5422 case Lisp_Misc_Overlay
:
5424 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5425 mark_object (ptr
->start
);
5426 mark_object (ptr
->end
);
5427 mark_object (ptr
->plist
);
5430 XSETMISC (obj
, ptr
->next
);
5443 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5444 if (CONS_MARKED_P (ptr
)) break;
5445 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5447 /* If the cdr is nil, avoid recursion for the car. */
5448 if (EQ (ptr
->cdr
, Qnil
))
5454 mark_object (ptr
->car
);
5457 if (cdr_count
== mark_object_loop_halt
)
5463 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5464 FLOAT_MARK (XFLOAT (obj
));
5475 #undef CHECK_ALLOCATED
5476 #undef CHECK_ALLOCATED_AND_LIVE
5479 /* Mark the pointers in a buffer structure. */
5485 register struct buffer
*buffer
= XBUFFER (buf
);
5486 register Lisp_Object
*ptr
, tmp
;
5487 Lisp_Object base_buffer
;
5489 VECTOR_MARK (buffer
);
5491 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5493 /* For now, we just don't mark the undo_list. It's done later in
5494 a special way just before the sweep phase, and after stripping
5495 some of its elements that are not needed any more. */
5497 if (buffer
->overlays_before
)
5499 XSETMISC (tmp
, buffer
->overlays_before
);
5502 if (buffer
->overlays_after
)
5504 XSETMISC (tmp
, buffer
->overlays_after
);
5508 for (ptr
= &buffer
->name
;
5509 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5513 /* If this is an indirect buffer, mark its base buffer. */
5514 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5516 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5517 mark_buffer (base_buffer
);
5522 /* Value is non-zero if OBJ will survive the current GC because it's
5523 either marked or does not need to be marked to survive. */
5531 switch (XGCTYPE (obj
))
5538 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5542 survives_p
= XMARKER (obj
)->gcmarkbit
;
5546 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5549 case Lisp_Vectorlike
:
5550 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5554 survives_p
= CONS_MARKED_P (XCONS (obj
));
5558 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5565 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5570 /* Sweep: find all structures not marked, and free them. */
5575 /* Remove or mark entries in weak hash tables.
5576 This must be done before any object is unmarked. */
5577 sweep_weak_hash_tables ();
5580 #ifdef GC_CHECK_STRING_BYTES
5581 if (!noninteractive
)
5582 check_string_bytes (1);
5585 /* Put all unmarked conses on free list */
5587 register struct cons_block
*cblk
;
5588 struct cons_block
**cprev
= &cons_block
;
5589 register int lim
= cons_block_index
;
5590 register int num_free
= 0, num_used
= 0;
5594 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5598 for (i
= 0; i
< lim
; i
++)
5599 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5602 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
5603 cons_free_list
= &cblk
->conses
[i
];
5605 cons_free_list
->car
= Vdead
;
5611 CONS_UNMARK (&cblk
->conses
[i
]);
5613 lim
= CONS_BLOCK_SIZE
;
5614 /* If this block contains only free conses and we have already
5615 seen more than two blocks worth of free conses then deallocate
5617 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5619 *cprev
= cblk
->next
;
5620 /* Unhook from the free list. */
5621 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
5622 lisp_align_free (cblk
);
5627 num_free
+= this_free
;
5628 cprev
= &cblk
->next
;
5631 total_conses
= num_used
;
5632 total_free_conses
= num_free
;
5635 /* Put all unmarked floats on free list */
5637 register struct float_block
*fblk
;
5638 struct float_block
**fprev
= &float_block
;
5639 register int lim
= float_block_index
;
5640 register int num_free
= 0, num_used
= 0;
5642 float_free_list
= 0;
5644 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5648 for (i
= 0; i
< lim
; i
++)
5649 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5652 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
5653 float_free_list
= &fblk
->floats
[i
];
5658 FLOAT_UNMARK (&fblk
->floats
[i
]);
5660 lim
= FLOAT_BLOCK_SIZE
;
5661 /* If this block contains only free floats and we have already
5662 seen more than two blocks worth of free floats then deallocate
5664 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5666 *fprev
= fblk
->next
;
5667 /* Unhook from the free list. */
5668 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5669 lisp_align_free (fblk
);
5674 num_free
+= this_free
;
5675 fprev
= &fblk
->next
;
5678 total_floats
= num_used
;
5679 total_free_floats
= num_free
;
5682 /* Put all unmarked intervals on free list */
5684 register struct interval_block
*iblk
;
5685 struct interval_block
**iprev
= &interval_block
;
5686 register int lim
= interval_block_index
;
5687 register int num_free
= 0, num_used
= 0;
5689 interval_free_list
= 0;
5691 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5696 for (i
= 0; i
< lim
; i
++)
5698 if (!iblk
->intervals
[i
].gcmarkbit
)
5700 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5701 interval_free_list
= &iblk
->intervals
[i
];
5707 iblk
->intervals
[i
].gcmarkbit
= 0;
5710 lim
= INTERVAL_BLOCK_SIZE
;
5711 /* If this block contains only free intervals and we have already
5712 seen more than two blocks worth of free intervals then
5713 deallocate this block. */
5714 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5716 *iprev
= iblk
->next
;
5717 /* Unhook from the free list. */
5718 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5720 n_interval_blocks
--;
5724 num_free
+= this_free
;
5725 iprev
= &iblk
->next
;
5728 total_intervals
= num_used
;
5729 total_free_intervals
= num_free
;
5732 /* Put all unmarked symbols on free list */
5734 register struct symbol_block
*sblk
;
5735 struct symbol_block
**sprev
= &symbol_block
;
5736 register int lim
= symbol_block_index
;
5737 register int num_free
= 0, num_used
= 0;
5739 symbol_free_list
= NULL
;
5741 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5744 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5745 struct Lisp_Symbol
*end
= sym
+ lim
;
5747 for (; sym
< end
; ++sym
)
5749 /* Check if the symbol was created during loadup. In such a case
5750 it might be pointed to by pure bytecode which we don't trace,
5751 so we conservatively assume that it is live. */
5752 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5754 if (!sym
->gcmarkbit
&& !pure_p
)
5756 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5757 symbol_free_list
= sym
;
5759 symbol_free_list
->function
= Vdead
;
5767 UNMARK_STRING (XSTRING (sym
->xname
));
5772 lim
= SYMBOL_BLOCK_SIZE
;
5773 /* If this block contains only free symbols and we have already
5774 seen more than two blocks worth of free symbols then deallocate
5776 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5778 *sprev
= sblk
->next
;
5779 /* Unhook from the free list. */
5780 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5786 num_free
+= this_free
;
5787 sprev
= &sblk
->next
;
5790 total_symbols
= num_used
;
5791 total_free_symbols
= num_free
;
5794 /* Put all unmarked misc's on free list.
5795 For a marker, first unchain it from the buffer it points into. */
5797 register struct marker_block
*mblk
;
5798 struct marker_block
**mprev
= &marker_block
;
5799 register int lim
= marker_block_index
;
5800 register int num_free
= 0, num_used
= 0;
5802 marker_free_list
= 0;
5804 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5809 for (i
= 0; i
< lim
; i
++)
5811 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5813 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5814 unchain_marker (&mblk
->markers
[i
].u_marker
);
5815 /* Set the type of the freed object to Lisp_Misc_Free.
5816 We could leave the type alone, since nobody checks it,
5817 but this might catch bugs faster. */
5818 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5819 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5820 marker_free_list
= &mblk
->markers
[i
];
5826 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5829 lim
= MARKER_BLOCK_SIZE
;
5830 /* If this block contains only free markers and we have already
5831 seen more than two blocks worth of free markers then deallocate
5833 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5835 *mprev
= mblk
->next
;
5836 /* Unhook from the free list. */
5837 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5843 num_free
+= this_free
;
5844 mprev
= &mblk
->next
;
5848 total_markers
= num_used
;
5849 total_free_markers
= num_free
;
5852 /* Free all unmarked buffers */
5854 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5857 if (!VECTOR_MARKED_P (buffer
))
5860 prev
->next
= buffer
->next
;
5862 all_buffers
= buffer
->next
;
5863 next
= buffer
->next
;
5869 VECTOR_UNMARK (buffer
);
5870 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5871 prev
= buffer
, buffer
= buffer
->next
;
5875 /* Free all unmarked vectors */
5877 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5878 total_vector_size
= 0;
5881 if (!VECTOR_MARKED_P (vector
))
5884 prev
->next
= vector
->next
;
5886 all_vectors
= vector
->next
;
5887 next
= vector
->next
;
5895 VECTOR_UNMARK (vector
);
5896 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5897 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5899 total_vector_size
+= vector
->size
;
5900 prev
= vector
, vector
= vector
->next
;
5904 #ifdef GC_CHECK_STRING_BYTES
5905 if (!noninteractive
)
5906 check_string_bytes (1);
5913 /* Debugging aids. */
5915 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5916 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
5917 This may be helpful in debugging Emacs's memory usage.
5918 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
5923 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5928 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5929 doc
: /* Return a list of counters that measure how much consing there has been.
5930 Each of these counters increments for a certain kind of object.
5931 The counters wrap around from the largest positive integer to zero.
5932 Garbage collection does not decrease them.
5933 The elements of the value are as follows:
5934 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
5935 All are in units of 1 = one object consed
5936 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
5938 MISCS include overlays, markers, and some internal types.
5939 Frames, windows, buffers, and subprocesses count as vectors
5940 (but the contents of a buffer's text do not count here). */)
5943 Lisp_Object consed
[8];
5945 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
5946 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
5947 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
5948 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
5949 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
5950 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
5951 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
5952 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
5954 return Flist (8, consed
);
5957 int suppress_checking
;
5959 die (msg
, file
, line
)
5964 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5969 /* Initialization */
5974 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5976 pure_size
= PURESIZE
;
5977 pure_bytes_used
= 0;
5978 pure_bytes_used_before_overflow
= 0;
5980 /* Initialize the list of free aligned blocks. */
5983 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5985 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5989 ignore_warnings
= 1;
5990 #ifdef DOUG_LEA_MALLOC
5991 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5992 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5993 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6003 malloc_hysteresis
= 32;
6005 malloc_hysteresis
= 0;
6008 spare_memory
= (char *) malloc (SPARE_MEMORY
);
6010 ignore_warnings
= 0;
6012 byte_stack_list
= 0;
6014 consing_since_gc
= 0;
6015 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6016 gc_relative_threshold
= 0;
6018 #ifdef VIRT_ADDR_VARIES
6019 malloc_sbrk_unused
= 1<<22; /* A large number */
6020 malloc_sbrk_used
= 100000; /* as reasonable as any number */
6021 #endif /* VIRT_ADDR_VARIES */
6028 byte_stack_list
= 0;
6030 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6031 setjmp_tested_p
= longjmps_done
= 0;
6034 Vgc_elapsed
= make_float (0.0);
6041 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
6042 doc
: /* *Number of bytes of consing between garbage collections.
6043 Garbage collection can happen automatically once this many bytes have been
6044 allocated since the last garbage collection. All data types count.
6046 Garbage collection happens automatically only when `eval' is called.
6048 By binding this temporarily to a large number, you can effectively
6049 prevent garbage collection during a part of the program.
6050 See also `gc-cons-percentage'. */);
6052 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage
,
6053 doc
: /* *Portion of the heap used for allocation.
6054 Garbage collection can happen automatically once this portion of the heap
6055 has been allocated since the last garbage collection.
6056 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6057 Vgc_cons_percentage
= make_float (0.1);
6059 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
6060 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6062 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
6063 doc
: /* Number of cons cells that have been consed so far. */);
6065 DEFVAR_INT ("floats-consed", &floats_consed
,
6066 doc
: /* Number of floats that have been consed so far. */);
6068 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
6069 doc
: /* Number of vector cells that have been consed so far. */);
6071 DEFVAR_INT ("symbols-consed", &symbols_consed
,
6072 doc
: /* Number of symbols that have been consed so far. */);
6074 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
6075 doc
: /* Number of string characters that have been consed so far. */);
6077 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
6078 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6080 DEFVAR_INT ("intervals-consed", &intervals_consed
,
6081 doc
: /* Number of intervals that have been consed so far. */);
6083 DEFVAR_INT ("strings-consed", &strings_consed
,
6084 doc
: /* Number of strings that have been consed so far. */);
6086 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
6087 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6088 This means that certain objects should be allocated in shared (pure) space. */);
6090 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
6091 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6092 garbage_collection_messages
= 0;
6094 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
6095 doc
: /* Hook run after garbage collection has finished. */);
6096 Vpost_gc_hook
= Qnil
;
6097 Qpost_gc_hook
= intern ("post-gc-hook");
6098 staticpro (&Qpost_gc_hook
);
6100 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
6101 doc
: /* Precomputed `signal' argument for memory-full error. */);
6102 /* We build this in advance because if we wait until we need it, we might
6103 not be able to allocate the memory to hold it. */
6106 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6108 DEFVAR_LISP ("memory-full", &Vmemory_full
,
6109 doc
: /* Non-nil means we are handling a memory-full error. */);
6110 Vmemory_full
= Qnil
;
6112 staticpro (&Qgc_cons_threshold
);
6113 Qgc_cons_threshold
= intern ("gc-cons-threshold");
6115 staticpro (&Qchar_table_extra_slots
);
6116 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
6118 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
6119 doc
: /* Accumulated time elapsed in garbage collections.
6120 The time is in seconds as a floating point value. */);
6121 DEFVAR_INT ("gcs-done", &gcs_done
,
6122 doc
: /* Accumulated number of garbage collections done. */);
6124 defsubr (&Smemory_full_p
);
6128 defsubr (&Smake_byte_code
);
6129 defsubr (&Smake_list
);
6130 defsubr (&Smake_vector
);
6131 defsubr (&Smake_char_table
);
6132 defsubr (&Smake_string
);
6133 defsubr (&Smake_bool_vector
);
6134 defsubr (&Smake_symbol
);
6135 defsubr (&Smake_marker
);
6136 defsubr (&Spurecopy
);
6137 defsubr (&Sgarbage_collect
);
6138 defsubr (&Smemory_limit
);
6139 defsubr (&Smemory_use_counts
);
6141 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6142 defsubr (&Sgc_status
);
6146 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6147 (do not change this comment) */