1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 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., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 /* Note that this declares bzero on OSF/1. How dumb. */
29 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
30 memory. Can do this only if using gmalloc.c. */
32 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
33 #undef GC_MALLOC_CHECK
36 /* This file is part of the core Lisp implementation, and thus must
37 deal with the real data structures. If the Lisp implementation is
38 replaced, this file likely will not be used. */
40 #undef HIDE_LISP_IMPLEMENTATION
43 #include "intervals.h"
49 #include "blockinput.h"
51 #include "syssignal.h"
57 extern POINTER_TYPE
*sbrk ();
60 #ifdef DOUG_LEA_MALLOC
63 /* malloc.h #defines this as size_t, at least in glibc2. */
64 #ifndef __malloc_size_t
65 #define __malloc_size_t int
68 /* Specify maximum number of areas to mmap. It would be nice to use a
69 value that explicitly means "no limit". */
71 #define MMAP_MAX_AREAS 100000000
73 #else /* not DOUG_LEA_MALLOC */
75 /* The following come from gmalloc.c. */
77 #define __malloc_size_t size_t
78 extern __malloc_size_t _bytes_used
;
79 extern __malloc_size_t __malloc_extra_blocks
;
81 #endif /* not DOUG_LEA_MALLOC */
83 #define max(A,B) ((A) > (B) ? (A) : (B))
84 #define min(A,B) ((A) < (B) ? (A) : (B))
86 /* Macro to verify that storage intended for Lisp objects is not
87 out of range to fit in the space for a pointer.
88 ADDRESS is the start of the block, and SIZE
89 is the amount of space within which objects can start. */
91 #define VALIDATE_LISP_STORAGE(address, size) \
95 XSETCONS (val, (char *) address + size); \
96 if ((char *) XCONS (val) != (char *) address + size) \
103 /* Value of _bytes_used, when spare_memory was freed. */
105 static __malloc_size_t bytes_used_when_full
;
107 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
108 to a struct Lisp_String. */
110 #define MARK_STRING(S) ((S)->size |= MARKBIT)
111 #define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
112 #define STRING_MARKED_P(S) ((S)->size & MARKBIT)
114 /* Value is the number of bytes/chars of S, a pointer to a struct
115 Lisp_String. This must be used instead of STRING_BYTES (S) or
116 S->size during GC, because S->size contains the mark bit for
119 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
120 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
122 /* Number of bytes of consing done since the last gc. */
124 int consing_since_gc
;
126 /* Count the amount of consing of various sorts of space. */
128 int cons_cells_consed
;
130 int vector_cells_consed
;
132 int string_chars_consed
;
133 int misc_objects_consed
;
134 int intervals_consed
;
137 /* Number of bytes of consing since GC before another GC should be done. */
139 int gc_cons_threshold
;
141 /* Nonzero during GC. */
145 /* Nonzero means display messages at beginning and end of GC. */
147 int garbage_collection_messages
;
149 #ifndef VIRT_ADDR_VARIES
151 #endif /* VIRT_ADDR_VARIES */
152 int malloc_sbrk_used
;
154 #ifndef VIRT_ADDR_VARIES
156 #endif /* VIRT_ADDR_VARIES */
157 int malloc_sbrk_unused
;
159 /* Two limits controlling how much undo information to keep. */
162 int undo_strong_limit
;
164 /* Number of live and free conses etc. */
166 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
167 static int total_free_conses
, total_free_markers
, total_free_symbols
;
168 static int total_free_floats
, total_floats
;
170 /* Points to memory space allocated as "spare", to be freed if we run
173 static char *spare_memory
;
175 /* Amount of spare memory to keep in reserve. */
177 #define SPARE_MEMORY (1 << 14)
179 /* Number of extra blocks malloc should get when it needs more core. */
181 static int malloc_hysteresis
;
183 /* Non-nil means defun should do purecopy on the function definition. */
185 Lisp_Object Vpurify_flag
;
189 /* Force it into data space! */
191 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,};
192 #define PUREBEG (char *) pure
194 #else /* not HAVE_SHM */
196 #define pure PURE_SEG_BITS /* Use shared memory segment */
197 #define PUREBEG (char *)PURE_SEG_BITS
199 /* This variable is used only by the XPNTR macro when HAVE_SHM is
200 defined. If we used the PURESIZE macro directly there, that would
201 make most of Emacs dependent on puresize.h, which we don't want -
202 you should be able to change that without too much recompilation.
203 So map_in_data initializes pure_size, and the dependencies work
208 #endif /* not HAVE_SHM */
210 /* Value is non-zero if P points into pure space. */
212 #define PURE_POINTER_P(P) \
213 (((PNTR_COMPARISON_TYPE) (P) \
214 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
215 && ((PNTR_COMPARISON_TYPE) (P) \
216 >= (PNTR_COMPARISON_TYPE) pure))
218 /* Index in pure at which next pure object will be allocated.. */
222 /* If nonzero, this is a warning delivered by malloc and not yet
225 char *pending_malloc_warning
;
227 /* Pre-computed signal argument for use when memory is exhausted. */
229 Lisp_Object memory_signal_data
;
231 /* Maximum amount of C stack to save when a GC happens. */
233 #ifndef MAX_SAVE_STACK
234 #define MAX_SAVE_STACK 16000
237 /* Buffer in which we save a copy of the C stack at each GC. */
242 /* Non-zero means ignore malloc warnings. Set during initialization.
243 Currently not used. */
247 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
249 static void mark_buffer
P_ ((Lisp_Object
));
250 static void mark_kboards
P_ ((void));
251 static void gc_sweep
P_ ((void));
252 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
253 static void mark_face_cache
P_ ((struct face_cache
*));
255 #ifdef HAVE_WINDOW_SYSTEM
256 static void mark_image
P_ ((struct image
*));
257 static void mark_image_cache
P_ ((struct frame
*));
258 #endif /* HAVE_WINDOW_SYSTEM */
260 static struct Lisp_String
*allocate_string
P_ ((void));
261 static void compact_small_strings
P_ ((void));
262 static void free_large_strings
P_ ((void));
263 static void sweep_strings
P_ ((void));
265 extern int message_enable_multibyte
;
267 /* When scanning the C stack for live Lisp objects, Emacs keeps track
268 of what memory allocated via lisp_malloc is intended for what
269 purpose. This enumeration specifies the type of memory. */
280 /* Keep the following vector-like types together, with
281 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
282 first. Or change the code of live_vector_p, for instance. */
290 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
292 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
293 #include <stdio.h> /* For fprintf. */
296 /* A unique object in pure space used to make some Lisp objects
297 on free lists recognizable in O(1). */
301 #ifdef GC_MALLOC_CHECK
303 enum mem_type allocated_mem_type
;
304 int dont_register_blocks
;
306 #endif /* GC_MALLOC_CHECK */
308 /* A node in the red-black tree describing allocated memory containing
309 Lisp data. Each such block is recorded with its start and end
310 address when it is allocated, and removed from the tree when it
313 A red-black tree is a balanced binary tree with the following
316 1. Every node is either red or black.
317 2. Every leaf is black.
318 3. If a node is red, then both of its children are black.
319 4. Every simple path from a node to a descendant leaf contains
320 the same number of black nodes.
321 5. The root is always black.
323 When nodes are inserted into the tree, or deleted from the tree,
324 the tree is "fixed" so that these properties are always true.
326 A red-black tree with N internal nodes has height at most 2
327 log(N+1). Searches, insertions and deletions are done in O(log N).
328 Please see a text book about data structures for a detailed
329 description of red-black trees. Any book worth its salt should
334 struct mem_node
*left
, *right
, *parent
;
336 /* Start and end of allocated region. */
340 enum {MEM_BLACK
, MEM_RED
} color
;
346 /* Base address of stack. Set in main. */
348 Lisp_Object
*stack_base
;
350 /* Root of the tree describing allocated Lisp memory. */
352 static struct mem_node
*mem_root
;
354 /* Lowest and highest known address in the heap. */
356 static void *min_heap_address
, *max_heap_address
;
358 /* Sentinel node of the tree. */
360 static struct mem_node mem_z
;
361 #define MEM_NIL &mem_z
363 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
364 static struct Lisp_Vector
*allocate_vectorlike
P_ ((EMACS_INT
, enum mem_type
));
365 static void lisp_free
P_ ((POINTER_TYPE
*));
366 static void mark_stack
P_ ((void));
367 static int live_vector_p
P_ ((struct mem_node
*, void *));
368 static int live_buffer_p
P_ ((struct mem_node
*, void *));
369 static int live_string_p
P_ ((struct mem_node
*, void *));
370 static int live_cons_p
P_ ((struct mem_node
*, void *));
371 static int live_symbol_p
P_ ((struct mem_node
*, void *));
372 static int live_float_p
P_ ((struct mem_node
*, void *));
373 static int live_misc_p
P_ ((struct mem_node
*, void *));
374 static void mark_maybe_object
P_ ((Lisp_Object
));
375 static void mark_memory
P_ ((void *, void *));
376 static void mem_init
P_ ((void));
377 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
378 static void mem_insert_fixup
P_ ((struct mem_node
*));
379 static void mem_rotate_left
P_ ((struct mem_node
*));
380 static void mem_rotate_right
P_ ((struct mem_node
*));
381 static void mem_delete
P_ ((struct mem_node
*));
382 static void mem_delete_fixup
P_ ((struct mem_node
*));
383 static INLINE
struct mem_node
*mem_find
P_ ((void *));
385 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
386 static void check_gcpros
P_ ((void));
389 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
391 /* Recording what needs to be marked for gc. */
393 struct gcpro
*gcprolist
;
395 /* Addresses of staticpro'd variables. */
397 #define NSTATICS 1024
398 Lisp_Object
*staticvec
[NSTATICS
] = {0};
400 /* Index of next unused slot in staticvec. */
404 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
407 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
408 ALIGNMENT must be a power of 2. */
410 #define ALIGN(SZ, ALIGNMENT) \
411 (((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1))
415 /************************************************************************
417 ************************************************************************/
419 /* Write STR to Vstandard_output plus some advice on how to free some
420 memory. Called when memory gets low. */
423 malloc_warning_1 (str
)
426 Fprinc (str
, Vstandard_output
);
427 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
428 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
429 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
434 /* Function malloc calls this if it finds we are near exhausting
441 pending_malloc_warning
= str
;
445 /* Display a malloc warning in buffer *Danger*. */
448 display_malloc_warning ()
450 register Lisp_Object val
;
452 val
= build_string (pending_malloc_warning
);
453 pending_malloc_warning
= 0;
454 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
458 #ifdef DOUG_LEA_MALLOC
459 # define BYTES_USED (mallinfo ().arena)
461 # define BYTES_USED _bytes_used
465 /* Called if malloc returns zero. */
470 #ifndef SYSTEM_MALLOC
471 bytes_used_when_full
= BYTES_USED
;
474 /* The first time we get here, free the spare memory. */
481 /* This used to call error, but if we've run out of memory, we could
482 get infinite recursion trying to build the string. */
484 Fsignal (Qnil
, memory_signal_data
);
488 /* Called if we can't allocate relocatable space for a buffer. */
491 buffer_memory_full ()
493 /* If buffers use the relocating allocator, no need to free
494 spare_memory, because we may have plenty of malloc space left
495 that we could get, and if we don't, the malloc that fails will
496 itself cause spare_memory to be freed. If buffers don't use the
497 relocating allocator, treat this like any other failing
504 /* This used to call error, but if we've run out of memory, we could
505 get infinite recursion trying to build the string. */
507 Fsignal (Qerror
, memory_signal_data
);
511 /* Like malloc but check for no memory and block interrupt input.. */
517 register POINTER_TYPE
*val
;
520 val
= (POINTER_TYPE
*) malloc (size
);
529 /* Like realloc but check for no memory and block interrupt input.. */
532 xrealloc (block
, size
)
536 register POINTER_TYPE
*val
;
539 /* We must call malloc explicitly when BLOCK is 0, since some
540 reallocs don't do this. */
542 val
= (POINTER_TYPE
*) malloc (size
);
544 val
= (POINTER_TYPE
*) realloc (block
, size
);
547 if (!val
&& size
) memory_full ();
552 /* Like free but block interrupt input.. */
564 /* Like strdup, but uses xmalloc. */
570 size_t len
= strlen (s
) + 1;
571 char *p
= (char *) xmalloc (len
);
577 /* Like malloc but used for allocating Lisp data. NBYTES is the
578 number of bytes to allocate, TYPE describes the intended use of the
579 allcated memory block (for strings, for conses, ...). */
581 static POINTER_TYPE
*
582 lisp_malloc (nbytes
, type
)
590 #ifdef GC_MALLOC_CHECK
591 allocated_mem_type
= type
;
594 val
= (void *) malloc (nbytes
);
596 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
597 if (val
&& type
!= MEM_TYPE_NON_LISP
)
598 mem_insert (val
, (char *) val
+ nbytes
, type
);
608 /* Return a new buffer structure allocated from the heap with
609 a call to lisp_malloc. */
615 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
617 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
622 /* Free BLOCK. This must be called to free memory allocated with a
623 call to lisp_malloc. */
631 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
632 mem_delete (mem_find (block
));
638 /* Arranging to disable input signals while we're in malloc.
640 This only works with GNU malloc. To help out systems which can't
641 use GNU malloc, all the calls to malloc, realloc, and free
642 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
643 pairs; unfortunately, we have no idea what C library functions
644 might call malloc, so we can't really protect them unless you're
645 using GNU malloc. Fortunately, most of the major operating can use
648 #ifndef SYSTEM_MALLOC
649 #ifndef DOUG_LEA_MALLOC
650 extern void * (*__malloc_hook
) P_ ((size_t));
651 extern void * (*__realloc_hook
) P_ ((void *, size_t));
652 extern void (*__free_hook
) P_ ((void *));
653 /* Else declared in malloc.h, perhaps with an extra arg. */
654 #endif /* DOUG_LEA_MALLOC */
655 static void * (*old_malloc_hook
) ();
656 static void * (*old_realloc_hook
) ();
657 static void (*old_free_hook
) ();
659 /* This function is used as the hook for free to call. */
662 emacs_blocked_free (ptr
)
667 #ifdef GC_MALLOC_CHECK
673 if (m
== MEM_NIL
|| m
->start
!= ptr
)
676 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
681 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
685 #endif /* GC_MALLOC_CHECK */
687 __free_hook
= old_free_hook
;
690 /* If we released our reserve (due to running out of memory),
691 and we have a fair amount free once again,
692 try to set aside another reserve in case we run out once more. */
693 if (spare_memory
== 0
694 /* Verify there is enough space that even with the malloc
695 hysteresis this call won't run out again.
696 The code here is correct as long as SPARE_MEMORY
697 is substantially larger than the block size malloc uses. */
698 && (bytes_used_when_full
699 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
700 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
702 __free_hook
= emacs_blocked_free
;
707 /* If we released our reserve (due to running out of memory),
708 and we have a fair amount free once again,
709 try to set aside another reserve in case we run out once more.
711 This is called when a relocatable block is freed in ralloc.c. */
714 refill_memory_reserve ()
716 if (spare_memory
== 0)
717 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
721 /* This function is the malloc hook that Emacs uses. */
724 emacs_blocked_malloc (size
)
730 __malloc_hook
= old_malloc_hook
;
731 #ifdef DOUG_LEA_MALLOC
732 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
734 __malloc_extra_blocks
= malloc_hysteresis
;
737 value
= (void *) malloc (size
);
739 #ifdef GC_MALLOC_CHECK
741 struct mem_node
*m
= mem_find (value
);
744 fprintf (stderr
, "Malloc returned %p which is already in use\n",
746 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
747 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
752 if (!dont_register_blocks
)
754 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
755 allocated_mem_type
= MEM_TYPE_NON_LISP
;
758 #endif /* GC_MALLOC_CHECK */
760 __malloc_hook
= emacs_blocked_malloc
;
763 /* fprintf (stderr, "%p malloc\n", value); */
768 /* This function is the realloc hook that Emacs uses. */
771 emacs_blocked_realloc (ptr
, size
)
778 __realloc_hook
= old_realloc_hook
;
780 #ifdef GC_MALLOC_CHECK
783 struct mem_node
*m
= mem_find (ptr
);
784 if (m
== MEM_NIL
|| m
->start
!= ptr
)
787 "Realloc of %p which wasn't allocated with malloc\n",
795 /* fprintf (stderr, "%p -> realloc\n", ptr); */
797 /* Prevent malloc from registering blocks. */
798 dont_register_blocks
= 1;
799 #endif /* GC_MALLOC_CHECK */
801 value
= (void *) realloc (ptr
, size
);
803 #ifdef GC_MALLOC_CHECK
804 dont_register_blocks
= 0;
807 struct mem_node
*m
= mem_find (value
);
810 fprintf (stderr
, "Realloc returns memory that is already in use\n");
814 /* Can't handle zero size regions in the red-black tree. */
815 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
818 /* fprintf (stderr, "%p <- realloc\n", value); */
819 #endif /* GC_MALLOC_CHECK */
821 __realloc_hook
= emacs_blocked_realloc
;
828 /* Called from main to set up malloc to use our hooks. */
831 uninterrupt_malloc ()
833 if (__free_hook
!= emacs_blocked_free
)
834 old_free_hook
= __free_hook
;
835 __free_hook
= emacs_blocked_free
;
837 if (__malloc_hook
!= emacs_blocked_malloc
)
838 old_malloc_hook
= __malloc_hook
;
839 __malloc_hook
= emacs_blocked_malloc
;
841 if (__realloc_hook
!= emacs_blocked_realloc
)
842 old_realloc_hook
= __realloc_hook
;
843 __realloc_hook
= emacs_blocked_realloc
;
846 #endif /* not SYSTEM_MALLOC */
850 /***********************************************************************
852 ***********************************************************************/
854 /* Number of intervals allocated in an interval_block structure.
855 The 1020 is 1024 minus malloc overhead. */
857 #define INTERVAL_BLOCK_SIZE \
858 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
860 /* Intervals are allocated in chunks in form of an interval_block
863 struct interval_block
865 struct interval_block
*next
;
866 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
869 /* Current interval block. Its `next' pointer points to older
872 struct interval_block
*interval_block
;
874 /* Index in interval_block above of the next unused interval
877 static int interval_block_index
;
879 /* Number of free and live intervals. */
881 static int total_free_intervals
, total_intervals
;
883 /* List of free intervals. */
885 INTERVAL interval_free_list
;
887 /* Total number of interval blocks now in use. */
889 int n_interval_blocks
;
892 /* Initialize interval allocation. */
898 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
900 interval_block
->next
= 0;
901 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
902 interval_block_index
= 0;
903 interval_free_list
= 0;
904 n_interval_blocks
= 1;
908 /* Return a new interval. */
915 if (interval_free_list
)
917 val
= interval_free_list
;
918 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
922 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
924 register struct interval_block
*newi
;
926 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
929 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
930 newi
->next
= interval_block
;
931 interval_block
= newi
;
932 interval_block_index
= 0;
935 val
= &interval_block
->intervals
[interval_block_index
++];
937 consing_since_gc
+= sizeof (struct interval
);
939 RESET_INTERVAL (val
);
944 /* Mark Lisp objects in interval I. */
947 mark_interval (i
, dummy
)
951 if (XMARKBIT (i
->plist
))
953 mark_object (&i
->plist
);
958 /* Mark the interval tree rooted in TREE. Don't call this directly;
959 use the macro MARK_INTERVAL_TREE instead. */
962 mark_interval_tree (tree
)
963 register INTERVAL tree
;
965 /* No need to test if this tree has been marked already; this
966 function is always called through the MARK_INTERVAL_TREE macro,
967 which takes care of that. */
969 /* XMARK expands to an assignment; the LHS of an assignment can't be
971 XMARK (tree
->up
.obj
);
973 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
977 /* Mark the interval tree rooted in I. */
979 #define MARK_INTERVAL_TREE(i) \
981 if (!NULL_INTERVAL_P (i) \
982 && ! XMARKBIT (i->up.obj)) \
983 mark_interval_tree (i); \
987 /* The oddity in the call to XUNMARK is necessary because XUNMARK
988 expands to an assignment to its argument, and most C compilers
989 don't support casts on the left operand of `='. */
991 #define UNMARK_BALANCE_INTERVALS(i) \
993 if (! NULL_INTERVAL_P (i)) \
995 XUNMARK ((i)->up.obj); \
996 (i) = balance_intervals (i); \
1001 /* Number support. If NO_UNION_TYPE isn't in effect, we
1002 can't create number objects in macros. */
1010 obj
.s
.type
= Lisp_Int
;
1015 /***********************************************************************
1017 ***********************************************************************/
1019 /* Lisp_Strings are allocated in string_block structures. When a new
1020 string_block is allocated, all the Lisp_Strings it contains are
1021 added to a free-list stiing_free_list. When a new Lisp_String is
1022 needed, it is taken from that list. During the sweep phase of GC,
1023 string_blocks that are entirely free are freed, except two which
1026 String data is allocated from sblock structures. Strings larger
1027 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1028 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1030 Sblocks consist internally of sdata structures, one for each
1031 Lisp_String. The sdata structure points to the Lisp_String it
1032 belongs to. The Lisp_String points back to the `u.data' member of
1033 its sdata structure.
1035 When a Lisp_String is freed during GC, it is put back on
1036 string_free_list, and its `data' member and its sdata's `string'
1037 pointer is set to null. The size of the string is recorded in the
1038 `u.nbytes' member of the sdata. So, sdata structures that are no
1039 longer used, can be easily recognized, and it's easy to compact the
1040 sblocks of small strings which we do in compact_small_strings. */
1042 /* Size in bytes of an sblock structure used for small strings. This
1043 is 8192 minus malloc overhead. */
1045 #define SBLOCK_SIZE 8188
1047 /* Strings larger than this are considered large strings. String data
1048 for large strings is allocated from individual sblocks. */
1050 #define LARGE_STRING_BYTES 1024
1052 /* Structure describing string memory sub-allocated from an sblock.
1053 This is where the contents of Lisp strings are stored. */
1057 /* Back-pointer to the string this sdata belongs to. If null, this
1058 structure is free, and the NBYTES member of the union below
1059 contains the string's byte size (the same value that STRING_BYTES
1060 would return if STRING were non-null). If non-null, STRING_BYTES
1061 (STRING) is the size of the data, and DATA contains the string's
1063 struct Lisp_String
*string
;
1065 #ifdef GC_CHECK_STRING_BYTES
1068 unsigned char data
[1];
1070 #define SDATA_NBYTES(S) (S)->nbytes
1071 #define SDATA_DATA(S) (S)->data
1073 #else /* not GC_CHECK_STRING_BYTES */
1077 /* When STRING in non-null. */
1078 unsigned char data
[1];
1080 /* When STRING is null. */
1085 #define SDATA_NBYTES(S) (S)->u.nbytes
1086 #define SDATA_DATA(S) (S)->u.data
1088 #endif /* not GC_CHECK_STRING_BYTES */
1092 /* Structure describing a block of memory which is sub-allocated to
1093 obtain string data memory for strings. Blocks for small strings
1094 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1095 as large as needed. */
1100 struct sblock
*next
;
1102 /* Pointer to the next free sdata block. This points past the end
1103 of the sblock if there isn't any space left in this block. */
1104 struct sdata
*next_free
;
1106 /* Start of data. */
1107 struct sdata first_data
;
1110 /* Number of Lisp strings in a string_block structure. The 1020 is
1111 1024 minus malloc overhead. */
1113 #define STRINGS_IN_STRING_BLOCK \
1114 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1116 /* Structure describing a block from which Lisp_String structures
1121 struct string_block
*next
;
1122 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
1125 /* Head and tail of the list of sblock structures holding Lisp string
1126 data. We always allocate from current_sblock. The NEXT pointers
1127 in the sblock structures go from oldest_sblock to current_sblock. */
1129 static struct sblock
*oldest_sblock
, *current_sblock
;
1131 /* List of sblocks for large strings. */
1133 static struct sblock
*large_sblocks
;
1135 /* List of string_block structures, and how many there are. */
1137 static struct string_block
*string_blocks
;
1138 static int n_string_blocks
;
1140 /* Free-list of Lisp_Strings. */
1142 static struct Lisp_String
*string_free_list
;
1144 /* Number of live and free Lisp_Strings. */
1146 static int total_strings
, total_free_strings
;
1148 /* Number of bytes used by live strings. */
1150 static int total_string_size
;
1152 /* Given a pointer to a Lisp_String S which is on the free-list
1153 string_free_list, return a pointer to its successor in the
1156 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1158 /* Return a pointer to the sdata structure belonging to Lisp string S.
1159 S must be live, i.e. S->data must not be null. S->data is actually
1160 a pointer to the `u.data' member of its sdata structure; the
1161 structure starts at a constant offset in front of that. */
1163 #ifdef GC_CHECK_STRING_BYTES
1165 #define SDATA_OF_STRING(S) \
1166 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1167 - sizeof (EMACS_INT)))
1169 #else /* not GC_CHECK_STRING_BYTES */
1171 #define SDATA_OF_STRING(S) \
1172 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1174 #endif /* not GC_CHECK_STRING_BYTES */
1176 /* Value is the size of an sdata structure large enough to hold NBYTES
1177 bytes of string data. The value returned includes a terminating
1178 NUL byte, the size of the sdata structure, and padding. */
1180 #ifdef GC_CHECK_STRING_BYTES
1182 #define SDATA_SIZE(NBYTES) \
1183 ((sizeof (struct Lisp_String *) \
1185 + sizeof (EMACS_INT) \
1186 + sizeof (EMACS_INT) - 1) \
1187 & ~(sizeof (EMACS_INT) - 1))
1189 #else /* not GC_CHECK_STRING_BYTES */
1191 #define SDATA_SIZE(NBYTES) \
1192 ((sizeof (struct Lisp_String *) \
1194 + sizeof (EMACS_INT) - 1) \
1195 & ~(sizeof (EMACS_INT) - 1))
1197 #endif /* not GC_CHECK_STRING_BYTES */
1199 /* Initialize string allocation. Called from init_alloc_once. */
1204 total_strings
= total_free_strings
= total_string_size
= 0;
1205 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1206 string_blocks
= NULL
;
1207 n_string_blocks
= 0;
1208 string_free_list
= NULL
;
1212 #ifdef GC_CHECK_STRING_BYTES
1214 static int check_string_bytes_count
;
1216 void check_string_bytes
P_ ((int));
1217 void check_sblock
P_ ((struct sblock
*));
1219 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1222 /* Like GC_STRING_BYTES, but with debugging check. */
1226 struct Lisp_String
*s
;
1228 int nbytes
= (s
->size_byte
< 0 ? s
->size
: s
->size_byte
) & ~MARKBIT
;
1229 if (!PURE_POINTER_P (s
)
1231 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1236 /* Check validity Lisp strings' string_bytes member in B. */
1242 struct sdata
*from
, *end
, *from_end
;
1246 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1248 /* Compute the next FROM here because copying below may
1249 overwrite data we need to compute it. */
1252 /* Check that the string size recorded in the string is the
1253 same as the one recorded in the sdata structure. */
1255 CHECK_STRING_BYTES (from
->string
);
1258 nbytes
= GC_STRING_BYTES (from
->string
);
1260 nbytes
= SDATA_NBYTES (from
);
1262 nbytes
= SDATA_SIZE (nbytes
);
1263 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1268 /* Check validity of Lisp strings' string_bytes member. ALL_P
1269 non-zero means check all strings, otherwise check only most
1270 recently allocated strings. Used for hunting a bug. */
1273 check_string_bytes (all_p
)
1280 for (b
= large_sblocks
; b
; b
= b
->next
)
1282 struct Lisp_String
*s
= b
->first_data
.string
;
1284 CHECK_STRING_BYTES (s
);
1287 for (b
= oldest_sblock
; b
; b
= b
->next
)
1291 check_sblock (current_sblock
);
1294 #endif /* GC_CHECK_STRING_BYTES */
1297 /* Return a new Lisp_String. */
1299 static struct Lisp_String
*
1302 struct Lisp_String
*s
;
1304 /* If the free-list is empty, allocate a new string_block, and
1305 add all the Lisp_Strings in it to the free-list. */
1306 if (string_free_list
== NULL
)
1308 struct string_block
*b
;
1311 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1312 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
1313 bzero (b
, sizeof *b
);
1314 b
->next
= string_blocks
;
1318 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
1321 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1322 string_free_list
= s
;
1325 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
1328 /* Pop a Lisp_String off the free-list. */
1329 s
= string_free_list
;
1330 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1332 /* Probably not strictly necessary, but play it safe. */
1333 bzero (s
, sizeof *s
);
1335 --total_free_strings
;
1338 consing_since_gc
+= sizeof *s
;
1340 #ifdef GC_CHECK_STRING_BYTES
1347 if (++check_string_bytes_count
== 200)
1349 check_string_bytes_count
= 0;
1350 check_string_bytes (1);
1353 check_string_bytes (0);
1355 #endif /* GC_CHECK_STRING_BYTES */
1361 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1362 plus a NUL byte at the end. Allocate an sdata structure for S, and
1363 set S->data to its `u.data' member. Store a NUL byte at the end of
1364 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1365 S->data if it was initially non-null. */
1368 allocate_string_data (s
, nchars
, nbytes
)
1369 struct Lisp_String
*s
;
1372 struct sdata
*data
, *old_data
;
1374 int needed
, old_nbytes
;
1376 /* Determine the number of bytes needed to store NBYTES bytes
1378 needed
= SDATA_SIZE (nbytes
);
1380 if (nbytes
> LARGE_STRING_BYTES
)
1382 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1384 #ifdef DOUG_LEA_MALLOC
1385 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1386 because mapped region contents are not preserved in
1388 mallopt (M_MMAP_MAX
, 0);
1391 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1393 #ifdef DOUG_LEA_MALLOC
1394 /* Back to a reasonable maximum of mmap'ed areas. */
1395 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1398 b
->next_free
= &b
->first_data
;
1399 b
->first_data
.string
= NULL
;
1400 b
->next
= large_sblocks
;
1403 else if (current_sblock
== NULL
1404 || (((char *) current_sblock
+ SBLOCK_SIZE
1405 - (char *) current_sblock
->next_free
)
1408 /* Not enough room in the current sblock. */
1409 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1410 b
->next_free
= &b
->first_data
;
1411 b
->first_data
.string
= NULL
;
1415 current_sblock
->next
= b
;
1423 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1424 old_nbytes
= GC_STRING_BYTES (s
);
1426 data
= b
->next_free
;
1428 s
->data
= SDATA_DATA (data
);
1429 #ifdef GC_CHECK_STRING_BYTES
1430 SDATA_NBYTES (data
) = nbytes
;
1433 s
->size_byte
= nbytes
;
1434 s
->data
[nbytes
] = '\0';
1435 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1437 /* If S had already data assigned, mark that as free by setting its
1438 string back-pointer to null, and recording the size of the data
1442 SDATA_NBYTES (old_data
) = old_nbytes
;
1443 old_data
->string
= NULL
;
1446 consing_since_gc
+= needed
;
1450 /* Sweep and compact strings. */
1455 struct string_block
*b
, *next
;
1456 struct string_block
*live_blocks
= NULL
;
1458 string_free_list
= NULL
;
1459 total_strings
= total_free_strings
= 0;
1460 total_string_size
= 0;
1462 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1463 for (b
= string_blocks
; b
; b
= next
)
1466 struct Lisp_String
*free_list_before
= string_free_list
;
1470 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1472 struct Lisp_String
*s
= b
->strings
+ i
;
1476 /* String was not on free-list before. */
1477 if (STRING_MARKED_P (s
))
1479 /* String is live; unmark it and its intervals. */
1482 if (!NULL_INTERVAL_P (s
->intervals
))
1483 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1486 total_string_size
+= STRING_BYTES (s
);
1490 /* String is dead. Put it on the free-list. */
1491 struct sdata
*data
= SDATA_OF_STRING (s
);
1493 /* Save the size of S in its sdata so that we know
1494 how large that is. Reset the sdata's string
1495 back-pointer so that we know it's free. */
1496 #ifdef GC_CHECK_STRING_BYTES
1497 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1500 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1502 data
->string
= NULL
;
1504 /* Reset the strings's `data' member so that we
1508 /* Put the string on the free-list. */
1509 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1510 string_free_list
= s
;
1516 /* S was on the free-list before. Put it there again. */
1517 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1518 string_free_list
= s
;
1523 /* Free blocks that contain free Lisp_Strings only, except
1524 the first two of them. */
1525 if (nfree
== STRINGS_IN_STRING_BLOCK
1526 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1530 string_free_list
= free_list_before
;
1534 total_free_strings
+= nfree
;
1535 b
->next
= live_blocks
;
1540 string_blocks
= live_blocks
;
1541 free_large_strings ();
1542 compact_small_strings ();
1546 /* Free dead large strings. */
1549 free_large_strings ()
1551 struct sblock
*b
, *next
;
1552 struct sblock
*live_blocks
= NULL
;
1554 for (b
= large_sblocks
; b
; b
= next
)
1558 if (b
->first_data
.string
== NULL
)
1562 b
->next
= live_blocks
;
1567 large_sblocks
= live_blocks
;
1571 /* Compact data of small strings. Free sblocks that don't contain
1572 data of live strings after compaction. */
1575 compact_small_strings ()
1577 struct sblock
*b
, *tb
, *next
;
1578 struct sdata
*from
, *to
, *end
, *tb_end
;
1579 struct sdata
*to_end
, *from_end
;
1581 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1582 to, and TB_END is the end of TB. */
1584 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1585 to
= &tb
->first_data
;
1587 /* Step through the blocks from the oldest to the youngest. We
1588 expect that old blocks will stabilize over time, so that less
1589 copying will happen this way. */
1590 for (b
= oldest_sblock
; b
; b
= b
->next
)
1593 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1595 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1597 /* Compute the next FROM here because copying below may
1598 overwrite data we need to compute it. */
1601 #ifdef GC_CHECK_STRING_BYTES
1602 /* Check that the string size recorded in the string is the
1603 same as the one recorded in the sdata structure. */
1605 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1607 #endif /* GC_CHECK_STRING_BYTES */
1610 nbytes
= GC_STRING_BYTES (from
->string
);
1612 nbytes
= SDATA_NBYTES (from
);
1614 nbytes
= SDATA_SIZE (nbytes
);
1615 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1617 /* FROM->string non-null means it's alive. Copy its data. */
1620 /* If TB is full, proceed with the next sblock. */
1621 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1622 if (to_end
> tb_end
)
1626 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1627 to
= &tb
->first_data
;
1628 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1631 /* Copy, and update the string's `data' pointer. */
1634 xassert (tb
!= b
|| to
<= from
);
1635 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1636 to
->string
->data
= SDATA_DATA (to
);
1639 /* Advance past the sdata we copied to. */
1645 /* The rest of the sblocks following TB don't contain live data, so
1646 we can free them. */
1647 for (b
= tb
->next
; b
; b
= next
)
1655 current_sblock
= tb
;
1659 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1660 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1661 Both LENGTH and INIT must be numbers.")
1663 Lisp_Object length
, init
;
1665 register Lisp_Object val
;
1666 register unsigned char *p
, *end
;
1669 CHECK_NATNUM (length
, 0);
1670 CHECK_NUMBER (init
, 1);
1673 if (SINGLE_BYTE_CHAR_P (c
))
1675 nbytes
= XINT (length
);
1676 val
= make_uninit_string (nbytes
);
1677 p
= XSTRING (val
)->data
;
1678 end
= p
+ XSTRING (val
)->size
;
1684 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1685 int len
= CHAR_STRING (c
, str
);
1687 nbytes
= len
* XINT (length
);
1688 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1689 p
= XSTRING (val
)->data
;
1693 bcopy (str
, p
, len
);
1703 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1704 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1705 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1707 Lisp_Object length
, init
;
1709 register Lisp_Object val
;
1710 struct Lisp_Bool_Vector
*p
;
1712 int length_in_chars
, length_in_elts
, bits_per_value
;
1714 CHECK_NATNUM (length
, 0);
1716 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1718 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1719 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1721 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1722 slot `size' of the struct Lisp_Bool_Vector. */
1723 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1724 p
= XBOOL_VECTOR (val
);
1726 /* Get rid of any bits that would cause confusion. */
1728 XSETBOOL_VECTOR (val
, p
);
1729 p
->size
= XFASTINT (length
);
1731 real_init
= (NILP (init
) ? 0 : -1);
1732 for (i
= 0; i
< length_in_chars
; i
++)
1733 p
->data
[i
] = real_init
;
1735 /* Clear the extraneous bits in the last byte. */
1736 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1737 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1738 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1744 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1745 of characters from the contents. This string may be unibyte or
1746 multibyte, depending on the contents. */
1749 make_string (contents
, nbytes
)
1753 register Lisp_Object val
;
1754 int nchars
, multibyte_nbytes
;
1756 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1757 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1758 /* CONTENTS contains no multibyte sequences or contains an invalid
1759 multibyte sequence. We must make unibyte string. */
1760 val
= make_unibyte_string (contents
, nbytes
);
1762 val
= make_multibyte_string (contents
, nchars
, nbytes
);
1767 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1770 make_unibyte_string (contents
, length
)
1774 register Lisp_Object val
;
1775 val
= make_uninit_string (length
);
1776 bcopy (contents
, XSTRING (val
)->data
, length
);
1777 SET_STRING_BYTES (XSTRING (val
), -1);
1782 /* Make a multibyte string from NCHARS characters occupying NBYTES
1783 bytes at CONTENTS. */
1786 make_multibyte_string (contents
, nchars
, nbytes
)
1790 register Lisp_Object val
;
1791 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1792 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1797 /* Make a string from NCHARS characters occupying NBYTES bytes at
1798 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1801 make_string_from_bytes (contents
, nchars
, nbytes
)
1805 register Lisp_Object val
;
1806 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1807 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1808 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1809 SET_STRING_BYTES (XSTRING (val
), -1);
1814 /* Make a string from NCHARS characters occupying NBYTES bytes at
1815 CONTENTS. The argument MULTIBYTE controls whether to label the
1816 string as multibyte. */
1819 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1824 register Lisp_Object val
;
1825 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1826 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1828 SET_STRING_BYTES (XSTRING (val
), -1);
1833 /* Make a string from the data at STR, treating it as multibyte if the
1840 return make_string (str
, strlen (str
));
1844 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1845 occupying LENGTH bytes. */
1848 make_uninit_string (length
)
1852 val
= make_uninit_multibyte_string (length
, length
);
1853 SET_STRING_BYTES (XSTRING (val
), -1);
1858 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1859 which occupy NBYTES bytes. */
1862 make_uninit_multibyte_string (nchars
, nbytes
)
1866 struct Lisp_String
*s
;
1871 s
= allocate_string ();
1872 allocate_string_data (s
, nchars
, nbytes
);
1873 XSETSTRING (string
, s
);
1874 string_chars_consed
+= nbytes
;
1880 /***********************************************************************
1882 ***********************************************************************/
1884 /* We store float cells inside of float_blocks, allocating a new
1885 float_block with malloc whenever necessary. Float cells reclaimed
1886 by GC are put on a free list to be reallocated before allocating
1887 any new float cells from the latest float_block.
1889 Each float_block is just under 1020 bytes long, since malloc really
1890 allocates in units of powers of two and uses 4 bytes for its own
1893 #define FLOAT_BLOCK_SIZE \
1894 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1898 struct float_block
*next
;
1899 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1902 /* Current float_block. */
1904 struct float_block
*float_block
;
1906 /* Index of first unused Lisp_Float in the current float_block. */
1908 int float_block_index
;
1910 /* Total number of float blocks now in use. */
1914 /* Free-list of Lisp_Floats. */
1916 struct Lisp_Float
*float_free_list
;
1919 /* Initialize float allocation. */
1924 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1926 float_block
->next
= 0;
1927 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1928 float_block_index
= 0;
1929 float_free_list
= 0;
1934 /* Explicitly free a float cell by putting it on the free-list. */
1938 struct Lisp_Float
*ptr
;
1940 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1944 float_free_list
= ptr
;
1948 /* Return a new float object with value FLOAT_VALUE. */
1951 make_float (float_value
)
1954 register Lisp_Object val
;
1956 if (float_free_list
)
1958 /* We use the data field for chaining the free list
1959 so that we won't use the same field that has the mark bit. */
1960 XSETFLOAT (val
, float_free_list
);
1961 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1965 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1967 register struct float_block
*new;
1969 new = (struct float_block
*) lisp_malloc (sizeof *new,
1971 VALIDATE_LISP_STORAGE (new, sizeof *new);
1972 new->next
= float_block
;
1974 float_block_index
= 0;
1977 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1980 XFLOAT_DATA (val
) = float_value
;
1981 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1982 consing_since_gc
+= sizeof (struct Lisp_Float
);
1989 /***********************************************************************
1991 ***********************************************************************/
1993 /* We store cons cells inside of cons_blocks, allocating a new
1994 cons_block with malloc whenever necessary. Cons cells reclaimed by
1995 GC are put on a free list to be reallocated before allocating
1996 any new cons cells from the latest cons_block.
1998 Each cons_block is just under 1020 bytes long,
1999 since malloc really allocates in units of powers of two
2000 and uses 4 bytes for its own overhead. */
2002 #define CONS_BLOCK_SIZE \
2003 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
2007 struct cons_block
*next
;
2008 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2011 /* Current cons_block. */
2013 struct cons_block
*cons_block
;
2015 /* Index of first unused Lisp_Cons in the current block. */
2017 int cons_block_index
;
2019 /* Free-list of Lisp_Cons structures. */
2021 struct Lisp_Cons
*cons_free_list
;
2023 /* Total number of cons blocks now in use. */
2028 /* Initialize cons allocation. */
2033 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
2035 cons_block
->next
= 0;
2036 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
2037 cons_block_index
= 0;
2043 /* Explicitly free a cons cell by putting it on the free-list. */
2047 struct Lisp_Cons
*ptr
;
2049 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2053 cons_free_list
= ptr
;
2057 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2058 "Create a new cons, give it CAR and CDR as components, and return it.")
2060 Lisp_Object car
, cdr
;
2062 register Lisp_Object val
;
2066 /* We use the cdr for chaining the free list
2067 so that we won't use the same field that has the mark bit. */
2068 XSETCONS (val
, cons_free_list
);
2069 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2073 if (cons_block_index
== CONS_BLOCK_SIZE
)
2075 register struct cons_block
*new;
2076 new = (struct cons_block
*) lisp_malloc (sizeof *new,
2078 VALIDATE_LISP_STORAGE (new, sizeof *new);
2079 new->next
= cons_block
;
2081 cons_block_index
= 0;
2084 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
2089 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2090 cons_cells_consed
++;
2095 /* Make a list of 2, 3, 4 or 5 specified objects. */
2099 Lisp_Object arg1
, arg2
;
2101 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2106 list3 (arg1
, arg2
, arg3
)
2107 Lisp_Object arg1
, arg2
, arg3
;
2109 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2114 list4 (arg1
, arg2
, arg3
, arg4
)
2115 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2117 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2122 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2123 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2125 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2126 Fcons (arg5
, Qnil
)))));
2130 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2131 "Return a newly created list with specified arguments as elements.\n\
2132 Any number of arguments, even zero arguments, are allowed.")
2135 register Lisp_Object
*args
;
2137 register Lisp_Object val
;
2143 val
= Fcons (args
[nargs
], val
);
2149 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2150 "Return a newly created list of length LENGTH, with each element being INIT.")
2152 register Lisp_Object length
, init
;
2154 register Lisp_Object val
;
2157 CHECK_NATNUM (length
, 0);
2158 size
= XFASTINT (length
);
2163 val
= Fcons (init
, val
);
2168 val
= Fcons (init
, val
);
2173 val
= Fcons (init
, val
);
2178 val
= Fcons (init
, val
);
2183 val
= Fcons (init
, val
);
2198 /***********************************************************************
2200 ***********************************************************************/
2202 /* Singly-linked list of all vectors. */
2204 struct Lisp_Vector
*all_vectors
;
2206 /* Total number of vector-like objects now in use. */
2211 /* Value is a pointer to a newly allocated Lisp_Vector structure
2212 with room for LEN Lisp_Objects. */
2214 static struct Lisp_Vector
*
2215 allocate_vectorlike (len
, type
)
2219 struct Lisp_Vector
*p
;
2222 #ifdef DOUG_LEA_MALLOC
2223 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2224 because mapped region contents are not preserved in
2226 mallopt (M_MMAP_MAX
, 0);
2229 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2230 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2232 #ifdef DOUG_LEA_MALLOC
2233 /* Back to a reasonable maximum of mmap'ed areas. */
2234 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2237 VALIDATE_LISP_STORAGE (p
, 0);
2238 consing_since_gc
+= nbytes
;
2239 vector_cells_consed
+= len
;
2241 p
->next
= all_vectors
;
2248 /* Allocate a vector with NSLOTS slots. */
2250 struct Lisp_Vector
*
2251 allocate_vector (nslots
)
2254 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2260 /* Allocate other vector-like structures. */
2262 struct Lisp_Hash_Table
*
2263 allocate_hash_table ()
2265 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2266 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2270 for (i
= 0; i
< len
; ++i
)
2271 v
->contents
[i
] = Qnil
;
2273 return (struct Lisp_Hash_Table
*) v
;
2280 EMACS_INT len
= VECSIZE (struct window
);
2281 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2284 for (i
= 0; i
< len
; ++i
)
2285 v
->contents
[i
] = Qnil
;
2288 return (struct window
*) v
;
2295 EMACS_INT len
= VECSIZE (struct frame
);
2296 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2299 for (i
= 0; i
< len
; ++i
)
2300 v
->contents
[i
] = make_number (0);
2302 return (struct frame
*) v
;
2306 struct Lisp_Process
*
2309 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2310 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2313 for (i
= 0; i
< len
; ++i
)
2314 v
->contents
[i
] = Qnil
;
2317 return (struct Lisp_Process
*) v
;
2321 struct Lisp_Vector
*
2322 allocate_other_vector (len
)
2325 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2328 for (i
= 0; i
< len
; ++i
)
2329 v
->contents
[i
] = Qnil
;
2336 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2337 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
2338 See also the function `vector'.")
2340 register Lisp_Object length
, init
;
2343 register EMACS_INT sizei
;
2345 register struct Lisp_Vector
*p
;
2347 CHECK_NATNUM (length
, 0);
2348 sizei
= XFASTINT (length
);
2350 p
= allocate_vector (sizei
);
2351 for (index
= 0; index
< sizei
; index
++)
2352 p
->contents
[index
] = init
;
2354 XSETVECTOR (vector
, p
);
2359 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2360 "Return a newly created char-table, with purpose PURPOSE.\n\
2361 Each element is initialized to INIT, which defaults to nil.\n\
2362 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
2363 The property's value should be an integer between 0 and 10.")
2365 register Lisp_Object purpose
, init
;
2369 CHECK_SYMBOL (purpose
, 1);
2370 n
= Fget (purpose
, Qchar_table_extra_slots
);
2371 CHECK_NUMBER (n
, 0);
2372 if (XINT (n
) < 0 || XINT (n
) > 10)
2373 args_out_of_range (n
, Qnil
);
2374 /* Add 2 to the size for the defalt and parent slots. */
2375 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2377 XCHAR_TABLE (vector
)->top
= Qt
;
2378 XCHAR_TABLE (vector
)->parent
= Qnil
;
2379 XCHAR_TABLE (vector
)->purpose
= purpose
;
2380 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2385 /* Return a newly created sub char table with default value DEFALT.
2386 Since a sub char table does not appear as a top level Emacs Lisp
2387 object, we don't need a Lisp interface to make it. */
2390 make_sub_char_table (defalt
)
2394 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2395 XCHAR_TABLE (vector
)->top
= Qnil
;
2396 XCHAR_TABLE (vector
)->defalt
= defalt
;
2397 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2402 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2403 "Return a newly created vector with specified arguments as elements.\n\
2404 Any number of arguments, even zero arguments, are allowed.")
2409 register Lisp_Object len
, val
;
2411 register struct Lisp_Vector
*p
;
2413 XSETFASTINT (len
, nargs
);
2414 val
= Fmake_vector (len
, Qnil
);
2416 for (index
= 0; index
< nargs
; index
++)
2417 p
->contents
[index
] = args
[index
];
2422 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2423 "Create a byte-code object with specified arguments as elements.\n\
2424 The arguments should be the arglist, bytecode-string, constant vector,\n\
2425 stack size, (optional) doc string, and (optional) interactive spec.\n\
2426 The first four arguments are required; at most six have any\n\
2432 register Lisp_Object len
, val
;
2434 register struct Lisp_Vector
*p
;
2436 XSETFASTINT (len
, nargs
);
2437 if (!NILP (Vpurify_flag
))
2438 val
= make_pure_vector ((EMACS_INT
) nargs
);
2440 val
= Fmake_vector (len
, Qnil
);
2442 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2443 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2444 earlier because they produced a raw 8-bit string for byte-code
2445 and now such a byte-code string is loaded as multibyte while
2446 raw 8-bit characters converted to multibyte form. Thus, now we
2447 must convert them back to the original unibyte form. */
2448 args
[1] = Fstring_as_unibyte (args
[1]);
2451 for (index
= 0; index
< nargs
; index
++)
2453 if (!NILP (Vpurify_flag
))
2454 args
[index
] = Fpurecopy (args
[index
]);
2455 p
->contents
[index
] = args
[index
];
2457 XSETCOMPILED (val
, p
);
2463 /***********************************************************************
2465 ***********************************************************************/
2467 /* Each symbol_block is just under 1020 bytes long, since malloc
2468 really allocates in units of powers of two and uses 4 bytes for its
2471 #define SYMBOL_BLOCK_SIZE \
2472 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2476 struct symbol_block
*next
;
2477 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2480 /* Current symbol block and index of first unused Lisp_Symbol
2483 struct symbol_block
*symbol_block
;
2484 int symbol_block_index
;
2486 /* List of free symbols. */
2488 struct Lisp_Symbol
*symbol_free_list
;
2490 /* Total number of symbol blocks now in use. */
2492 int n_symbol_blocks
;
2495 /* Initialize symbol allocation. */
2500 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
2502 symbol_block
->next
= 0;
2503 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
2504 symbol_block_index
= 0;
2505 symbol_free_list
= 0;
2506 n_symbol_blocks
= 1;
2510 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2511 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2512 Its value and function definition are void, and its property list is nil.")
2516 register Lisp_Object val
;
2517 register struct Lisp_Symbol
*p
;
2519 CHECK_STRING (name
, 0);
2521 if (symbol_free_list
)
2523 XSETSYMBOL (val
, symbol_free_list
);
2524 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2528 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2530 struct symbol_block
*new;
2531 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2533 VALIDATE_LISP_STORAGE (new, sizeof *new);
2534 new->next
= symbol_block
;
2536 symbol_block_index
= 0;
2539 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2543 p
->name
= XSTRING (name
);
2546 p
->value
= Qunbound
;
2547 p
->function
= Qunbound
;
2549 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2556 /***********************************************************************
2557 Marker (Misc) Allocation
2558 ***********************************************************************/
2560 /* Allocation of markers and other objects that share that structure.
2561 Works like allocation of conses. */
2563 #define MARKER_BLOCK_SIZE \
2564 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2568 struct marker_block
*next
;
2569 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2572 struct marker_block
*marker_block
;
2573 int marker_block_index
;
2575 union Lisp_Misc
*marker_free_list
;
2577 /* Total number of marker blocks now in use. */
2579 int n_marker_blocks
;
2584 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2586 marker_block
->next
= 0;
2587 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2588 marker_block_index
= 0;
2589 marker_free_list
= 0;
2590 n_marker_blocks
= 1;
2593 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2600 if (marker_free_list
)
2602 XSETMISC (val
, marker_free_list
);
2603 marker_free_list
= marker_free_list
->u_free
.chain
;
2607 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2609 struct marker_block
*new;
2610 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2612 VALIDATE_LISP_STORAGE (new, sizeof *new);
2613 new->next
= marker_block
;
2615 marker_block_index
= 0;
2618 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2621 consing_since_gc
+= sizeof (union Lisp_Misc
);
2622 misc_objects_consed
++;
2626 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2627 "Return a newly allocated marker which does not point at any place.")
2630 register Lisp_Object val
;
2631 register struct Lisp_Marker
*p
;
2633 val
= allocate_misc ();
2634 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2640 p
->insertion_type
= 0;
2644 /* Put MARKER back on the free list after using it temporarily. */
2647 free_marker (marker
)
2650 unchain_marker (marker
);
2652 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2653 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2654 marker_free_list
= XMISC (marker
);
2656 total_free_markers
++;
2660 /* Return a newly created vector or string with specified arguments as
2661 elements. If all the arguments are characters that can fit
2662 in a string of events, make a string; otherwise, make a vector.
2664 Any number of arguments, even zero arguments, are allowed. */
2667 make_event_array (nargs
, args
)
2673 for (i
= 0; i
< nargs
; i
++)
2674 /* The things that fit in a string
2675 are characters that are in 0...127,
2676 after discarding the meta bit and all the bits above it. */
2677 if (!INTEGERP (args
[i
])
2678 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2679 return Fvector (nargs
, args
);
2681 /* Since the loop exited, we know that all the things in it are
2682 characters, so we can make a string. */
2686 result
= Fmake_string (make_number (nargs
), make_number (0));
2687 for (i
= 0; i
< nargs
; i
++)
2689 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2690 /* Move the meta bit to the right place for a string char. */
2691 if (XINT (args
[i
]) & CHAR_META
)
2692 XSTRING (result
)->data
[i
] |= 0x80;
2701 /************************************************************************
2703 ************************************************************************/
2705 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
2707 /* Initialize this part of alloc.c. */
2712 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2713 mem_z
.parent
= NULL
;
2714 mem_z
.color
= MEM_BLACK
;
2715 mem_z
.start
= mem_z
.end
= NULL
;
2720 /* Value is a pointer to the mem_node containing START. Value is
2721 MEM_NIL if there is no node in the tree containing START. */
2723 static INLINE
struct mem_node
*
2729 if (start
< min_heap_address
|| start
> max_heap_address
)
2732 /* Make the search always successful to speed up the loop below. */
2733 mem_z
.start
= start
;
2734 mem_z
.end
= (char *) start
+ 1;
2737 while (start
< p
->start
|| start
>= p
->end
)
2738 p
= start
< p
->start
? p
->left
: p
->right
;
2743 /* Insert a new node into the tree for a block of memory with start
2744 address START, end address END, and type TYPE. Value is a
2745 pointer to the node that was inserted. */
2747 static struct mem_node
*
2748 mem_insert (start
, end
, type
)
2752 struct mem_node
*c
, *parent
, *x
;
2754 if (start
< min_heap_address
)
2755 min_heap_address
= start
;
2756 if (end
> max_heap_address
)
2757 max_heap_address
= end
;
2759 /* See where in the tree a node for START belongs. In this
2760 particular application, it shouldn't happen that a node is already
2761 present. For debugging purposes, let's check that. */
2765 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2767 while (c
!= MEM_NIL
)
2769 if (start
>= c
->start
&& start
< c
->end
)
2772 c
= start
< c
->start
? c
->left
: c
->right
;
2775 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2777 while (c
!= MEM_NIL
)
2780 c
= start
< c
->start
? c
->left
: c
->right
;
2783 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2785 /* Create a new node. */
2786 #ifdef GC_MALLOC_CHECK
2787 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
2791 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2797 x
->left
= x
->right
= MEM_NIL
;
2800 /* Insert it as child of PARENT or install it as root. */
2803 if (start
< parent
->start
)
2811 /* Re-establish red-black tree properties. */
2812 mem_insert_fixup (x
);
2818 /* Re-establish the red-black properties of the tree, and thereby
2819 balance the tree, after node X has been inserted; X is always red. */
2822 mem_insert_fixup (x
)
2825 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2827 /* X is red and its parent is red. This is a violation of
2828 red-black tree property #3. */
2830 if (x
->parent
== x
->parent
->parent
->left
)
2832 /* We're on the left side of our grandparent, and Y is our
2834 struct mem_node
*y
= x
->parent
->parent
->right
;
2836 if (y
->color
== MEM_RED
)
2838 /* Uncle and parent are red but should be black because
2839 X is red. Change the colors accordingly and proceed
2840 with the grandparent. */
2841 x
->parent
->color
= MEM_BLACK
;
2842 y
->color
= MEM_BLACK
;
2843 x
->parent
->parent
->color
= MEM_RED
;
2844 x
= x
->parent
->parent
;
2848 /* Parent and uncle have different colors; parent is
2849 red, uncle is black. */
2850 if (x
== x
->parent
->right
)
2853 mem_rotate_left (x
);
2856 x
->parent
->color
= MEM_BLACK
;
2857 x
->parent
->parent
->color
= MEM_RED
;
2858 mem_rotate_right (x
->parent
->parent
);
2863 /* This is the symmetrical case of above. */
2864 struct mem_node
*y
= x
->parent
->parent
->left
;
2866 if (y
->color
== MEM_RED
)
2868 x
->parent
->color
= MEM_BLACK
;
2869 y
->color
= MEM_BLACK
;
2870 x
->parent
->parent
->color
= MEM_RED
;
2871 x
= x
->parent
->parent
;
2875 if (x
== x
->parent
->left
)
2878 mem_rotate_right (x
);
2881 x
->parent
->color
= MEM_BLACK
;
2882 x
->parent
->parent
->color
= MEM_RED
;
2883 mem_rotate_left (x
->parent
->parent
);
2888 /* The root may have been changed to red due to the algorithm. Set
2889 it to black so that property #5 is satisfied. */
2890 mem_root
->color
= MEM_BLACK
;
2906 /* Turn y's left sub-tree into x's right sub-tree. */
2909 if (y
->left
!= MEM_NIL
)
2910 y
->left
->parent
= x
;
2912 /* Y's parent was x's parent. */
2914 y
->parent
= x
->parent
;
2916 /* Get the parent to point to y instead of x. */
2919 if (x
== x
->parent
->left
)
2920 x
->parent
->left
= y
;
2922 x
->parent
->right
= y
;
2927 /* Put x on y's left. */
2941 mem_rotate_right (x
)
2944 struct mem_node
*y
= x
->left
;
2947 if (y
->right
!= MEM_NIL
)
2948 y
->right
->parent
= x
;
2951 y
->parent
= x
->parent
;
2954 if (x
== x
->parent
->right
)
2955 x
->parent
->right
= y
;
2957 x
->parent
->left
= y
;
2968 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2974 struct mem_node
*x
, *y
;
2976 if (!z
|| z
== MEM_NIL
)
2979 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2984 while (y
->left
!= MEM_NIL
)
2988 if (y
->left
!= MEM_NIL
)
2993 x
->parent
= y
->parent
;
2996 if (y
== y
->parent
->left
)
2997 y
->parent
->left
= x
;
2999 y
->parent
->right
= x
;
3006 z
->start
= y
->start
;
3011 if (y
->color
== MEM_BLACK
)
3012 mem_delete_fixup (x
);
3014 #ifdef GC_MALLOC_CHECK
3022 /* Re-establish the red-black properties of the tree, after a
3026 mem_delete_fixup (x
)
3029 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3031 if (x
== x
->parent
->left
)
3033 struct mem_node
*w
= x
->parent
->right
;
3035 if (w
->color
== MEM_RED
)
3037 w
->color
= MEM_BLACK
;
3038 x
->parent
->color
= MEM_RED
;
3039 mem_rotate_left (x
->parent
);
3040 w
= x
->parent
->right
;
3043 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3050 if (w
->right
->color
== MEM_BLACK
)
3052 w
->left
->color
= MEM_BLACK
;
3054 mem_rotate_right (w
);
3055 w
= x
->parent
->right
;
3057 w
->color
= x
->parent
->color
;
3058 x
->parent
->color
= MEM_BLACK
;
3059 w
->right
->color
= MEM_BLACK
;
3060 mem_rotate_left (x
->parent
);
3066 struct mem_node
*w
= x
->parent
->left
;
3068 if (w
->color
== MEM_RED
)
3070 w
->color
= MEM_BLACK
;
3071 x
->parent
->color
= MEM_RED
;
3072 mem_rotate_right (x
->parent
);
3073 w
= x
->parent
->left
;
3076 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3083 if (w
->left
->color
== MEM_BLACK
)
3085 w
->right
->color
= MEM_BLACK
;
3087 mem_rotate_left (w
);
3088 w
= x
->parent
->left
;
3091 w
->color
= x
->parent
->color
;
3092 x
->parent
->color
= MEM_BLACK
;
3093 w
->left
->color
= MEM_BLACK
;
3094 mem_rotate_right (x
->parent
);
3100 x
->color
= MEM_BLACK
;
3104 /* Value is non-zero if P is a pointer to a live Lisp string on
3105 the heap. M is a pointer to the mem_block for P. */
3108 live_string_p (m
, p
)
3112 if (m
->type
== MEM_TYPE_STRING
)
3114 struct string_block
*b
= (struct string_block
*) m
->start
;
3115 int offset
= (char *) p
- (char *) &b
->strings
[0];
3117 /* P must point to the start of a Lisp_String structure, and it
3118 must not be on the free-list. */
3120 && offset
% sizeof b
->strings
[0] == 0
3121 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3128 /* Value is non-zero if P is a pointer to a live Lisp cons on
3129 the heap. M is a pointer to the mem_block for P. */
3136 if (m
->type
== MEM_TYPE_CONS
)
3138 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3139 int offset
= (char *) p
- (char *) &b
->conses
[0];
3141 /* P must point to the start of a Lisp_Cons, not be
3142 one of the unused cells in the current cons block,
3143 and not be on the free-list. */
3145 && offset
% sizeof b
->conses
[0] == 0
3147 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3148 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3155 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3156 the heap. M is a pointer to the mem_block for P. */
3159 live_symbol_p (m
, p
)
3163 if (m
->type
== MEM_TYPE_SYMBOL
)
3165 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3166 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3168 /* P must point to the start of a Lisp_Symbol, not be
3169 one of the unused cells in the current symbol block,
3170 and not be on the free-list. */
3172 && offset
% sizeof b
->symbols
[0] == 0
3173 && (b
!= symbol_block
3174 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3175 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3182 /* Value is non-zero if P is a pointer to a live Lisp float on
3183 the heap. M is a pointer to the mem_block for P. */
3190 if (m
->type
== MEM_TYPE_FLOAT
)
3192 struct float_block
*b
= (struct float_block
*) m
->start
;
3193 int offset
= (char *) p
- (char *) &b
->floats
[0];
3195 /* P must point to the start of a Lisp_Float, not be
3196 one of the unused cells in the current float block,
3197 and not be on the free-list. */
3199 && offset
% sizeof b
->floats
[0] == 0
3200 && (b
!= float_block
3201 || offset
/ sizeof b
->floats
[0] < float_block_index
)
3202 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
3209 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3210 the heap. M is a pointer to the mem_block for P. */
3217 if (m
->type
== MEM_TYPE_MISC
)
3219 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3220 int offset
= (char *) p
- (char *) &b
->markers
[0];
3222 /* P must point to the start of a Lisp_Misc, not be
3223 one of the unused cells in the current misc block,
3224 and not be on the free-list. */
3226 && offset
% sizeof b
->markers
[0] == 0
3227 && (b
!= marker_block
3228 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3229 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3236 /* Value is non-zero if P is a pointer to a live vector-like object.
3237 M is a pointer to the mem_block for P. */
3240 live_vector_p (m
, p
)
3244 return (p
== m
->start
3245 && m
->type
>= MEM_TYPE_VECTOR
3246 && m
->type
<= MEM_TYPE_WINDOW
);
3250 /* Value is non-zero of P is a pointer to a live buffer. M is a
3251 pointer to the mem_block for P. */
3254 live_buffer_p (m
, p
)
3258 /* P must point to the start of the block, and the buffer
3259 must not have been killed. */
3260 return (m
->type
== MEM_TYPE_BUFFER
3262 && !NILP (((struct buffer
*) p
)->name
));
3265 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3269 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3271 /* Array of objects that are kept alive because the C stack contains
3272 a pattern that looks like a reference to them . */
3274 #define MAX_ZOMBIES 10
3275 static Lisp_Object zombies
[MAX_ZOMBIES
];
3277 /* Number of zombie objects. */
3279 static int nzombies
;
3281 /* Number of garbage collections. */
3285 /* Average percentage of zombies per collection. */
3287 static double avg_zombies
;
3289 /* Max. number of live and zombie objects. */
3291 static int max_live
, max_zombies
;
3293 /* Average number of live objects per GC. */
3295 static double avg_live
;
3297 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3298 "Show information about live and zombie objects.")
3301 Lisp_Object args
[7];
3302 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
3303 args
[1] = make_number (ngcs
);
3304 args
[2] = make_float (avg_live
);
3305 args
[3] = make_float (avg_zombies
);
3306 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3307 args
[5] = make_number (max_live
);
3308 args
[6] = make_number (max_zombies
);
3309 return Fmessage (7, args
);
3312 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3315 /* Mark OBJ if we can prove it's a Lisp_Object. */
3318 mark_maybe_object (obj
)
3321 void *po
= (void *) XPNTR (obj
);
3322 struct mem_node
*m
= mem_find (po
);
3328 switch (XGCTYPE (obj
))
3331 mark_p
= (live_string_p (m
, po
)
3332 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3336 mark_p
= (live_cons_p (m
, po
)
3337 && !XMARKBIT (XCONS (obj
)->car
));
3341 mark_p
= (live_symbol_p (m
, po
)
3342 && !XMARKBIT (XSYMBOL (obj
)->plist
));
3346 mark_p
= (live_float_p (m
, po
)
3347 && !XMARKBIT (XFLOAT (obj
)->type
));
3350 case Lisp_Vectorlike
:
3351 /* Note: can't check GC_BUFFERP before we know it's a
3352 buffer because checking that dereferences the pointer
3353 PO which might point anywhere. */
3354 if (live_vector_p (m
, po
))
3355 mark_p
= (!GC_SUBRP (obj
)
3356 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
3357 else if (live_buffer_p (m
, po
))
3358 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
3362 if (live_misc_p (m
, po
))
3364 switch (XMISCTYPE (obj
))
3366 case Lisp_Misc_Marker
:
3367 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
3370 case Lisp_Misc_Buffer_Local_Value
:
3371 case Lisp_Misc_Some_Buffer_Local_Value
:
3372 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
3375 case Lisp_Misc_Overlay
:
3376 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
3383 case Lisp_Type_Limit
:
3389 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3390 if (nzombies
< MAX_ZOMBIES
)
3391 zombies
[nzombies
] = *p
;
3400 /* If P points to Lisp data, mark that as live if it isn't already
3404 mark_maybe_pointer (p
)
3409 /* Quickly rule out some values which can't point to Lisp data. We
3410 assume that Lisp data is aligned on even addresses. */
3411 if ((EMACS_INT
) p
& 1)
3417 Lisp_Object obj
= Qnil
;
3421 case MEM_TYPE_NON_LISP
:
3422 /* Nothing to do; not a pointer to Lisp memory. */
3425 case MEM_TYPE_BUFFER
:
3426 if (live_buffer_p (m
, p
)
3427 && !XMARKBIT (((struct buffer
*) p
)->name
))
3428 XSETVECTOR (obj
, p
);
3432 if (live_cons_p (m
, p
)
3433 && !XMARKBIT (((struct Lisp_Cons
*) p
)->car
))
3437 case MEM_TYPE_STRING
:
3438 if (live_string_p (m
, p
)
3439 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
3440 XSETSTRING (obj
, p
);
3444 if (live_misc_p (m
, p
))
3449 switch (XMISCTYPE (tem
))
3451 case Lisp_Misc_Marker
:
3452 if (!XMARKBIT (XMARKER (tem
)->chain
))
3456 case Lisp_Misc_Buffer_Local_Value
:
3457 case Lisp_Misc_Some_Buffer_Local_Value
:
3458 if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem
)->realvalue
))
3462 case Lisp_Misc_Overlay
:
3463 if (!XMARKBIT (XOVERLAY (tem
)->plist
))
3470 case MEM_TYPE_SYMBOL
:
3471 if (live_symbol_p (m
, p
)
3472 && !XMARKBIT (((struct Lisp_Symbol
*) p
)->plist
))
3473 XSETSYMBOL (obj
, p
);
3476 case MEM_TYPE_FLOAT
:
3477 if (live_float_p (m
, p
)
3478 && !XMARKBIT (((struct Lisp_Float
*) p
)->type
))
3482 case MEM_TYPE_VECTOR
:
3483 case MEM_TYPE_PROCESS
:
3484 case MEM_TYPE_HASH_TABLE
:
3485 case MEM_TYPE_FRAME
:
3486 case MEM_TYPE_WINDOW
:
3487 if (live_vector_p (m
, p
))
3490 XSETVECTOR (tem
, p
);
3492 && !(XVECTOR (tem
)->size
& ARRAY_MARK_FLAG
))
3507 /* Mark Lisp objects referenced from the address range START..END. */
3510 mark_memory (start
, end
)
3516 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3520 /* Make START the pointer to the start of the memory region,
3521 if it isn't already. */
3529 /* Mark Lisp_Objects. */
3530 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3531 mark_maybe_object (*p
);
3533 /* Mark Lisp data pointed to. This is necessary because, in some
3534 situations, the C compiler optimizes Lisp objects away, so that
3535 only a pointer to them remains. Example:
3537 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
3540 Lisp_Object obj = build_string ("test");
3541 struct Lisp_String *s = XSTRING (obj);
3542 Fgarbage_collect ();
3543 fprintf (stderr, "test `%s'\n", s->data);
3547 Here, `obj' isn't really used, and the compiler optimizes it
3548 away. The only reference to the life string is through the
3551 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
3552 mark_maybe_pointer (*pp
);
3556 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3558 static int setjmp_tested_p
, longjmps_done
;
3560 #define SETJMP_WILL_LIKELY_WORK "\
3562 Emacs garbage collector has been changed to use conservative stack\n\
3563 marking. Emacs has determined that the method it uses to do the\n\
3564 marking will likely work on your system, but this isn't sure.\n\
3566 If you are a system-programmer, or can get the help of a local wizard\n\
3567 who is, please take a look at the function mark_stack in alloc.c, and\n\
3568 verify that the methods used are appropriate for your system.\n\
3570 Please mail the result to <gerd@gnu.org>.\n\
3573 #define SETJMP_WILL_NOT_WORK "\
3575 Emacs garbage collector has been changed to use conservative stack\n\
3576 marking. Emacs has determined that the default method it uses to do the\n\
3577 marking will not work on your system. We will need a system-dependent\n\
3578 solution for your system.\n\
3580 Please take a look at the function mark_stack in alloc.c, and\n\
3581 try to find a way to make it work on your system.\n\
3582 Please mail the result to <gerd@gnu.org>.\n\
3586 /* Perform a quick check if it looks like setjmp saves registers in a
3587 jmp_buf. Print a message to stderr saying so. When this test
3588 succeeds, this is _not_ a proof that setjmp is sufficient for
3589 conservative stack marking. Only the sources or a disassembly
3600 /* Arrange for X to be put in a register. */
3606 if (longjmps_done
== 1)
3608 /* Came here after the longjmp at the end of the function.
3610 If x == 1, the longjmp has restored the register to its
3611 value before the setjmp, and we can hope that setjmp
3612 saves all such registers in the jmp_buf, although that
3615 For other values of X, either something really strange is
3616 taking place, or the setjmp just didn't save the register. */
3619 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3622 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3629 if (longjmps_done
== 1)
3633 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3636 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3638 /* Abort if anything GCPRO'd doesn't survive the GC. */
3646 for (p
= gcprolist
; p
; p
= p
->next
)
3647 for (i
= 0; i
< p
->nvars
; ++i
)
3648 if (!survives_gc_p (p
->var
[i
]))
3652 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3659 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3660 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3662 fprintf (stderr
, " %d = ", i
);
3663 debug_print (zombies
[i
]);
3667 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3670 /* Mark live Lisp objects on the C stack.
3672 There are several system-dependent problems to consider when
3673 porting this to new architectures:
3677 We have to mark Lisp objects in CPU registers that can hold local
3678 variables or are used to pass parameters.
3680 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3681 something that either saves relevant registers on the stack, or
3682 calls mark_maybe_object passing it each register's contents.
3684 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3685 implementation assumes that calling setjmp saves registers we need
3686 to see in a jmp_buf which itself lies on the stack. This doesn't
3687 have to be true! It must be verified for each system, possibly
3688 by taking a look at the source code of setjmp.
3692 Architectures differ in the way their processor stack is organized.
3693 For example, the stack might look like this
3696 | Lisp_Object | size = 4
3698 | something else | size = 2
3700 | Lisp_Object | size = 4
3704 In such a case, not every Lisp_Object will be aligned equally. To
3705 find all Lisp_Object on the stack it won't be sufficient to walk
3706 the stack in steps of 4 bytes. Instead, two passes will be
3707 necessary, one starting at the start of the stack, and a second
3708 pass starting at the start of the stack + 2. Likewise, if the
3709 minimal alignment of Lisp_Objects on the stack is 1, four passes
3710 would be necessary, each one starting with one byte more offset
3711 from the stack start.
3713 The current code assumes by default that Lisp_Objects are aligned
3714 equally on the stack. */
3720 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3723 /* This trick flushes the register windows so that all the state of
3724 the process is contained in the stack. */
3729 /* Save registers that we need to see on the stack. We need to see
3730 registers used to hold register variables and registers used to
3732 #ifdef GC_SAVE_REGISTERS_ON_STACK
3733 GC_SAVE_REGISTERS_ON_STACK (end
);
3734 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3736 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3737 setjmp will definitely work, test it
3738 and print a message with the result
3740 if (!setjmp_tested_p
)
3742 setjmp_tested_p
= 1;
3745 #endif /* GC_SETJMP_WORKS */
3748 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3749 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3751 /* This assumes that the stack is a contiguous region in memory. If
3752 that's not the case, something has to be done here to iterate
3753 over the stack segments. */
3754 #if GC_LISP_OBJECT_ALIGNMENT == 1
3755 mark_memory (stack_base
, end
);
3756 mark_memory ((char *) stack_base
+ 1, end
);
3757 mark_memory ((char *) stack_base
+ 2, end
);
3758 mark_memory ((char *) stack_base
+ 3, end
);
3759 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3760 mark_memory (stack_base
, end
);
3761 mark_memory ((char *) stack_base
+ 2, end
);
3763 mark_memory (stack_base
, end
);
3766 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3772 #endif /* GC_MARK_STACK != 0 */
3776 /***********************************************************************
3777 Pure Storage Management
3778 ***********************************************************************/
3780 /* Allocate room for SIZE bytes from pure Lisp storage and return a
3781 pointer to it. TYPE is the Lisp type for which the memory is
3782 allocated. TYPE < 0 means it's not used for a Lisp object.
3784 If store_pure_type_info is set and TYPE is >= 0, the type of
3785 the allocated object is recorded in pure_types. */
3787 static POINTER_TYPE
*
3788 pure_alloc (size
, type
)
3793 POINTER_TYPE
*result
;
3794 char *beg
= PUREBEG
;
3796 /* Give Lisp_Floats an extra alignment. */
3797 if (type
== Lisp_Float
)
3800 #if defined __GNUC__ && __GNUC__ >= 2
3801 alignment
= __alignof (struct Lisp_Float
);
3803 alignment
= sizeof (struct Lisp_Float
);
3805 pure_bytes_used
= ALIGN (pure_bytes_used
, alignment
);
3808 nbytes
= ALIGN (size
, sizeof (EMACS_INT
));
3809 if (pure_bytes_used
+ nbytes
> PURESIZE
)
3810 error ("Pure Lisp storage exhausted");
3812 result
= (POINTER_TYPE
*) (beg
+ pure_bytes_used
);
3813 pure_bytes_used
+= nbytes
;
3818 /* Return a string allocated in pure space. DATA is a buffer holding
3819 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3820 non-zero means make the result string multibyte.
3822 Must get an error if pure storage is full, since if it cannot hold
3823 a large string it may be able to hold conses that point to that
3824 string; then the string is not protected from gc. */
3827 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3833 struct Lisp_String
*s
;
3835 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
3836 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
3838 s
->size_byte
= multibyte
? nbytes
: -1;
3839 bcopy (data
, s
->data
, nbytes
);
3840 s
->data
[nbytes
] = '\0';
3841 s
->intervals
= NULL_INTERVAL
;
3842 XSETSTRING (string
, s
);
3847 /* Return a cons allocated from pure space. Give it pure copies
3848 of CAR as car and CDR as cdr. */
3851 pure_cons (car
, cdr
)
3852 Lisp_Object car
, cdr
;
3854 register Lisp_Object
new;
3855 struct Lisp_Cons
*p
;
3857 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
3859 XCAR (new) = Fpurecopy (car
);
3860 XCDR (new) = Fpurecopy (cdr
);
3865 /* Value is a float object with value NUM allocated from pure space. */
3868 make_pure_float (num
)
3871 register Lisp_Object
new;
3872 struct Lisp_Float
*p
;
3874 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
3876 XFLOAT_DATA (new) = num
;
3881 /* Return a vector with room for LEN Lisp_Objects allocated from
3885 make_pure_vector (len
)
3889 struct Lisp_Vector
*p
;
3890 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
3892 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
3893 XSETVECTOR (new, p
);
3894 XVECTOR (new)->size
= len
;
3899 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3900 "Make a copy of OBJECT in pure storage.\n\
3901 Recursively copies contents of vectors and cons cells.\n\
3902 Does not copy symbols. Copies strings without text properties.")
3904 register Lisp_Object obj
;
3906 if (NILP (Vpurify_flag
))
3909 if (PURE_POINTER_P (XPNTR (obj
)))
3913 return pure_cons (XCAR (obj
), XCDR (obj
));
3914 else if (FLOATP (obj
))
3915 return make_pure_float (XFLOAT_DATA (obj
));
3916 else if (STRINGP (obj
))
3917 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3918 STRING_BYTES (XSTRING (obj
)),
3919 STRING_MULTIBYTE (obj
));
3920 else if (COMPILEDP (obj
) || VECTORP (obj
))
3922 register struct Lisp_Vector
*vec
;
3923 register int i
, size
;
3925 size
= XVECTOR (obj
)->size
;
3926 if (size
& PSEUDOVECTOR_FLAG
)
3927 size
&= PSEUDOVECTOR_SIZE_MASK
;
3928 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3929 for (i
= 0; i
< size
; i
++)
3930 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3931 if (COMPILEDP (obj
))
3932 XSETCOMPILED (obj
, vec
);
3934 XSETVECTOR (obj
, vec
);
3937 else if (MARKERP (obj
))
3938 error ("Attempt to copy a marker to pure storage");
3945 /***********************************************************************
3947 ***********************************************************************/
3949 /* Put an entry in staticvec, pointing at the variable with address
3953 staticpro (varaddress
)
3954 Lisp_Object
*varaddress
;
3956 staticvec
[staticidx
++] = varaddress
;
3957 if (staticidx
>= NSTATICS
)
3965 struct catchtag
*next
;
3970 struct backtrace
*next
;
3971 Lisp_Object
*function
;
3972 Lisp_Object
*args
; /* Points to vector of args. */
3973 int nargs
; /* Length of vector. */
3974 /* If nargs is UNEVALLED, args points to slot holding list of
3981 /***********************************************************************
3983 ***********************************************************************/
3985 /* Temporarily prevent garbage collection. */
3988 inhibit_garbage_collection ()
3990 int count
= specpdl_ptr
- specpdl
;
3992 int nbits
= min (VALBITS
, BITS_PER_INT
);
3994 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3996 specbind (Qgc_cons_threshold
, number
);
4002 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4003 "Reclaim storage for Lisp objects no longer needed.\n\
4004 Returns info on amount of space in use:\n\
4005 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
4006 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
4007 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)\n\
4008 (USED-STRINGS . FREE-STRINGS))\n\
4009 Garbage collection happens automatically if you cons more than\n\
4010 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
4013 register struct gcpro
*tail
;
4014 register struct specbinding
*bind
;
4015 struct catchtag
*catch;
4016 struct handler
*handler
;
4017 register struct backtrace
*backlist
;
4018 char stack_top_variable
;
4021 Lisp_Object total
[8];
4022 int count
= BINDING_STACK_SIZE ();
4024 /* In case user calls debug_print during GC,
4025 don't let that cause a recursive GC. */
4026 consing_since_gc
= 0;
4028 /* Save what's currently displayed in the echo area. */
4029 message_p
= push_message ();
4030 record_unwind_protect (push_message_unwind
, Qnil
);
4032 /* Save a copy of the contents of the stack, for debugging. */
4033 #if MAX_SAVE_STACK > 0
4034 if (NILP (Vpurify_flag
))
4036 i
= &stack_top_variable
- stack_bottom
;
4038 if (i
< MAX_SAVE_STACK
)
4040 if (stack_copy
== 0)
4041 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4042 else if (stack_copy_size
< i
)
4043 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4046 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4047 bcopy (stack_bottom
, stack_copy
, i
);
4049 bcopy (&stack_top_variable
, stack_copy
, i
);
4053 #endif /* MAX_SAVE_STACK > 0 */
4055 if (garbage_collection_messages
)
4056 message1_nolog ("Garbage collecting...");
4060 shrink_regexp_cache ();
4062 /* Don't keep undo information around forever. */
4064 register struct buffer
*nextb
= all_buffers
;
4068 /* If a buffer's undo list is Qt, that means that undo is
4069 turned off in that buffer. Calling truncate_undo_list on
4070 Qt tends to return NULL, which effectively turns undo back on.
4071 So don't call truncate_undo_list if undo_list is Qt. */
4072 if (! EQ (nextb
->undo_list
, Qt
))
4074 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
4076 nextb
= nextb
->next
;
4082 /* clear_marks (); */
4084 /* Mark all the special slots that serve as the roots of accessibility.
4086 Usually the special slots to mark are contained in particular structures.
4087 Then we know no slot is marked twice because the structures don't overlap.
4088 In some cases, the structures point to the slots to be marked.
4089 For these, we use MARKBIT to avoid double marking of the slot. */
4091 for (i
= 0; i
< staticidx
; i
++)
4092 mark_object (staticvec
[i
]);
4094 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4095 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4098 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4099 for (i
= 0; i
< tail
->nvars
; i
++)
4100 if (!XMARKBIT (tail
->var
[i
]))
4102 /* Explicit casting prevents compiler warning about
4103 discarding the `volatile' qualifier. */
4104 mark_object ((Lisp_Object
*)&tail
->var
[i
]);
4105 XMARK (tail
->var
[i
]);
4110 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4112 mark_object (&bind
->symbol
);
4113 mark_object (&bind
->old_value
);
4115 for (catch = catchlist
; catch; catch = catch->next
)
4117 mark_object (&catch->tag
);
4118 mark_object (&catch->val
);
4120 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4122 mark_object (&handler
->handler
);
4123 mark_object (&handler
->var
);
4125 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
4127 if (!XMARKBIT (*backlist
->function
))
4129 mark_object (backlist
->function
);
4130 XMARK (*backlist
->function
);
4132 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
4135 i
= backlist
->nargs
- 1;
4137 if (!XMARKBIT (backlist
->args
[i
]))
4139 mark_object (&backlist
->args
[i
]);
4140 XMARK (backlist
->args
[i
]);
4145 /* Look thru every buffer's undo list
4146 for elements that update markers that were not marked,
4149 register struct buffer
*nextb
= all_buffers
;
4153 /* If a buffer's undo list is Qt, that means that undo is
4154 turned off in that buffer. Calling truncate_undo_list on
4155 Qt tends to return NULL, which effectively turns undo back on.
4156 So don't call truncate_undo_list if undo_list is Qt. */
4157 if (! EQ (nextb
->undo_list
, Qt
))
4159 Lisp_Object tail
, prev
;
4160 tail
= nextb
->undo_list
;
4162 while (CONSP (tail
))
4164 if (GC_CONSP (XCAR (tail
))
4165 && GC_MARKERP (XCAR (XCAR (tail
)))
4166 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
4169 nextb
->undo_list
= tail
= XCDR (tail
);
4171 tail
= XCDR (prev
) = XCDR (tail
);
4181 nextb
= nextb
->next
;
4185 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4191 /* Clear the mark bits that we set in certain root slots. */
4193 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
4194 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
4195 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4196 for (i
= 0; i
< tail
->nvars
; i
++)
4197 XUNMARK (tail
->var
[i
]);
4200 unmark_byte_stack ();
4201 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
4203 XUNMARK (*backlist
->function
);
4204 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
4207 i
= backlist
->nargs
- 1;
4209 XUNMARK (backlist
->args
[i
]);
4211 XUNMARK (buffer_defaults
.name
);
4212 XUNMARK (buffer_local_symbols
.name
);
4214 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4220 /* clear_marks (); */
4223 consing_since_gc
= 0;
4224 if (gc_cons_threshold
< 10000)
4225 gc_cons_threshold
= 10000;
4227 if (garbage_collection_messages
)
4229 if (message_p
|| minibuf_level
> 0)
4232 message1_nolog ("Garbage collecting...done");
4235 unbind_to (count
, Qnil
);
4237 total
[0] = Fcons (make_number (total_conses
),
4238 make_number (total_free_conses
));
4239 total
[1] = Fcons (make_number (total_symbols
),
4240 make_number (total_free_symbols
));
4241 total
[2] = Fcons (make_number (total_markers
),
4242 make_number (total_free_markers
));
4243 total
[3] = make_number (total_string_size
);
4244 total
[4] = make_number (total_vector_size
);
4245 total
[5] = Fcons (make_number (total_floats
),
4246 make_number (total_free_floats
));
4247 total
[6] = Fcons (make_number (total_intervals
),
4248 make_number (total_free_intervals
));
4249 total
[7] = Fcons (make_number (total_strings
),
4250 make_number (total_free_strings
));
4252 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4254 /* Compute average percentage of zombies. */
4257 for (i
= 0; i
< 7; ++i
)
4258 nlive
+= XFASTINT (XCAR (total
[i
]));
4260 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4261 max_live
= max (nlive
, max_live
);
4262 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4263 max_zombies
= max (nzombies
, max_zombies
);
4268 return Flist (sizeof total
/ sizeof *total
, total
);
4272 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4273 only interesting objects referenced from glyphs are strings. */
4276 mark_glyph_matrix (matrix
)
4277 struct glyph_matrix
*matrix
;
4279 struct glyph_row
*row
= matrix
->rows
;
4280 struct glyph_row
*end
= row
+ matrix
->nrows
;
4282 for (; row
< end
; ++row
)
4286 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
4288 struct glyph
*glyph
= row
->glyphs
[area
];
4289 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
4291 for (; glyph
< end_glyph
; ++glyph
)
4292 if (GC_STRINGP (glyph
->object
)
4293 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
4294 mark_object (&glyph
->object
);
4300 /* Mark Lisp faces in the face cache C. */
4304 struct face_cache
*c
;
4309 for (i
= 0; i
< c
->used
; ++i
)
4311 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
4315 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
4316 mark_object (&face
->lface
[j
]);
4323 #ifdef HAVE_WINDOW_SYSTEM
4325 /* Mark Lisp objects in image IMG. */
4331 mark_object (&img
->spec
);
4333 if (!NILP (img
->data
.lisp_val
))
4334 mark_object (&img
->data
.lisp_val
);
4338 /* Mark Lisp objects in image cache of frame F. It's done this way so
4339 that we don't have to include xterm.h here. */
4342 mark_image_cache (f
)
4345 forall_images_in_image_cache (f
, mark_image
);
4348 #endif /* HAVE_X_WINDOWS */
4352 /* Mark reference to a Lisp_Object.
4353 If the object referred to has not been seen yet, recursively mark
4354 all the references contained in it. */
4356 #define LAST_MARKED_SIZE 500
4357 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
4358 int last_marked_index
;
4361 mark_object (argptr
)
4362 Lisp_Object
*argptr
;
4364 Lisp_Object
*objptr
= argptr
;
4365 register Lisp_Object obj
;
4366 #ifdef GC_CHECK_MARKED_OBJECTS
4376 if (PURE_POINTER_P (XPNTR (obj
)))
4379 last_marked
[last_marked_index
++] = objptr
;
4380 if (last_marked_index
== LAST_MARKED_SIZE
)
4381 last_marked_index
= 0;
4383 /* Perform some sanity checks on the objects marked here. Abort if
4384 we encounter an object we know is bogus. This increases GC time
4385 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4386 #ifdef GC_CHECK_MARKED_OBJECTS
4388 po
= (void *) XPNTR (obj
);
4390 /* Check that the object pointed to by PO is known to be a Lisp
4391 structure allocated from the heap. */
4392 #define CHECK_ALLOCATED() \
4394 m = mem_find (po); \
4399 /* Check that the object pointed to by PO is live, using predicate
4401 #define CHECK_LIVE(LIVEP) \
4403 if (!LIVEP (m, po)) \
4407 /* Check both of the above conditions. */
4408 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4410 CHECK_ALLOCATED (); \
4411 CHECK_LIVE (LIVEP); \
4414 #else /* not GC_CHECK_MARKED_OBJECTS */
4416 #define CHECK_ALLOCATED() (void) 0
4417 #define CHECK_LIVE(LIVEP) (void) 0
4418 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4420 #endif /* not GC_CHECK_MARKED_OBJECTS */
4422 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4426 register struct Lisp_String
*ptr
= XSTRING (obj
);
4427 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4428 MARK_INTERVAL_TREE (ptr
->intervals
);
4430 #ifdef GC_CHECK_STRING_BYTES
4431 /* Check that the string size recorded in the string is the
4432 same as the one recorded in the sdata structure. */
4433 CHECK_STRING_BYTES (ptr
);
4434 #endif /* GC_CHECK_STRING_BYTES */
4438 case Lisp_Vectorlike
:
4439 #ifdef GC_CHECK_MARKED_OBJECTS
4441 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4442 && po
!= &buffer_defaults
4443 && po
!= &buffer_local_symbols
)
4445 #endif /* GC_CHECK_MARKED_OBJECTS */
4447 if (GC_BUFFERP (obj
))
4449 if (!XMARKBIT (XBUFFER (obj
)->name
))
4451 #ifdef GC_CHECK_MARKED_OBJECTS
4452 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4455 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4460 #endif /* GC_CHECK_MARKED_OBJECTS */
4464 else if (GC_SUBRP (obj
))
4466 else if (GC_COMPILEDP (obj
))
4467 /* We could treat this just like a vector, but it is better to
4468 save the COMPILED_CONSTANTS element for last and avoid
4471 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4472 register EMACS_INT size
= ptr
->size
;
4475 if (size
& ARRAY_MARK_FLAG
)
4476 break; /* Already marked */
4478 CHECK_LIVE (live_vector_p
);
4479 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4480 size
&= PSEUDOVECTOR_SIZE_MASK
;
4481 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4483 if (i
!= COMPILED_CONSTANTS
)
4484 mark_object (&ptr
->contents
[i
]);
4486 /* This cast should be unnecessary, but some Mips compiler complains
4487 (MIPS-ABI + SysVR4, DC/OSx, etc). */
4488 objptr
= (Lisp_Object
*) &ptr
->contents
[COMPILED_CONSTANTS
];
4491 else if (GC_FRAMEP (obj
))
4493 register struct frame
*ptr
= XFRAME (obj
);
4494 register EMACS_INT size
= ptr
->size
;
4496 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4497 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4499 CHECK_LIVE (live_vector_p
);
4500 mark_object (&ptr
->name
);
4501 mark_object (&ptr
->icon_name
);
4502 mark_object (&ptr
->title
);
4503 mark_object (&ptr
->focus_frame
);
4504 mark_object (&ptr
->selected_window
);
4505 mark_object (&ptr
->minibuffer_window
);
4506 mark_object (&ptr
->param_alist
);
4507 mark_object (&ptr
->scroll_bars
);
4508 mark_object (&ptr
->condemned_scroll_bars
);
4509 mark_object (&ptr
->menu_bar_items
);
4510 mark_object (&ptr
->face_alist
);
4511 mark_object (&ptr
->menu_bar_vector
);
4512 mark_object (&ptr
->buffer_predicate
);
4513 mark_object (&ptr
->buffer_list
);
4514 mark_object (&ptr
->menu_bar_window
);
4515 mark_object (&ptr
->tool_bar_window
);
4516 mark_face_cache (ptr
->face_cache
);
4517 #ifdef HAVE_WINDOW_SYSTEM
4518 mark_image_cache (ptr
);
4519 mark_object (&ptr
->tool_bar_items
);
4520 mark_object (&ptr
->desired_tool_bar_string
);
4521 mark_object (&ptr
->current_tool_bar_string
);
4522 #endif /* HAVE_WINDOW_SYSTEM */
4524 else if (GC_BOOL_VECTOR_P (obj
))
4526 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4528 if (ptr
->size
& ARRAY_MARK_FLAG
)
4529 break; /* Already marked */
4530 CHECK_LIVE (live_vector_p
);
4531 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4533 else if (GC_WINDOWP (obj
))
4535 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4536 struct window
*w
= XWINDOW (obj
);
4537 register EMACS_INT size
= ptr
->size
;
4540 /* Stop if already marked. */
4541 if (size
& ARRAY_MARK_FLAG
)
4545 CHECK_LIVE (live_vector_p
);
4546 ptr
->size
|= ARRAY_MARK_FLAG
;
4548 /* There is no Lisp data above The member CURRENT_MATRIX in
4549 struct WINDOW. Stop marking when that slot is reached. */
4551 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4553 mark_object (&ptr
->contents
[i
]);
4555 /* Mark glyphs for leaf windows. Marking window matrices is
4556 sufficient because frame matrices use the same glyph
4558 if (NILP (w
->hchild
)
4560 && w
->current_matrix
)
4562 mark_glyph_matrix (w
->current_matrix
);
4563 mark_glyph_matrix (w
->desired_matrix
);
4566 else if (GC_HASH_TABLE_P (obj
))
4568 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4569 EMACS_INT size
= h
->size
;
4571 /* Stop if already marked. */
4572 if (size
& ARRAY_MARK_FLAG
)
4576 CHECK_LIVE (live_vector_p
);
4577 h
->size
|= ARRAY_MARK_FLAG
;
4579 /* Mark contents. */
4580 mark_object (&h
->test
);
4581 mark_object (&h
->weak
);
4582 mark_object (&h
->rehash_size
);
4583 mark_object (&h
->rehash_threshold
);
4584 mark_object (&h
->hash
);
4585 mark_object (&h
->next
);
4586 mark_object (&h
->index
);
4587 mark_object (&h
->user_hash_function
);
4588 mark_object (&h
->user_cmp_function
);
4590 /* If hash table is not weak, mark all keys and values.
4591 For weak tables, mark only the vector. */
4592 if (GC_NILP (h
->weak
))
4593 mark_object (&h
->key_and_value
);
4595 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
4600 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4601 register EMACS_INT size
= ptr
->size
;
4604 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4605 CHECK_LIVE (live_vector_p
);
4606 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4607 if (size
& PSEUDOVECTOR_FLAG
)
4608 size
&= PSEUDOVECTOR_SIZE_MASK
;
4610 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4611 mark_object (&ptr
->contents
[i
]);
4617 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4618 struct Lisp_Symbol
*ptrx
;
4620 if (XMARKBIT (ptr
->plist
)) break;
4621 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4623 mark_object ((Lisp_Object
*) &ptr
->value
);
4624 mark_object (&ptr
->function
);
4625 mark_object (&ptr
->plist
);
4627 if (!PURE_POINTER_P (ptr
->name
))
4628 MARK_STRING (ptr
->name
);
4629 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
4631 /* Note that we do not mark the obarray of the symbol.
4632 It is safe not to do so because nothing accesses that
4633 slot except to check whether it is nil. */
4637 /* For the benefit of the last_marked log. */
4638 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4639 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4640 XSETSYMBOL (obj
, ptrx
);
4641 /* We can't goto loop here because *objptr doesn't contain an
4642 actual Lisp_Object with valid datatype field. */
4649 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4650 switch (XMISCTYPE (obj
))
4652 case Lisp_Misc_Marker
:
4653 XMARK (XMARKER (obj
)->chain
);
4654 /* DO NOT mark thru the marker's chain.
4655 The buffer's markers chain does not preserve markers from gc;
4656 instead, markers are removed from the chain when freed by gc. */
4659 case Lisp_Misc_Buffer_Local_Value
:
4660 case Lisp_Misc_Some_Buffer_Local_Value
:
4662 register struct Lisp_Buffer_Local_Value
*ptr
4663 = XBUFFER_LOCAL_VALUE (obj
);
4664 if (XMARKBIT (ptr
->realvalue
)) break;
4665 XMARK (ptr
->realvalue
);
4666 /* If the cdr is nil, avoid recursion for the car. */
4667 if (EQ (ptr
->cdr
, Qnil
))
4669 objptr
= &ptr
->realvalue
;
4672 mark_object (&ptr
->realvalue
);
4673 mark_object (&ptr
->buffer
);
4674 mark_object (&ptr
->frame
);
4679 case Lisp_Misc_Intfwd
:
4680 case Lisp_Misc_Boolfwd
:
4681 case Lisp_Misc_Objfwd
:
4682 case Lisp_Misc_Buffer_Objfwd
:
4683 case Lisp_Misc_Kboard_Objfwd
:
4684 /* Don't bother with Lisp_Buffer_Objfwd,
4685 since all markable slots in current buffer marked anyway. */
4686 /* Don't need to do Lisp_Objfwd, since the places they point
4687 are protected with staticpro. */
4690 case Lisp_Misc_Overlay
:
4692 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4693 if (!XMARKBIT (ptr
->plist
))
4696 mark_object (&ptr
->start
);
4697 mark_object (&ptr
->end
);
4698 objptr
= &ptr
->plist
;
4711 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4712 if (XMARKBIT (ptr
->car
)) break;
4713 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
4715 /* If the cdr is nil, avoid recursion for the car. */
4716 if (EQ (ptr
->cdr
, Qnil
))
4721 mark_object (&ptr
->car
);
4727 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
4728 XMARK (XFLOAT (obj
)->type
);
4739 #undef CHECK_ALLOCATED
4740 #undef CHECK_ALLOCATED_AND_LIVE
4743 /* Mark the pointers in a buffer structure. */
4749 register struct buffer
*buffer
= XBUFFER (buf
);
4750 register Lisp_Object
*ptr
;
4751 Lisp_Object base_buffer
;
4753 /* This is the buffer's markbit */
4754 mark_object (&buffer
->name
);
4755 XMARK (buffer
->name
);
4757 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4759 if (CONSP (buffer
->undo_list
))
4762 tail
= buffer
->undo_list
;
4764 while (CONSP (tail
))
4766 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4768 if (XMARKBIT (ptr
->car
))
4771 if (GC_CONSP (ptr
->car
)
4772 && ! XMARKBIT (XCAR (ptr
->car
))
4773 && GC_MARKERP (XCAR (ptr
->car
)))
4775 XMARK (XCAR (ptr
->car
));
4776 mark_object (&XCDR (ptr
->car
));
4779 mark_object (&ptr
->car
);
4781 if (CONSP (ptr
->cdr
))
4787 mark_object (&XCDR (tail
));
4790 mark_object (&buffer
->undo_list
);
4792 for (ptr
= &buffer
->name
+ 1;
4793 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4797 /* If this is an indirect buffer, mark its base buffer. */
4798 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4800 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4801 mark_buffer (base_buffer
);
4806 /* Mark the pointers in the kboard objects. */
4813 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4815 if (kb
->kbd_macro_buffer
)
4816 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4818 mark_object (&kb
->Voverriding_terminal_local_map
);
4819 mark_object (&kb
->Vlast_command
);
4820 mark_object (&kb
->Vreal_last_command
);
4821 mark_object (&kb
->Vprefix_arg
);
4822 mark_object (&kb
->Vlast_prefix_arg
);
4823 mark_object (&kb
->kbd_queue
);
4824 mark_object (&kb
->defining_kbd_macro
);
4825 mark_object (&kb
->Vlast_kbd_macro
);
4826 mark_object (&kb
->Vsystem_key_alist
);
4827 mark_object (&kb
->system_key_syms
);
4828 mark_object (&kb
->Vdefault_minibuffer_frame
);
4833 /* Value is non-zero if OBJ will survive the current GC because it's
4834 either marked or does not need to be marked to survive. */
4842 switch (XGCTYPE (obj
))
4849 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4853 switch (XMISCTYPE (obj
))
4855 case Lisp_Misc_Marker
:
4856 survives_p
= XMARKBIT (obj
);
4859 case Lisp_Misc_Buffer_Local_Value
:
4860 case Lisp_Misc_Some_Buffer_Local_Value
:
4861 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4864 case Lisp_Misc_Intfwd
:
4865 case Lisp_Misc_Boolfwd
:
4866 case Lisp_Misc_Objfwd
:
4867 case Lisp_Misc_Buffer_Objfwd
:
4868 case Lisp_Misc_Kboard_Objfwd
:
4872 case Lisp_Misc_Overlay
:
4873 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4883 struct Lisp_String
*s
= XSTRING (obj
);
4884 survives_p
= STRING_MARKED_P (s
);
4888 case Lisp_Vectorlike
:
4889 if (GC_BUFFERP (obj
))
4890 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4891 else if (GC_SUBRP (obj
))
4894 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4898 survives_p
= XMARKBIT (XCAR (obj
));
4902 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4909 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4914 /* Sweep: find all structures not marked, and free them. */
4919 /* Remove or mark entries in weak hash tables.
4920 This must be done before any object is unmarked. */
4921 sweep_weak_hash_tables ();
4924 #ifdef GC_CHECK_STRING_BYTES
4925 if (!noninteractive
)
4926 check_string_bytes (1);
4929 /* Put all unmarked conses on free list */
4931 register struct cons_block
*cblk
;
4932 struct cons_block
**cprev
= &cons_block
;
4933 register int lim
= cons_block_index
;
4934 register int num_free
= 0, num_used
= 0;
4938 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4942 for (i
= 0; i
< lim
; i
++)
4943 if (!XMARKBIT (cblk
->conses
[i
].car
))
4946 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4947 cons_free_list
= &cblk
->conses
[i
];
4949 cons_free_list
->car
= Vdead
;
4955 XUNMARK (cblk
->conses
[i
].car
);
4957 lim
= CONS_BLOCK_SIZE
;
4958 /* If this block contains only free conses and we have already
4959 seen more than two blocks worth of free conses then deallocate
4961 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4963 *cprev
= cblk
->next
;
4964 /* Unhook from the free list. */
4965 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4971 num_free
+= this_free
;
4972 cprev
= &cblk
->next
;
4975 total_conses
= num_used
;
4976 total_free_conses
= num_free
;
4979 /* Put all unmarked floats on free list */
4981 register struct float_block
*fblk
;
4982 struct float_block
**fprev
= &float_block
;
4983 register int lim
= float_block_index
;
4984 register int num_free
= 0, num_used
= 0;
4986 float_free_list
= 0;
4988 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4992 for (i
= 0; i
< lim
; i
++)
4993 if (!XMARKBIT (fblk
->floats
[i
].type
))
4996 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4997 float_free_list
= &fblk
->floats
[i
];
4999 float_free_list
->type
= Vdead
;
5005 XUNMARK (fblk
->floats
[i
].type
);
5007 lim
= FLOAT_BLOCK_SIZE
;
5008 /* If this block contains only free floats and we have already
5009 seen more than two blocks worth of free floats then deallocate
5011 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5013 *fprev
= fblk
->next
;
5014 /* Unhook from the free list. */
5015 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5021 num_free
+= this_free
;
5022 fprev
= &fblk
->next
;
5025 total_floats
= num_used
;
5026 total_free_floats
= num_free
;
5029 /* Put all unmarked intervals on free list */
5031 register struct interval_block
*iblk
;
5032 struct interval_block
**iprev
= &interval_block
;
5033 register int lim
= interval_block_index
;
5034 register int num_free
= 0, num_used
= 0;
5036 interval_free_list
= 0;
5038 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5043 for (i
= 0; i
< lim
; i
++)
5045 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
5047 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5048 interval_free_list
= &iblk
->intervals
[i
];
5054 XUNMARK (iblk
->intervals
[i
].plist
);
5057 lim
= INTERVAL_BLOCK_SIZE
;
5058 /* If this block contains only free intervals and we have already
5059 seen more than two blocks worth of free intervals then
5060 deallocate this block. */
5061 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5063 *iprev
= iblk
->next
;
5064 /* Unhook from the free list. */
5065 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5067 n_interval_blocks
--;
5071 num_free
+= this_free
;
5072 iprev
= &iblk
->next
;
5075 total_intervals
= num_used
;
5076 total_free_intervals
= num_free
;
5079 /* Put all unmarked symbols on free list */
5081 register struct symbol_block
*sblk
;
5082 struct symbol_block
**sprev
= &symbol_block
;
5083 register int lim
= symbol_block_index
;
5084 register int num_free
= 0, num_used
= 0;
5086 symbol_free_list
= NULL
;
5088 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5091 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5092 struct Lisp_Symbol
*end
= sym
+ lim
;
5094 for (; sym
< end
; ++sym
)
5096 /* Check if the symbol was created during loadup. In such a case
5097 it might be pointed to by pure bytecode which we don't trace,
5098 so we conservatively assume that it is live. */
5099 int pure_p
= PURE_POINTER_P (sym
->name
);
5101 if (!XMARKBIT (sym
->plist
) && !pure_p
)
5103 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5104 symbol_free_list
= sym
;
5106 symbol_free_list
->function
= Vdead
;
5114 UNMARK_STRING (sym
->name
);
5115 XUNMARK (sym
->plist
);
5119 lim
= SYMBOL_BLOCK_SIZE
;
5120 /* If this block contains only free symbols and we have already
5121 seen more than two blocks worth of free symbols then deallocate
5123 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5125 *sprev
= sblk
->next
;
5126 /* Unhook from the free list. */
5127 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5133 num_free
+= this_free
;
5134 sprev
= &sblk
->next
;
5137 total_symbols
= num_used
;
5138 total_free_symbols
= num_free
;
5141 /* Put all unmarked misc's on free list.
5142 For a marker, first unchain it from the buffer it points into. */
5144 register struct marker_block
*mblk
;
5145 struct marker_block
**mprev
= &marker_block
;
5146 register int lim
= marker_block_index
;
5147 register int num_free
= 0, num_used
= 0;
5149 marker_free_list
= 0;
5151 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5155 EMACS_INT already_free
= -1;
5157 for (i
= 0; i
< lim
; i
++)
5159 Lisp_Object
*markword
;
5160 switch (mblk
->markers
[i
].u_marker
.type
)
5162 case Lisp_Misc_Marker
:
5163 markword
= &mblk
->markers
[i
].u_marker
.chain
;
5165 case Lisp_Misc_Buffer_Local_Value
:
5166 case Lisp_Misc_Some_Buffer_Local_Value
:
5167 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
5169 case Lisp_Misc_Overlay
:
5170 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
5172 case Lisp_Misc_Free
:
5173 /* If the object was already free, keep it
5174 on the free list. */
5175 markword
= (Lisp_Object
*) &already_free
;
5181 if (markword
&& !XMARKBIT (*markword
))
5184 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5186 /* tem1 avoids Sun compiler bug */
5187 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
5188 XSETMARKER (tem
, tem1
);
5189 unchain_marker (tem
);
5191 /* Set the type of the freed object to Lisp_Misc_Free.
5192 We could leave the type alone, since nobody checks it,
5193 but this might catch bugs faster. */
5194 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5195 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5196 marker_free_list
= &mblk
->markers
[i
];
5203 XUNMARK (*markword
);
5206 lim
= MARKER_BLOCK_SIZE
;
5207 /* If this block contains only free markers and we have already
5208 seen more than two blocks worth of free markers then deallocate
5210 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5212 *mprev
= mblk
->next
;
5213 /* Unhook from the free list. */
5214 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5220 num_free
+= this_free
;
5221 mprev
= &mblk
->next
;
5225 total_markers
= num_used
;
5226 total_free_markers
= num_free
;
5229 /* Free all unmarked buffers */
5231 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5234 if (!XMARKBIT (buffer
->name
))
5237 prev
->next
= buffer
->next
;
5239 all_buffers
= buffer
->next
;
5240 next
= buffer
->next
;
5246 XUNMARK (buffer
->name
);
5247 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5248 prev
= buffer
, buffer
= buffer
->next
;
5252 /* Free all unmarked vectors */
5254 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5255 total_vector_size
= 0;
5258 if (!(vector
->size
& ARRAY_MARK_FLAG
))
5261 prev
->next
= vector
->next
;
5263 all_vectors
= vector
->next
;
5264 next
= vector
->next
;
5272 vector
->size
&= ~ARRAY_MARK_FLAG
;
5273 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5274 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5276 total_vector_size
+= vector
->size
;
5277 prev
= vector
, vector
= vector
->next
;
5281 #ifdef GC_CHECK_STRING_BYTES
5282 if (!noninteractive
)
5283 check_string_bytes (1);
5290 /* Debugging aids. */
5292 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5293 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
5294 This may be helpful in debugging Emacs's memory usage.\n\
5295 We divide the value by 1024 to make sure it fits in a Lisp integer.")
5300 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5305 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5306 "Return a list of counters that measure how much consing there has been.\n\
5307 Each of these counters increments for a certain kind of object.\n\
5308 The counters wrap around from the largest positive integer to zero.\n\
5309 Garbage collection does not decrease them.\n\
5310 The elements of the value are as follows:\n\
5311 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
5312 All are in units of 1 = one object consed\n\
5313 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
5315 MISCS include overlays, markers, and some internal types.\n\
5316 Frames, windows, buffers, and subprocesses count as vectors\n\
5317 (but the contents of a buffer's text do not count here).")
5320 Lisp_Object consed
[8];
5323 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5325 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5327 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5329 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5331 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5333 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5335 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5337 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5339 return Flist (8, consed
);
5342 int suppress_checking
;
5344 die (msg
, file
, line
)
5349 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5354 /* Initialization */
5359 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5360 pure_bytes_used
= 0;
5361 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5363 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5366 pure_size
= PURESIZE
;
5369 ignore_warnings
= 1;
5370 #ifdef DOUG_LEA_MALLOC
5371 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5372 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5373 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5383 malloc_hysteresis
= 32;
5385 malloc_hysteresis
= 0;
5388 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5390 ignore_warnings
= 0;
5392 byte_stack_list
= 0;
5394 consing_since_gc
= 0;
5395 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5396 #ifdef VIRT_ADDR_VARIES
5397 malloc_sbrk_unused
= 1<<22; /* A large number */
5398 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5399 #endif /* VIRT_ADDR_VARIES */
5406 byte_stack_list
= 0;
5408 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5409 setjmp_tested_p
= longjmps_done
= 0;
5417 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5418 "*Number of bytes of consing between garbage collections.\n\
5419 Garbage collection can happen automatically once this many bytes have been\n\
5420 allocated since the last garbage collection. All data types count.\n\n\
5421 Garbage collection happens automatically only when `eval' is called.\n\n\
5422 By binding this temporarily to a large number, you can effectively\n\
5423 prevent garbage collection during a part of the program.");
5425 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5426 "Number of bytes of sharable Lisp data allocated so far.");
5428 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5429 "Number of cons cells that have been consed so far.");
5431 DEFVAR_INT ("floats-consed", &floats_consed
,
5432 "Number of floats that have been consed so far.");
5434 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5435 "Number of vector cells that have been consed so far.");
5437 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5438 "Number of symbols that have been consed so far.");
5440 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5441 "Number of string characters that have been consed so far.");
5443 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5444 "Number of miscellaneous objects that have been consed so far.");
5446 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5447 "Number of intervals that have been consed so far.");
5449 DEFVAR_INT ("strings-consed", &strings_consed
,
5450 "Number of strings that have been consed so far.");
5452 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5453 "Non-nil means loading Lisp code in order to dump an executable.\n\
5454 This means that certain objects should be allocated in shared (pure) space.");
5456 DEFVAR_INT ("undo-limit", &undo_limit
,
5457 "Keep no more undo information once it exceeds this size.\n\
5458 This limit is applied when garbage collection happens.\n\
5459 The size is counted as the number of bytes occupied,\n\
5460 which includes both saved text and other data.");
5463 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5464 "Don't keep more than this much size of undo information.\n\
5465 A command which pushes past this size is itself forgotten.\n\
5466 This limit is applied when garbage collection happens.\n\
5467 The size is counted as the number of bytes occupied,\n\
5468 which includes both saved text and other data.");
5469 undo_strong_limit
= 30000;
5471 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5472 "Non-nil means display messages at start and end of garbage collection.");
5473 garbage_collection_messages
= 0;
5475 /* We build this in advance because if we wait until we need it, we might
5476 not be able to allocate the memory to hold it. */
5478 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
5479 staticpro (&memory_signal_data
);
5481 staticpro (&Qgc_cons_threshold
);
5482 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5484 staticpro (&Qchar_table_extra_slots
);
5485 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5490 defsubr (&Smake_byte_code
);
5491 defsubr (&Smake_list
);
5492 defsubr (&Smake_vector
);
5493 defsubr (&Smake_char_table
);
5494 defsubr (&Smake_string
);
5495 defsubr (&Smake_bool_vector
);
5496 defsubr (&Smake_symbol
);
5497 defsubr (&Smake_marker
);
5498 defsubr (&Spurecopy
);
5499 defsubr (&Sgarbage_collect
);
5500 defsubr (&Smemory_limit
);
5501 defsubr (&Smemory_use_counts
);
5503 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5504 defsubr (&Sgc_status
);