1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
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 /* This file is part of the core Lisp implementation, and thus must
30 deal with the real data structures. If the Lisp implementation is
31 replaced, this file likely will not be used. */
33 #undef HIDE_LISP_IMPLEMENTATION
35 #include "intervals.h"
40 #include "blockinput.h"
43 #include "syssignal.h"
48 #ifdef DOUG_LEA_MALLOC
51 #define __malloc_size_t int
53 /* Specify maximum number of areas to mmap. It would be nice to use a
54 value that explicitly means "no limit". */
56 #define MMAP_MAX_AREAS 100000000
58 #else /* not DOUG_LEA_MALLOC */
60 /* The following come from gmalloc.c. */
62 #if defined (STDC_HEADERS)
64 #define __malloc_size_t size_t
66 #define __malloc_size_t unsigned int
68 extern __malloc_size_t _bytes_used
;
69 extern int __malloc_extra_blocks
;
71 #endif /* not DOUG_LEA_MALLOC */
73 #define max(A,B) ((A) > (B) ? (A) : (B))
74 #define min(A,B) ((A) < (B) ? (A) : (B))
76 /* Macro to verify that storage intended for Lisp objects is not
77 out of range to fit in the space for a pointer.
78 ADDRESS is the start of the block, and SIZE
79 is the amount of space within which objects can start. */
81 #define VALIDATE_LISP_STORAGE(address, size) \
85 XSETCONS (val, (char *) address + size); \
86 if ((char *) XCONS (val) != (char *) address + size) \
93 /* Value of _bytes_used, when spare_memory was freed. */
95 static __malloc_size_t bytes_used_when_full
;
97 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
98 to a struct Lisp_String. */
100 #define MARK_STRING(S) XMARK ((S)->size)
101 #define UNMARK_STRING(S) XUNMARK ((S)->size)
102 #define STRING_MARKED_P(S) XMARKBIT ((S)->size)
104 /* Value is the number of bytes/chars of S, a pointer to a struct
105 Lisp_String. This must be used instead of STRING_BYTES (S) or
106 S->size during GC, because S->size contains the mark bit for
109 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
110 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
112 /* Number of bytes of consing done since the last gc. */
114 int consing_since_gc
;
116 /* Count the amount of consing of various sorts of space. */
118 int cons_cells_consed
;
120 int vector_cells_consed
;
122 int string_chars_consed
;
123 int misc_objects_consed
;
124 int intervals_consed
;
127 /* Number of bytes of consing since GC before another GC should be done. */
129 int gc_cons_threshold
;
131 /* Nonzero during GC. */
135 /* Nonzero means display messages at beginning and end of GC. */
137 int garbage_collection_messages
;
139 #ifndef VIRT_ADDR_VARIES
141 #endif /* VIRT_ADDR_VARIES */
142 int malloc_sbrk_used
;
144 #ifndef VIRT_ADDR_VARIES
146 #endif /* VIRT_ADDR_VARIES */
147 int malloc_sbrk_unused
;
149 /* Two limits controlling how much undo information to keep. */
152 int undo_strong_limit
;
154 /* Number of live and free conses etc. */
156 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
157 static int total_free_conses
, total_free_markers
, total_free_symbols
;
158 static int total_free_floats
, total_floats
;
160 /* Points to memory space allocated as "spare", to be freed if we run
163 static char *spare_memory
;
165 /* Amount of spare memory to keep in reserve. */
167 #define SPARE_MEMORY (1 << 14)
169 /* Number of extra blocks malloc should get when it needs more core. */
171 static int malloc_hysteresis
;
173 /* Non-nil means defun should do purecopy on the function definition. */
175 Lisp_Object Vpurify_flag
;
179 /* Force it into data space! */
181 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,};
182 #define PUREBEG (char *) pure
184 #else /* not HAVE_SHM */
186 #define pure PURE_SEG_BITS /* Use shared memory segment */
187 #define PUREBEG (char *)PURE_SEG_BITS
189 /* This variable is used only by the XPNTR macro when HAVE_SHM is
190 defined. If we used the PURESIZE macro directly there, that would
191 make most of Emacs dependent on puresize.h, which we don't want -
192 you should be able to change that without too much recompilation.
193 So map_in_data initializes pure_size, and the dependencies work
198 #endif /* not HAVE_SHM */
200 /* Value is non-zero if P points into pure space. */
202 #define PURE_POINTER_P(P) \
203 (((PNTR_COMPARISON_TYPE) (P) \
204 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
205 && ((PNTR_COMPARISON_TYPE) (P) \
206 >= (PNTR_COMPARISON_TYPE) pure))
208 /* Index in pure at which next pure object will be allocated.. */
212 /* If nonzero, this is a warning delivered by malloc and not yet
215 char *pending_malloc_warning
;
217 /* Pre-computed signal argument for use when memory is exhausted. */
219 Lisp_Object memory_signal_data
;
221 /* Maximum amount of C stack to save when a GC happens. */
223 #ifndef MAX_SAVE_STACK
224 #define MAX_SAVE_STACK 16000
227 /* Buffer in which we save a copy of the C stack at each GC. */
232 /* Non-zero means ignore malloc warnings. Set during initialization.
233 Currently not used. */
237 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
239 static void mark_buffer
P_ ((Lisp_Object
));
240 static void mark_kboards
P_ ((void));
241 static void gc_sweep
P_ ((void));
242 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
243 static void mark_face_cache
P_ ((struct face_cache
*));
245 #ifdef HAVE_WINDOW_SYSTEM
246 static void mark_image
P_ ((struct image
*));
247 static void mark_image_cache
P_ ((struct frame
*));
248 #endif /* HAVE_WINDOW_SYSTEM */
250 static struct Lisp_String
*allocate_string
P_ ((void));
251 static void compact_small_strings
P_ ((void));
252 static void free_large_strings
P_ ((void));
253 static void sweep_strings
P_ ((void));
255 extern int message_enable_multibyte
;
257 /* When scanning the C stack for live Lisp objects, Emacs keeps track
258 of what memory allocated via lisp_malloc is intended for what
259 purpose. This enumeration specifies the type of memory. */
275 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
276 #include <stdio.h> /* For fprintf. */
279 /* A unique object in pure space used to make some Lisp objects
280 on free lists recognizable in O(1). */
285 static void *lisp_malloc
P_ ((int, enum mem_type
));
286 static void mark_stack
P_ ((void));
287 static void init_stack
P_ ((Lisp_Object
*));
288 static int live_vector_p
P_ ((struct mem_node
*, void *));
289 static int live_buffer_p
P_ ((struct mem_node
*, void *));
290 static int live_string_p
P_ ((struct mem_node
*, void *));
291 static int live_cons_p
P_ ((struct mem_node
*, void *));
292 static int live_symbol_p
P_ ((struct mem_node
*, void *));
293 static int live_float_p
P_ ((struct mem_node
*, void *));
294 static int live_misc_p
P_ ((struct mem_node
*, void *));
295 static void mark_maybe_object
P_ ((Lisp_Object
));
296 static void mark_memory
P_ ((void *, void *));
297 static void mem_init
P_ ((void));
298 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
299 static void mem_insert_fixup
P_ ((struct mem_node
*));
300 static void mem_rotate_left
P_ ((struct mem_node
*));
301 static void mem_rotate_right
P_ ((struct mem_node
*));
302 static void mem_delete
P_ ((struct mem_node
*));
303 static void mem_delete_fixup
P_ ((struct mem_node
*));
304 static INLINE
struct mem_node
*mem_find
P_ ((void *));
306 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
307 static void check_gcpros
P_ ((void));
310 #endif /* GC_MARK_STACK != 0 */
313 /************************************************************************
315 ************************************************************************/
317 /* Write STR to Vstandard_output plus some advice on how to free some
318 memory. Called when memory gets low. */
321 malloc_warning_1 (str
)
324 Fprinc (str
, Vstandard_output
);
325 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
326 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
327 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
332 /* Function malloc calls this if it finds we are near exhausting
339 pending_malloc_warning
= str
;
343 /* Display a malloc warning in buffer *Danger*. */
346 display_malloc_warning ()
348 register Lisp_Object val
;
350 val
= build_string (pending_malloc_warning
);
351 pending_malloc_warning
= 0;
352 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
356 #ifdef DOUG_LEA_MALLOC
357 # define BYTES_USED (mallinfo ().arena)
359 # define BYTES_USED _bytes_used
363 /* Called if malloc returns zero. */
368 #ifndef SYSTEM_MALLOC
369 bytes_used_when_full
= BYTES_USED
;
372 /* The first time we get here, free the spare memory. */
379 /* This used to call error, but if we've run out of memory, we could
380 get infinite recursion trying to build the string. */
382 Fsignal (Qnil
, memory_signal_data
);
386 /* Called if we can't allocate relocatable space for a buffer. */
389 buffer_memory_full ()
391 /* If buffers use the relocating allocator, no need to free
392 spare_memory, because we may have plenty of malloc space left
393 that we could get, and if we don't, the malloc that fails will
394 itself cause spare_memory to be freed. If buffers don't use the
395 relocating allocator, treat this like any other failing
402 /* This used to call error, but if we've run out of memory, we could
403 get infinite recursion trying to build the string. */
405 Fsignal (Qerror
, memory_signal_data
);
409 /* Like malloc but check for no memory and block interrupt input.. */
418 val
= (long *) malloc (size
);
427 /* Like realloc but check for no memory and block interrupt input.. */
430 xrealloc (block
, size
)
437 /* We must call malloc explicitly when BLOCK is 0, since some
438 reallocs don't do this. */
440 val
= (long *) malloc (size
);
442 val
= (long *) realloc (block
, size
);
445 if (!val
&& size
) memory_full ();
450 /* Like free but block interrupt input.. */
462 /* Like strdup, but uses xmalloc. */
468 int len
= strlen (s
) + 1;
469 char *p
= (char *) xmalloc (len
);
475 /* Like malloc but used for allocating Lisp data. NBYTES is the
476 number of bytes to allocate, TYPE describes the intended use of the
477 allcated memory block (for strings, for conses, ...). */
480 lisp_malloc (nbytes
, type
)
487 val
= (void *) malloc (nbytes
);
490 if (val
&& type
!= MEM_TYPE_NON_LISP
)
491 mem_insert (val
, (char *) val
+ nbytes
, type
);
501 /* Return a new buffer structure allocated from the heap with
502 a call to lisp_malloc. */
507 return (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
512 /* Free BLOCK. This must be called to free memory allocated with a
513 call to lisp_malloc. */
522 mem_delete (mem_find (block
));
528 /* Arranging to disable input signals while we're in malloc.
530 This only works with GNU malloc. To help out systems which can't
531 use GNU malloc, all the calls to malloc, realloc, and free
532 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
533 pairs; unfortunately, we have no idea what C library functions
534 might call malloc, so we can't really protect them unless you're
535 using GNU malloc. Fortunately, most of the major operating can use
538 #ifndef SYSTEM_MALLOC
540 extern void * (*__malloc_hook
) ();
541 static void * (*old_malloc_hook
) ();
542 extern void * (*__realloc_hook
) ();
543 static void * (*old_realloc_hook
) ();
544 extern void (*__free_hook
) ();
545 static void (*old_free_hook
) ();
547 /* This function is used as the hook for free to call. */
550 emacs_blocked_free (ptr
)
554 __free_hook
= old_free_hook
;
556 /* If we released our reserve (due to running out of memory),
557 and we have a fair amount free once again,
558 try to set aside another reserve in case we run out once more. */
559 if (spare_memory
== 0
560 /* Verify there is enough space that even with the malloc
561 hysteresis this call won't run out again.
562 The code here is correct as long as SPARE_MEMORY
563 is substantially larger than the block size malloc uses. */
564 && (bytes_used_when_full
565 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
566 spare_memory
= (char *) malloc (SPARE_MEMORY
);
568 __free_hook
= emacs_blocked_free
;
573 /* If we released our reserve (due to running out of memory),
574 and we have a fair amount free once again,
575 try to set aside another reserve in case we run out once more.
577 This is called when a relocatable block is freed in ralloc.c. */
580 refill_memory_reserve ()
582 if (spare_memory
== 0)
583 spare_memory
= (char *) malloc (SPARE_MEMORY
);
587 /* This function is the malloc hook that Emacs uses. */
590 emacs_blocked_malloc (size
)
596 __malloc_hook
= old_malloc_hook
;
597 #ifdef DOUG_LEA_MALLOC
598 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
600 __malloc_extra_blocks
= malloc_hysteresis
;
602 value
= (void *) malloc (size
);
603 __malloc_hook
= emacs_blocked_malloc
;
610 /* This function is the realloc hook that Emacs uses. */
613 emacs_blocked_realloc (ptr
, size
)
620 __realloc_hook
= old_realloc_hook
;
621 value
= (void *) realloc (ptr
, size
);
622 __realloc_hook
= emacs_blocked_realloc
;
629 /* Called from main to set up malloc to use our hooks. */
632 uninterrupt_malloc ()
634 if (__free_hook
!= emacs_blocked_free
)
635 old_free_hook
= __free_hook
;
636 __free_hook
= emacs_blocked_free
;
638 if (__malloc_hook
!= emacs_blocked_malloc
)
639 old_malloc_hook
= __malloc_hook
;
640 __malloc_hook
= emacs_blocked_malloc
;
642 if (__realloc_hook
!= emacs_blocked_realloc
)
643 old_realloc_hook
= __realloc_hook
;
644 __realloc_hook
= emacs_blocked_realloc
;
647 #endif /* not SYSTEM_MALLOC */
651 /***********************************************************************
653 ***********************************************************************/
655 /* Number of intervals allocated in an interval_block structure.
656 The 1020 is 1024 minus malloc overhead. */
658 #define INTERVAL_BLOCK_SIZE \
659 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
661 /* Intervals are allocated in chunks in form of an interval_block
664 struct interval_block
666 struct interval_block
*next
;
667 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
670 /* Current interval block. Its `next' pointer points to older
673 struct interval_block
*interval_block
;
675 /* Index in interval_block above of the next unused interval
678 static int interval_block_index
;
680 /* Number of free and live intervals. */
682 static int total_free_intervals
, total_intervals
;
684 /* List of free intervals. */
686 INTERVAL interval_free_list
;
688 /* Total number of interval blocks now in use. */
690 int n_interval_blocks
;
693 /* Initialize interval allocation. */
699 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
701 interval_block
->next
= 0;
702 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
703 interval_block_index
= 0;
704 interval_free_list
= 0;
705 n_interval_blocks
= 1;
709 /* Return a new interval. */
716 if (interval_free_list
)
718 val
= interval_free_list
;
719 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
723 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
725 register struct interval_block
*newi
;
727 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
730 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
731 newi
->next
= interval_block
;
732 interval_block
= newi
;
733 interval_block_index
= 0;
736 val
= &interval_block
->intervals
[interval_block_index
++];
738 consing_since_gc
+= sizeof (struct interval
);
740 RESET_INTERVAL (val
);
745 /* Mark Lisp objects in interval I. */
748 mark_interval (i
, dummy
)
752 if (XMARKBIT (i
->plist
))
754 mark_object (&i
->plist
);
759 /* Mark the interval tree rooted in TREE. Don't call this directly;
760 use the macro MARK_INTERVAL_TREE instead. */
763 mark_interval_tree (tree
)
764 register INTERVAL tree
;
766 /* No need to test if this tree has been marked already; this
767 function is always called through the MARK_INTERVAL_TREE macro,
768 which takes care of that. */
770 /* XMARK expands to an assignment; the LHS of an assignment can't be
772 XMARK (tree
->up
.obj
);
774 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
778 /* Mark the interval tree rooted in I. */
780 #define MARK_INTERVAL_TREE(i) \
782 if (!NULL_INTERVAL_P (i) \
783 && ! XMARKBIT (i->up.obj)) \
784 mark_interval_tree (i); \
788 /* The oddity in the call to XUNMARK is necessary because XUNMARK
789 expands to an assignment to its argument, and most C compilers
790 don't support casts on the left operand of `='. */
792 #define UNMARK_BALANCE_INTERVALS(i) \
794 if (! NULL_INTERVAL_P (i)) \
796 XUNMARK ((i)->up.obj); \
797 (i) = balance_intervals (i); \
803 /***********************************************************************
805 ***********************************************************************/
807 /* Lisp_Strings are allocated in string_block structures. When a new
808 string_block is allocated, all the Lisp_Strings it contains are
809 added to a free-list stiing_free_list. When a new Lisp_String is
810 needed, it is taken from that list. During the sweep phase of GC,
811 string_blocks that are entirely free are freed, except two which
814 String data is allocated from sblock structures. Strings larger
815 than LARGE_STRING_BYTES, get their own sblock, data for smaller
816 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
818 Sblocks consist internally of sdata structures, one for each
819 Lisp_String. The sdata structure points to the Lisp_String it
820 belongs to. The Lisp_String points back to the `u.data' member of
823 When a Lisp_String is freed during GC, it is put back on
824 string_free_list, and its `data' member and its sdata's `string'
825 pointer is set to null. The size of the string is recorded in the
826 `u.nbytes' member of the sdata. So, sdata structures that are no
827 longer used, can be easily recognized, and it's easy to compact the
828 sblocks of small strings which we do in compact_small_strings. */
830 /* Size in bytes of an sblock structure used for small strings. This
831 is 8192 minus malloc overhead. */
833 #define SBLOCK_SIZE 8188
835 /* Strings larger than this are considered large strings. String data
836 for large strings is allocated from individual sblocks. */
838 #define LARGE_STRING_BYTES 1024
840 /* Structure describing string memory sub-allocated from an sblock.
841 This is where the contents of Lisp strings are stored. */
845 /* Back-pointer to the string this sdata belongs to. If null, this
846 structure is free, and the NBYTES member of the union below
847 contains the string's byte size (the same value that STRING_BYTES
848 would return if STRING were non-null). If non-null, STRING_BYTES
849 (STRING) is the size of the data, and DATA contains the string's
851 struct Lisp_String
*string
;
855 /* When STRING in non-null. */
856 unsigned char data
[1];
858 /* When STRING is null. */
863 /* Structure describing a block of memory which is sub-allocated to
864 obtain string data memory for strings. Blocks for small strings
865 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
866 as large as needed. */
873 /* Pointer to the next free sdata block. This points past the end
874 of the sblock if there isn't any space left in this block. */
875 struct sdata
*next_free
;
878 struct sdata first_data
;
881 /* Number of Lisp strings in a string_block structure. The 1020 is
882 1024 minus malloc overhead. */
884 #define STRINGS_IN_STRING_BLOCK \
885 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
887 /* Structure describing a block from which Lisp_String structures
892 struct string_block
*next
;
893 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
896 /* Head and tail of the list of sblock structures holding Lisp string
897 data. We always allocate from current_sblock. The NEXT pointers
898 in the sblock structures go from oldest_sblock to current_sblock. */
900 static struct sblock
*oldest_sblock
, *current_sblock
;
902 /* List of sblocks for large strings. */
904 static struct sblock
*large_sblocks
;
906 /* List of string_block structures, and how many there are. */
908 static struct string_block
*string_blocks
;
909 static int n_string_blocks
;
911 /* Free-list of Lisp_Strings. */
913 static struct Lisp_String
*string_free_list
;
915 /* Number of live and free Lisp_Strings. */
917 static int total_strings
, total_free_strings
;
919 /* Number of bytes used by live strings. */
921 static int total_string_size
;
923 /* Given a pointer to a Lisp_String S which is on the free-list
924 string_free_list, return a pointer to its successor in the
927 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
929 /* Return a pointer to the sdata structure belonging to Lisp string S.
930 S must be live, i.e. S->data must not be null. S->data is actually
931 a pointer to the `u.data' member of its sdata structure; the
932 structure starts at a constant offset in front of that. */
934 #define SDATA_OF_STRING(S) \
935 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
937 /* Value is the size of an sdata structure large enough to hold NBYTES
938 bytes of string data. The value returned includes a terminating
939 NUL byte, the size of the sdata structure, and padding. */
941 #define SDATA_SIZE(NBYTES) \
942 ((sizeof (struct Lisp_String *) \
944 + sizeof (EMACS_INT) - 1) \
945 & ~(sizeof (EMACS_INT) - 1))
948 /* Initialize string allocation. Called from init_alloc_once. */
953 total_strings
= total_free_strings
= total_string_size
= 0;
954 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
955 string_blocks
= NULL
;
957 string_free_list
= NULL
;
961 /* Return a new Lisp_String. */
963 static struct Lisp_String
*
966 struct Lisp_String
*s
;
968 /* If the free-list is empty, allocate a new string_block, and
969 add all the Lisp_Strings in it to the free-list. */
970 if (string_free_list
== NULL
)
972 struct string_block
*b
;
975 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
976 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
977 bzero (b
, sizeof *b
);
978 b
->next
= string_blocks
;
982 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
985 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
986 string_free_list
= s
;
989 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
992 /* Pop a Lisp_String off the free-list. */
993 s
= string_free_list
;
994 string_free_list
= NEXT_FREE_LISP_STRING (s
);
996 /* Probably not strictly necessary, but play it safe. */
997 bzero (s
, sizeof *s
);
999 --total_free_strings
;
1002 consing_since_gc
+= sizeof *s
;
1008 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1009 plus a NUL byte at the end. Allocate an sdata structure for S, and
1010 set S->data to its `u.data' member. Store a NUL byte at the end of
1011 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1012 S->data if it was initially non-null. */
1015 allocate_string_data (s
, nchars
, nbytes
)
1016 struct Lisp_String
*s
;
1023 /* Determine the number of bytes needed to store NBYTES bytes
1025 needed
= SDATA_SIZE (nbytes
);
1027 if (nbytes
> LARGE_STRING_BYTES
)
1029 int size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1031 #ifdef DOUG_LEA_MALLOC
1032 /* Prevent mmap'ing the chunk (which is potentially very large). */
1033 mallopt (M_MMAP_MAX
, 0);
1036 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1038 #ifdef DOUG_LEA_MALLOC
1039 /* Back to a reasonable maximum of mmap'ed areas. */
1040 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1043 b
->next_free
= &b
->first_data
;
1044 b
->first_data
.string
= NULL
;
1045 b
->next
= large_sblocks
;
1048 else if (current_sblock
== NULL
1049 || (((char *) current_sblock
+ SBLOCK_SIZE
1050 - (char *) current_sblock
->next_free
)
1053 /* Not enough room in the current sblock. */
1054 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1055 b
->next_free
= &b
->first_data
;
1056 b
->first_data
.string
= NULL
;
1060 current_sblock
->next
= b
;
1068 /* If S had already data assigned, mark that as free by setting
1069 its string back-pointer to null, and recording the size of
1073 data
= SDATA_OF_STRING (s
);
1074 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1075 data
->string
= NULL
;
1078 data
= b
->next_free
;
1080 s
->data
= data
->u
.data
;
1082 s
->size_byte
= nbytes
;
1083 s
->data
[nbytes
] = '\0';
1084 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1086 consing_since_gc
+= needed
;
1090 /* Sweep and compact strings. */
1095 struct string_block
*b
, *next
;
1096 struct string_block
*live_blocks
= NULL
;
1098 string_free_list
= NULL
;
1099 total_strings
= total_free_strings
= 0;
1100 total_string_size
= 0;
1102 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1103 for (b
= string_blocks
; b
; b
= next
)
1106 struct Lisp_String
*free_list_before
= string_free_list
;
1110 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1112 struct Lisp_String
*s
= b
->strings
+ i
;
1116 /* String was not on free-list before. */
1117 if (STRING_MARKED_P (s
))
1119 /* String is live; unmark it and its intervals. */
1122 if (!NULL_INTERVAL_P (s
->intervals
))
1123 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1126 total_string_size
+= STRING_BYTES (s
);
1130 /* String is dead. Put it on the free-list. */
1131 struct sdata
*data
= SDATA_OF_STRING (s
);
1133 /* Save the size of S in its sdata so that we know
1134 how large that is. Reset the sdata's string
1135 back-pointer so that we know it's free. */
1136 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1137 data
->string
= NULL
;
1139 /* Reset the strings's `data' member so that we
1143 /* Put the string on the free-list. */
1144 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1145 string_free_list
= s
;
1151 /* S was on the free-list before. Put it there again. */
1152 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1153 string_free_list
= s
;
1158 /* Free blocks that contain free Lisp_Strings only, except
1159 the first two of them. */
1160 if (nfree
== STRINGS_IN_STRING_BLOCK
1161 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1165 string_free_list
= free_list_before
;
1169 total_free_strings
+= nfree
;
1170 b
->next
= live_blocks
;
1175 string_blocks
= live_blocks
;
1176 free_large_strings ();
1177 compact_small_strings ();
1181 /* Free dead large strings. */
1184 free_large_strings ()
1186 struct sblock
*b
, *next
;
1187 struct sblock
*live_blocks
= NULL
;
1189 for (b
= large_sblocks
; b
; b
= next
)
1193 if (b
->first_data
.string
== NULL
)
1197 b
->next
= live_blocks
;
1202 large_sblocks
= live_blocks
;
1206 /* Compact data of small strings. Free sblocks that don't contain
1207 data of live strings after compaction. */
1210 compact_small_strings ()
1212 struct sblock
*b
, *tb
, *next
;
1213 struct sdata
*from
, *to
, *end
, *tb_end
;
1214 struct sdata
*to_end
, *from_end
;
1216 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1217 to, and TB_END is the end of TB. */
1219 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1220 to
= &tb
->first_data
;
1222 /* Step through the blocks from the oldest to the youngest. We
1223 expect that old blocks will stabilize over time, so that less
1224 copying will happen this way. */
1225 for (b
= oldest_sblock
; b
; b
= b
->next
)
1228 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1230 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1232 /* Compute the next FROM here because copying below may
1233 overwrite data we need to compute it. */
1237 nbytes
= GC_STRING_BYTES (from
->string
);
1239 nbytes
= from
->u
.nbytes
;
1241 nbytes
= SDATA_SIZE (nbytes
);
1242 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1244 /* FROM->string non-null means it's alive. Copy its data. */
1247 /* If TB is full, proceed with the next sblock. */
1248 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1249 if (to_end
> tb_end
)
1253 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1254 to
= &tb
->first_data
;
1255 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1258 /* Copy, and update the string's `data' pointer. */
1261 bcopy (from
, to
, nbytes
);
1262 to
->string
->data
= to
->u
.data
;
1265 /* Advance past the sdata we copied to. */
1271 /* The rest of the sblocks following TB don't contain live data, so
1272 we can free them. */
1273 for (b
= tb
->next
; b
; b
= next
)
1281 current_sblock
= tb
;
1285 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1286 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1287 Both LENGTH and INIT must be numbers.")
1289 Lisp_Object length
, init
;
1291 register Lisp_Object val
;
1292 register unsigned char *p
, *end
;
1295 CHECK_NATNUM (length
, 0);
1296 CHECK_NUMBER (init
, 1);
1299 if (SINGLE_BYTE_CHAR_P (c
))
1301 nbytes
= XINT (length
);
1302 val
= make_uninit_string (nbytes
);
1303 p
= XSTRING (val
)->data
;
1304 end
= p
+ XSTRING (val
)->size
;
1310 unsigned char str
[4];
1311 int len
= CHAR_STRING (c
, str
);
1313 nbytes
= len
* XINT (length
);
1314 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1315 p
= XSTRING (val
)->data
;
1319 bcopy (str
, p
, len
);
1329 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1330 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1331 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1333 Lisp_Object length
, init
;
1335 register Lisp_Object val
;
1336 struct Lisp_Bool_Vector
*p
;
1338 int length_in_chars
, length_in_elts
, bits_per_value
;
1340 CHECK_NATNUM (length
, 0);
1342 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1344 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1345 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1347 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1348 slot `size' of the struct Lisp_Bool_Vector. */
1349 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1350 p
= XBOOL_VECTOR (val
);
1352 /* Get rid of any bits that would cause confusion. */
1354 XSETBOOL_VECTOR (val
, p
);
1355 p
->size
= XFASTINT (length
);
1357 real_init
= (NILP (init
) ? 0 : -1);
1358 for (i
= 0; i
< length_in_chars
; i
++)
1359 p
->data
[i
] = real_init
;
1361 /* Clear the extraneous bits in the last byte. */
1362 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1363 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1364 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1370 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1371 of characters from the contents. This string may be unibyte or
1372 multibyte, depending on the contents. */
1375 make_string (contents
, nbytes
)
1379 register Lisp_Object val
;
1380 int nchars
= chars_in_text (contents
, nbytes
);
1381 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1382 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1383 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1384 SET_STRING_BYTES (XSTRING (val
), -1);
1389 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1392 make_unibyte_string (contents
, length
)
1396 register Lisp_Object val
;
1397 val
= make_uninit_string (length
);
1398 bcopy (contents
, XSTRING (val
)->data
, length
);
1399 SET_STRING_BYTES (XSTRING (val
), -1);
1404 /* Make a multibyte string from NCHARS characters occupying NBYTES
1405 bytes at CONTENTS. */
1408 make_multibyte_string (contents
, nchars
, nbytes
)
1412 register Lisp_Object val
;
1413 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1414 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1419 /* Make a string from NCHARS characters occupying NBYTES bytes at
1420 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1423 make_string_from_bytes (contents
, nchars
, nbytes
)
1427 register Lisp_Object val
;
1428 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1429 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1430 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1431 SET_STRING_BYTES (XSTRING (val
), -1);
1436 /* Make a string from NCHARS characters occupying NBYTES bytes at
1437 CONTENTS. The argument MULTIBYTE controls whether to label the
1438 string as multibyte. */
1441 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1446 register Lisp_Object val
;
1447 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1448 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1450 SET_STRING_BYTES (XSTRING (val
), -1);
1455 /* Make a string from the data at STR, treating it as multibyte if the
1462 return make_string (str
, strlen (str
));
1466 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1467 occupying LENGTH bytes. */
1470 make_uninit_string (length
)
1474 val
= make_uninit_multibyte_string (length
, length
);
1475 SET_STRING_BYTES (XSTRING (val
), -1);
1480 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1481 which occupy NBYTES bytes. */
1484 make_uninit_multibyte_string (nchars
, nbytes
)
1488 struct Lisp_String
*s
;
1493 s
= allocate_string ();
1494 allocate_string_data (s
, nchars
, nbytes
);
1495 XSETSTRING (string
, s
);
1496 string_chars_consed
+= nbytes
;
1502 /***********************************************************************
1504 ***********************************************************************/
1506 /* We store float cells inside of float_blocks, allocating a new
1507 float_block with malloc whenever necessary. Float cells reclaimed
1508 by GC are put on a free list to be reallocated before allocating
1509 any new float cells from the latest float_block.
1511 Each float_block is just under 1020 bytes long, since malloc really
1512 allocates in units of powers of two and uses 4 bytes for its own
1515 #define FLOAT_BLOCK_SIZE \
1516 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1520 struct float_block
*next
;
1521 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1524 /* Current float_block. */
1526 struct float_block
*float_block
;
1528 /* Index of first unused Lisp_Float in the current float_block. */
1530 int float_block_index
;
1532 /* Total number of float blocks now in use. */
1536 /* Free-list of Lisp_Floats. */
1538 struct Lisp_Float
*float_free_list
;
1541 /* Initialze float allocation. */
1546 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1548 float_block
->next
= 0;
1549 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1550 float_block_index
= 0;
1551 float_free_list
= 0;
1556 /* Explicitly free a float cell by putting it on the free-list. */
1560 struct Lisp_Float
*ptr
;
1562 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1566 float_free_list
= ptr
;
1570 /* Return a new float object with value FLOAT_VALUE. */
1573 make_float (float_value
)
1576 register Lisp_Object val
;
1578 if (float_free_list
)
1580 /* We use the data field for chaining the free list
1581 so that we won't use the same field that has the mark bit. */
1582 XSETFLOAT (val
, float_free_list
);
1583 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1587 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1589 register struct float_block
*new;
1591 new = (struct float_block
*) lisp_malloc (sizeof *new,
1593 VALIDATE_LISP_STORAGE (new, sizeof *new);
1594 new->next
= float_block
;
1596 float_block_index
= 0;
1599 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1602 XFLOAT_DATA (val
) = float_value
;
1603 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1604 consing_since_gc
+= sizeof (struct Lisp_Float
);
1611 /***********************************************************************
1613 ***********************************************************************/
1615 /* We store cons cells inside of cons_blocks, allocating a new
1616 cons_block with malloc whenever necessary. Cons cells reclaimed by
1617 GC are put on a free list to be reallocated before allocating
1618 any new cons cells from the latest cons_block.
1620 Each cons_block is just under 1020 bytes long,
1621 since malloc really allocates in units of powers of two
1622 and uses 4 bytes for its own overhead. */
1624 #define CONS_BLOCK_SIZE \
1625 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1629 struct cons_block
*next
;
1630 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1633 /* Current cons_block. */
1635 struct cons_block
*cons_block
;
1637 /* Index of first unused Lisp_Cons in the current block. */
1639 int cons_block_index
;
1641 /* Free-list of Lisp_Cons structures. */
1643 struct Lisp_Cons
*cons_free_list
;
1645 /* Total number of cons blocks now in use. */
1650 /* Initialize cons allocation. */
1655 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1657 cons_block
->next
= 0;
1658 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1659 cons_block_index
= 0;
1665 /* Explicitly free a cons cell by putting it on the free-list. */
1669 struct Lisp_Cons
*ptr
;
1671 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1675 cons_free_list
= ptr
;
1679 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
1680 "Create a new cons, give it CAR and CDR as components, and return it.")
1682 Lisp_Object car
, cdr
;
1684 register Lisp_Object val
;
1688 /* We use the cdr for chaining the free list
1689 so that we won't use the same field that has the mark bit. */
1690 XSETCONS (val
, cons_free_list
);
1691 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
1695 if (cons_block_index
== CONS_BLOCK_SIZE
)
1697 register struct cons_block
*new;
1698 new = (struct cons_block
*) lisp_malloc (sizeof *new,
1700 VALIDATE_LISP_STORAGE (new, sizeof *new);
1701 new->next
= cons_block
;
1703 cons_block_index
= 0;
1706 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
1711 consing_since_gc
+= sizeof (struct Lisp_Cons
);
1712 cons_cells_consed
++;
1717 /* Make a list of 2, 3, 4 or 5 specified objects. */
1721 Lisp_Object arg1
, arg2
;
1723 return Fcons (arg1
, Fcons (arg2
, Qnil
));
1728 list3 (arg1
, arg2
, arg3
)
1729 Lisp_Object arg1
, arg2
, arg3
;
1731 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
1736 list4 (arg1
, arg2
, arg3
, arg4
)
1737 Lisp_Object arg1
, arg2
, arg3
, arg4
;
1739 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
1744 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
1745 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
1747 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
1748 Fcons (arg5
, Qnil
)))));
1752 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
1753 "Return a newly created list with specified arguments as elements.\n\
1754 Any number of arguments, even zero arguments, are allowed.")
1757 register Lisp_Object
*args
;
1759 register Lisp_Object val
;
1765 val
= Fcons (args
[nargs
], val
);
1771 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
1772 "Return a newly created list of length LENGTH, with each element being INIT.")
1774 register Lisp_Object length
, init
;
1776 register Lisp_Object val
;
1779 CHECK_NATNUM (length
, 0);
1780 size
= XFASTINT (length
);
1784 val
= Fcons (init
, val
);
1790 /***********************************************************************
1792 ***********************************************************************/
1794 /* Singly-linked list of all vectors. */
1796 struct Lisp_Vector
*all_vectors
;
1798 /* Total number of vector-like objects now in use. */
1803 /* Value is a pointer to a newly allocated Lisp_Vector structure
1804 with room for LEN Lisp_Objects. */
1806 struct Lisp_Vector
*
1807 allocate_vectorlike (len
)
1810 struct Lisp_Vector
*p
;
1813 #ifdef DOUG_LEA_MALLOC
1814 /* Prevent mmap'ing the chunk (which is potentially very large).. */
1815 mallopt (M_MMAP_MAX
, 0);
1818 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
1819 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
1821 #ifdef DOUG_LEA_MALLOC
1822 /* Back to a reasonable maximum of mmap'ed areas. */
1823 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1826 VALIDATE_LISP_STORAGE (p
, 0);
1827 consing_since_gc
+= nbytes
;
1828 vector_cells_consed
+= len
;
1830 p
->next
= all_vectors
;
1837 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
1838 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1839 See also the function `vector'.")
1841 register Lisp_Object length
, init
;
1844 register EMACS_INT sizei
;
1846 register struct Lisp_Vector
*p
;
1848 CHECK_NATNUM (length
, 0);
1849 sizei
= XFASTINT (length
);
1851 p
= allocate_vectorlike (sizei
);
1853 for (index
= 0; index
< sizei
; index
++)
1854 p
->contents
[index
] = init
;
1856 XSETVECTOR (vector
, p
);
1861 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
1862 "Return a newly created char-table, with purpose PURPOSE.\n\
1863 Each element is initialized to INIT, which defaults to nil.\n\
1864 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
1865 The property's value should be an integer between 0 and 10.")
1867 register Lisp_Object purpose
, init
;
1871 CHECK_SYMBOL (purpose
, 1);
1872 n
= Fget (purpose
, Qchar_table_extra_slots
);
1873 CHECK_NUMBER (n
, 0);
1874 if (XINT (n
) < 0 || XINT (n
) > 10)
1875 args_out_of_range (n
, Qnil
);
1876 /* Add 2 to the size for the defalt and parent slots. */
1877 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
1879 XCHAR_TABLE (vector
)->top
= Qt
;
1880 XCHAR_TABLE (vector
)->parent
= Qnil
;
1881 XCHAR_TABLE (vector
)->purpose
= purpose
;
1882 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1887 /* Return a newly created sub char table with default value DEFALT.
1888 Since a sub char table does not appear as a top level Emacs Lisp
1889 object, we don't need a Lisp interface to make it. */
1892 make_sub_char_table (defalt
)
1896 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
1897 XCHAR_TABLE (vector
)->top
= Qnil
;
1898 XCHAR_TABLE (vector
)->defalt
= defalt
;
1899 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1904 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
1905 "Return a newly created vector with specified arguments as elements.\n\
1906 Any number of arguments, even zero arguments, are allowed.")
1911 register Lisp_Object len
, val
;
1913 register struct Lisp_Vector
*p
;
1915 XSETFASTINT (len
, nargs
);
1916 val
= Fmake_vector (len
, Qnil
);
1918 for (index
= 0; index
< nargs
; index
++)
1919 p
->contents
[index
] = args
[index
];
1924 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
1925 "Create a byte-code object with specified arguments as elements.\n\
1926 The arguments should be the arglist, bytecode-string, constant vector,\n\
1927 stack size, (optional) doc string, and (optional) interactive spec.\n\
1928 The first four arguments are required; at most six have any\n\
1934 register Lisp_Object len
, val
;
1936 register struct Lisp_Vector
*p
;
1938 XSETFASTINT (len
, nargs
);
1939 if (!NILP (Vpurify_flag
))
1940 val
= make_pure_vector ((EMACS_INT
) nargs
);
1942 val
= Fmake_vector (len
, Qnil
);
1944 for (index
= 0; index
< nargs
; index
++)
1946 if (!NILP (Vpurify_flag
))
1947 args
[index
] = Fpurecopy (args
[index
]);
1948 p
->contents
[index
] = args
[index
];
1950 XSETCOMPILED (val
, p
);
1956 /***********************************************************************
1958 ***********************************************************************/
1960 /* Each symbol_block is just under 1020 bytes long, since malloc
1961 really allocates in units of powers of two and uses 4 bytes for its
1964 #define SYMBOL_BLOCK_SIZE \
1965 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
1969 struct symbol_block
*next
;
1970 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
1973 /* Current symbol block and index of first unused Lisp_Symbol
1976 struct symbol_block
*symbol_block
;
1977 int symbol_block_index
;
1979 /* List of free symbols. */
1981 struct Lisp_Symbol
*symbol_free_list
;
1983 /* Total number of symbol blocks now in use. */
1985 int n_symbol_blocks
;
1988 /* Initialize symbol allocation. */
1993 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
1995 symbol_block
->next
= 0;
1996 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
1997 symbol_block_index
= 0;
1998 symbol_free_list
= 0;
1999 n_symbol_blocks
= 1;
2003 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2004 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2005 Its value and function definition are void, and its property list is nil.")
2009 register Lisp_Object val
;
2010 register struct Lisp_Symbol
*p
;
2012 CHECK_STRING (name
, 0);
2014 if (symbol_free_list
)
2016 XSETSYMBOL (val
, symbol_free_list
);
2017 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2021 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2023 struct symbol_block
*new;
2024 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2026 VALIDATE_LISP_STORAGE (new, sizeof *new);
2027 new->next
= symbol_block
;
2029 symbol_block_index
= 0;
2032 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2036 p
->name
= XSTRING (name
);
2039 p
->value
= Qunbound
;
2040 p
->function
= Qunbound
;
2042 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2049 /***********************************************************************
2050 Marker (Misc) Allocation
2051 ***********************************************************************/
2053 /* Allocation of markers and other objects that share that structure.
2054 Works like allocation of conses. */
2056 #define MARKER_BLOCK_SIZE \
2057 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2061 struct marker_block
*next
;
2062 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2065 struct marker_block
*marker_block
;
2066 int marker_block_index
;
2068 union Lisp_Misc
*marker_free_list
;
2070 /* Total number of marker blocks now in use. */
2072 int n_marker_blocks
;
2077 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2079 marker_block
->next
= 0;
2080 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2081 marker_block_index
= 0;
2082 marker_free_list
= 0;
2083 n_marker_blocks
= 1;
2086 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2093 if (marker_free_list
)
2095 XSETMISC (val
, marker_free_list
);
2096 marker_free_list
= marker_free_list
->u_free
.chain
;
2100 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2102 struct marker_block
*new;
2103 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2105 VALIDATE_LISP_STORAGE (new, sizeof *new);
2106 new->next
= marker_block
;
2108 marker_block_index
= 0;
2111 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2114 consing_since_gc
+= sizeof (union Lisp_Misc
);
2115 misc_objects_consed
++;
2119 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2120 "Return a newly allocated marker which does not point at any place.")
2123 register Lisp_Object val
;
2124 register struct Lisp_Marker
*p
;
2126 val
= allocate_misc ();
2127 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2133 p
->insertion_type
= 0;
2137 /* Put MARKER back on the free list after using it temporarily. */
2140 free_marker (marker
)
2143 unchain_marker (marker
);
2145 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2146 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2147 marker_free_list
= XMISC (marker
);
2149 total_free_markers
++;
2153 /* Return a newly created vector or string with specified arguments as
2154 elements. If all the arguments are characters that can fit
2155 in a string of events, make a string; otherwise, make a vector.
2157 Any number of arguments, even zero arguments, are allowed. */
2160 make_event_array (nargs
, args
)
2166 for (i
= 0; i
< nargs
; i
++)
2167 /* The things that fit in a string
2168 are characters that are in 0...127,
2169 after discarding the meta bit and all the bits above it. */
2170 if (!INTEGERP (args
[i
])
2171 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2172 return Fvector (nargs
, args
);
2174 /* Since the loop exited, we know that all the things in it are
2175 characters, so we can make a string. */
2179 result
= Fmake_string (make_number (nargs
), make_number (0));
2180 for (i
= 0; i
< nargs
; i
++)
2182 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2183 /* Move the meta bit to the right place for a string char. */
2184 if (XINT (args
[i
]) & CHAR_META
)
2185 XSTRING (result
)->data
[i
] |= 0x80;
2194 /************************************************************************
2196 ************************************************************************/
2201 /* Base address of stack. Set in main. */
2203 Lisp_Object
*stack_base
;
2205 /* A node in the red-black tree describing allocated memory containing
2206 Lisp data. Each such block is recorded with its start and end
2207 address when it is allocated, and removed from the tree when it
2210 A red-black tree is a balanced binary tree with the following
2213 1. Every node is either red or black.
2214 2. Every leaf is black.
2215 3. If a node is red, then both of its children are black.
2216 4. Every simple path from a node to a descendant leaf contains
2217 the same number of black nodes.
2218 5. The root is always black.
2220 When nodes are inserted into the tree, or deleted from the tree,
2221 the tree is "fixed" so that these properties are always true.
2223 A red-black tree with N internal nodes has height at most 2
2224 log(N+1). Searches, insertions and deletions are done in O(log N).
2225 Please see a text book about data structures for a detailed
2226 description of red-black trees. Any book worth its salt should
2231 struct mem_node
*left
, *right
, *parent
;
2233 /* Start and end of allocated region. */
2237 enum {MEM_BLACK
, MEM_RED
} color
;
2243 /* Root of the tree describing allocated Lisp memory. */
2245 static struct mem_node
*mem_root
;
2247 /* Sentinel node of the tree. */
2249 static struct mem_node mem_z
;
2250 #define MEM_NIL &mem_z
2253 /* Initialize this part of alloc.c. */
2258 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2259 mem_z
.parent
= NULL
;
2260 mem_z
.color
= MEM_BLACK
;
2261 mem_z
.start
= mem_z
.end
= NULL
;
2266 /* Value is a pointer to the mem_node containing START. Value is
2267 MEM_NIL if there is no node in the tree containing START. */
2269 static INLINE
struct mem_node
*
2275 /* Make the search always successful to speed up the loop below. */
2276 mem_z
.start
= start
;
2277 mem_z
.end
= (char *) start
+ 1;
2280 while (start
< p
->start
|| start
>= p
->end
)
2281 p
= start
< p
->start
? p
->left
: p
->right
;
2286 /* Insert a new node into the tree for a block of memory with start
2287 address START, end address END, and type TYPE. Value is a
2288 pointer to the node that was inserted. */
2290 static struct mem_node
*
2291 mem_insert (start
, end
, type
)
2295 struct mem_node
*c
, *parent
, *x
;
2297 /* See where in the tree a node for START belongs. In this
2298 particular application, it shouldn't happen that a node is already
2299 present. For debugging purposes, let's check that. */
2303 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2305 while (c
!= MEM_NIL
)
2307 if (start
>= c
->start
&& start
< c
->end
)
2310 c
= start
< c
->start
? c
->left
: c
->right
;
2313 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2315 while (c
!= MEM_NIL
)
2318 c
= start
< c
->start
? c
->left
: c
->right
;
2321 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2323 /* Create a new node. */
2324 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2329 x
->left
= x
->right
= MEM_NIL
;
2332 /* Insert it as child of PARENT or install it as root. */
2335 if (start
< parent
->start
)
2343 /* Re-establish red-black tree properties. */
2344 mem_insert_fixup (x
);
2349 /* Re-establish the red-black properties of the tree, and thereby
2350 balance the tree, after node X has been inserted; X is always red. */
2353 mem_insert_fixup (x
)
2356 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2358 /* X is red and its parent is red. This is a violation of
2359 red-black tree property #3. */
2361 if (x
->parent
== x
->parent
->parent
->left
)
2363 /* We're on the left side of our grandparent, and Y is our
2365 struct mem_node
*y
= x
->parent
->parent
->right
;
2367 if (y
->color
== MEM_RED
)
2369 /* Uncle and parent are red but should be black because
2370 X is red. Change the colors accordingly and proceed
2371 with the grandparent. */
2372 x
->parent
->color
= MEM_BLACK
;
2373 y
->color
= MEM_BLACK
;
2374 x
->parent
->parent
->color
= MEM_RED
;
2375 x
= x
->parent
->parent
;
2379 /* Parent and uncle have different colors; parent is
2380 red, uncle is black. */
2381 if (x
== x
->parent
->right
)
2384 mem_rotate_left (x
);
2387 x
->parent
->color
= MEM_BLACK
;
2388 x
->parent
->parent
->color
= MEM_RED
;
2389 mem_rotate_right (x
->parent
->parent
);
2394 /* This is the symmetrical case of above. */
2395 struct mem_node
*y
= x
->parent
->parent
->left
;
2397 if (y
->color
== MEM_RED
)
2399 x
->parent
->color
= MEM_BLACK
;
2400 y
->color
= MEM_BLACK
;
2401 x
->parent
->parent
->color
= MEM_RED
;
2402 x
= x
->parent
->parent
;
2406 if (x
== x
->parent
->left
)
2409 mem_rotate_right (x
);
2412 x
->parent
->color
= MEM_BLACK
;
2413 x
->parent
->parent
->color
= MEM_RED
;
2414 mem_rotate_left (x
->parent
->parent
);
2419 /* The root may have been changed to red due to the algorithm. Set
2420 it to black so that property #5 is satisfied. */
2421 mem_root
->color
= MEM_BLACK
;
2437 /* Turn y's left sub-tree into x's right sub-tree. */
2440 if (y
->left
!= MEM_NIL
)
2441 y
->left
->parent
= x
;
2443 /* Y's parent was x's parent. */
2445 y
->parent
= x
->parent
;
2447 /* Get the parent to point to y instead of x. */
2450 if (x
== x
->parent
->left
)
2451 x
->parent
->left
= y
;
2453 x
->parent
->right
= y
;
2458 /* Put x on y's left. */
2472 mem_rotate_right (x
)
2475 struct mem_node
*y
= x
->left
;
2478 if (y
->right
!= MEM_NIL
)
2479 y
->right
->parent
= x
;
2482 y
->parent
= x
->parent
;
2485 if (x
== x
->parent
->right
)
2486 x
->parent
->right
= y
;
2488 x
->parent
->left
= y
;
2499 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2505 struct mem_node
*x
, *y
;
2507 if (!z
|| z
== MEM_NIL
)
2510 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2515 while (y
->left
!= MEM_NIL
)
2519 if (y
->left
!= MEM_NIL
)
2524 x
->parent
= y
->parent
;
2527 if (y
== y
->parent
->left
)
2528 y
->parent
->left
= x
;
2530 y
->parent
->right
= x
;
2537 z
->start
= y
->start
;
2542 if (y
->color
== MEM_BLACK
)
2543 mem_delete_fixup (x
);
2548 /* Re-establish the red-black properties of the tree, after a
2552 mem_delete_fixup (x
)
2555 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2557 if (x
== x
->parent
->left
)
2559 struct mem_node
*w
= x
->parent
->right
;
2561 if (w
->color
== MEM_RED
)
2563 w
->color
= MEM_BLACK
;
2564 x
->parent
->color
= MEM_RED
;
2565 mem_rotate_left (x
->parent
);
2566 w
= x
->parent
->right
;
2569 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2576 if (w
->right
->color
== MEM_BLACK
)
2578 w
->left
->color
= MEM_BLACK
;
2580 mem_rotate_right (w
);
2581 w
= x
->parent
->right
;
2583 w
->color
= x
->parent
->color
;
2584 x
->parent
->color
= MEM_BLACK
;
2585 w
->right
->color
= MEM_BLACK
;
2586 mem_rotate_left (x
->parent
);
2592 struct mem_node
*w
= x
->parent
->left
;
2594 if (w
->color
== MEM_RED
)
2596 w
->color
= MEM_BLACK
;
2597 x
->parent
->color
= MEM_RED
;
2598 mem_rotate_right (x
->parent
);
2599 w
= x
->parent
->left
;
2602 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2609 if (w
->left
->color
== MEM_BLACK
)
2611 w
->right
->color
= MEM_BLACK
;
2613 mem_rotate_left (w
);
2614 w
= x
->parent
->left
;
2617 w
->color
= x
->parent
->color
;
2618 x
->parent
->color
= MEM_BLACK
;
2619 w
->left
->color
= MEM_BLACK
;
2620 mem_rotate_right (x
->parent
);
2626 x
->color
= MEM_BLACK
;
2630 /* Value is non-zero if P is a pointer to a live Lisp string on
2631 the heap. M is a pointer to the mem_block for P. */
2634 live_string_p (m
, p
)
2638 if (m
->type
== MEM_TYPE_STRING
)
2640 struct string_block
*b
= (struct string_block
*) m
->start
;
2641 int offset
= (char *) p
- (char *) &b
->strings
[0];
2643 /* P must point to the start of a Lisp_String structure, and it
2644 must not be on the free-list. */
2645 return (offset
% sizeof b
->strings
[0] == 0
2646 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2653 /* Value is non-zero if P is a pointer to a live Lisp cons on
2654 the heap. M is a pointer to the mem_block for P. */
2661 if (m
->type
== MEM_TYPE_CONS
)
2663 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2664 int offset
= (char *) p
- (char *) &b
->conses
[0];
2666 /* P must point to the start of a Lisp_Cons, not be
2667 one of the unused cells in the current cons block,
2668 and not be on the free-list. */
2669 return (offset
% sizeof b
->conses
[0] == 0
2671 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2672 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2679 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2680 the heap. M is a pointer to the mem_block for P. */
2683 live_symbol_p (m
, p
)
2687 if (m
->type
== MEM_TYPE_SYMBOL
)
2689 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2690 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2692 /* P must point to the start of a Lisp_Symbol, not be
2693 one of the unused cells in the current symbol block,
2694 and not be on the free-list. */
2695 return (offset
% sizeof b
->symbols
[0] == 0
2696 && (b
!= symbol_block
2697 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2698 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2705 /* Value is non-zero if P is a pointer to a live Lisp float on
2706 the heap. M is a pointer to the mem_block for P. */
2713 if (m
->type
== MEM_TYPE_FLOAT
)
2715 struct float_block
*b
= (struct float_block
*) m
->start
;
2716 int offset
= (char *) p
- (char *) &b
->floats
[0];
2718 /* P must point to the start of a Lisp_Float, not be
2719 one of the unused cells in the current float block,
2720 and not be on the free-list. */
2721 return (offset
% sizeof b
->floats
[0] == 0
2722 && (b
!= float_block
2723 || offset
/ sizeof b
->floats
[0] < float_block_index
)
2724 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
2731 /* Value is non-zero if P is a pointer to a live Lisp Misc on
2732 the heap. M is a pointer to the mem_block for P. */
2739 if (m
->type
== MEM_TYPE_MISC
)
2741 struct marker_block
*b
= (struct marker_block
*) m
->start
;
2742 int offset
= (char *) p
- (char *) &b
->markers
[0];
2744 /* P must point to the start of a Lisp_Misc, not be
2745 one of the unused cells in the current misc block,
2746 and not be on the free-list. */
2747 return (offset
% sizeof b
->markers
[0] == 0
2748 && (b
!= marker_block
2749 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
2750 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
2757 /* Value is non-zero if P is a pointer to a live vector-like object.
2758 M is a pointer to the mem_block for P. */
2761 live_vector_p (m
, p
)
2765 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
2769 /* Value is non-zero of P is a pointer to a live buffer. M is a
2770 pointer to the mem_block for P. */
2773 live_buffer_p (m
, p
)
2777 /* P must point to the start of the block, and the buffer
2778 must not have been killed. */
2779 return (m
->type
== MEM_TYPE_BUFFER
2781 && !NILP (((struct buffer
*) p
)->name
));
2785 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2787 /* Array of objects that are kept alive because the C stack contains
2788 a pattern that looks like a reference to them . */
2790 #define MAX_ZOMBIES 10
2791 static Lisp_Object zombies
[MAX_ZOMBIES
];
2793 /* Number of zombie objects. */
2795 static int nzombies
;
2797 /* Number of garbage collections. */
2801 /* Average percentage of zombies per collection. */
2803 static double avg_zombies
;
2805 /* Max. number of live and zombie objects. */
2807 static int max_live
, max_zombies
;
2809 /* Average number of live objects per GC. */
2811 static double avg_live
;
2813 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
2814 "Show information about live and zombie objects.")
2817 Lisp_Object args
[7];
2818 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2819 args
[1] = make_number (ngcs
);
2820 args
[2] = make_float (avg_live
);
2821 args
[3] = make_float (avg_zombies
);
2822 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
2823 args
[5] = make_number (max_live
);
2824 args
[6] = make_number (max_zombies
);
2825 return Fmessage (7, args
);
2828 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2831 /* Mark OBJ if we can prove it's a Lisp_Object. */
2834 mark_maybe_object (obj
)
2837 void *po
= (void *) XPNTR (obj
);
2838 struct mem_node
*m
= mem_find (po
);
2844 switch (XGCTYPE (obj
))
2847 mark_p
= (live_string_p (m
, po
)
2848 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
2852 mark_p
= (live_cons_p (m
, po
)
2853 && !XMARKBIT (XCONS (obj
)->car
));
2857 mark_p
= (live_symbol_p (m
, po
)
2858 && !XMARKBIT (XSYMBOL (obj
)->plist
));
2862 mark_p
= (live_float_p (m
, po
)
2863 && !XMARKBIT (XFLOAT (obj
)->type
));
2866 case Lisp_Vectorlike
:
2867 /* Note: can't check GC_BUFFERP before we know it's a
2868 buffer because checking that dereferences the pointer
2869 PO which might point anywhere. */
2870 if (live_vector_p (m
, po
))
2871 mark_p
= (!GC_SUBRP (obj
)
2872 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
2873 else if (live_buffer_p (m
, po
))
2874 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
2878 if (live_misc_p (m
, po
))
2880 switch (XMISCTYPE (obj
))
2882 case Lisp_Misc_Marker
:
2883 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
2886 case Lisp_Misc_Buffer_Local_Value
:
2887 case Lisp_Misc_Some_Buffer_Local_Value
:
2888 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2891 case Lisp_Misc_Overlay
:
2892 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
2901 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2902 if (nzombies
< MAX_ZOMBIES
)
2903 zombies
[nzombies
] = *p
;
2911 /* Mark Lisp objects in the address range START..END. */
2914 mark_memory (start
, end
)
2919 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2923 /* Make START the pointer to the start of the memory region,
2924 if it isn't already. */
2932 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
2933 mark_maybe_object (*p
);
2937 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2939 static int setjmp_tested_p
, longjmps_done
;
2941 #define SETJMP_WILL_LIKELY_WORK "\
2943 Emacs garbage collector has been changed to use conservative stack\n\
2944 marking. Emacs has determined that the method it uses to do the\n\
2945 marking will likely work on your system, but this isn't sure.\n\
2947 If you are a system-programmer, or can get the help of a local wizard\n\
2948 who is, please take a look at the function mark_stack in alloc.c, and\n\
2949 verify that the methods used are appropriate for your system.\n\
2951 Please mail the result to <gerd@gnu.org>.\n\
2954 #define SETJMP_WILL_NOT_WORK "\
2956 Emacs garbage collector has been changed to use conservative stack\n\
2957 marking. Emacs has determined that the default method it uses to do the\n\
2958 marking will not work on your system. We will need a system-dependent\n\
2959 solution for your system.\n\
2961 Please take a look at the function mark_stack in alloc.c, and\n\
2962 try to find a way to make it work on your system.\n\
2963 Please mail the result to <gerd@gnu.org>.\n\
2967 /* Perform a quick check if it looks like setjmp saves registers in a
2968 jmp_buf. Print a message to stderr saying so. When this test
2969 succeeds, this is _not_ a proof that setjmp is sufficient for
2970 conservative stack marking. Only the sources or a disassembly
2981 /* Arrange for X to be put in a register. */
2987 if (longjmps_done
== 1)
2989 /* Came here after the longjmp at the end of the function.
2991 If x == 1, the longjmp has restored the register to its
2992 value before the setjmp, and we can hope that setjmp
2993 saves all such registers in the jmp_buf, although that
2996 For other values of X, either something really strange is
2997 taking place, or the setjmp just didn't save the register. */
3000 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3003 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3010 if (longjmps_done
== 1)
3014 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3017 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3019 /* Abort if anything GCPRO'd doesn't survive the GC. */
3027 for (p
= gcprolist
; p
; p
= p
->next
)
3028 for (i
= 0; i
< p
->nvars
; ++i
)
3029 if (!survives_gc_p (p
->var
[i
]))
3033 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3040 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3041 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3043 fprintf (stderr
, " %d = ", i
);
3044 debug_print (zombies
[i
]);
3048 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3051 /* Mark live Lisp objects on the C stack.
3053 There are several system-dependent problems to consider when
3054 porting this to new architectures:
3058 We have to mark Lisp objects in CPU registers that can hold local
3059 variables or are used to pass parameters.
3061 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3062 something that either saves relevant registers on the stack, or
3063 calls mark_maybe_object passing it each register's contents.
3065 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3066 implementation assumes that calling setjmp saves registers we need
3067 to see in a jmp_buf which itself lies on the stack. This doesn't
3068 have to be true! It must be verified for each system, possibly
3069 by taking a look at the source code of setjmp.
3073 Architectures differ in the way their processor stack is organized.
3074 For example, the stack might look like this
3077 | Lisp_Object | size = 4
3079 | something else | size = 2
3081 | Lisp_Object | size = 4
3085 In such a case, not every Lisp_Object will be aligned equally. To
3086 find all Lisp_Object on the stack it won't be sufficient to walk
3087 the stack in steps of 4 bytes. Instead, two passes will be
3088 necessary, one starting at the start of the stack, and a second
3089 pass starting at the start of the stack + 2. Likewise, if the
3090 minimal alignment of Lisp_Objects on the stack is 1, four passes
3091 would be necessary, each one starting with one byte more offset
3092 from the stack start.
3094 The current code assumes by default that Lisp_Objects are aligned
3095 equally on the stack. */
3101 int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3104 /* This trick flushes the register windows so that all the state of
3105 the process is contained in the stack. */
3110 /* Save registers that we need to see on the stack. We need to see
3111 registers used to hold register variables and registers used to
3113 #ifdef GC_SAVE_REGISTERS_ON_STACK
3114 GC_SAVE_REGISTERS_ON_STACK (end
);
3115 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3117 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3118 setjmp will definitely work, test it
3119 and print a message with the result
3121 if (!setjmp_tested_p
)
3123 setjmp_tested_p
= 1;
3126 #endif /* GC_SETJMP_WORKS */
3129 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3130 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3132 /* This assumes that the stack is a contiguous region in memory. If
3133 that's not the case, something has to be done here to iterate
3134 over the stack segments. */
3135 #if GC_LISP_OBJECT_ALIGNMENT == 1
3136 mark_memory (stack_base
, end
);
3137 mark_memory ((char *) stack_base
+ 1, end
);
3138 mark_memory ((char *) stack_base
+ 2, end
);
3139 mark_memory ((char *) stack_base
+ 3, end
);
3140 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3141 mark_memory (stack_base
, end
);
3142 mark_memory ((char *) stack_base
+ 2, end
);
3144 mark_memory (stack_base
, end
);
3147 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3153 #endif /* GC_MARK_STACK != 0 */
3157 /***********************************************************************
3158 Pure Storage Management
3159 ***********************************************************************/
3161 /* Return a string allocated in pure space. DATA is a buffer holding
3162 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3163 non-zero means make the result string multibyte.
3165 Must get an error if pure storage is full, since if it cannot hold
3166 a large string it may be able to hold conses that point to that
3167 string; then the string is not protected from gc. */
3170 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3176 struct Lisp_String
*s
;
3177 int string_size
, data_size
;
3179 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3181 string_size
= PAD (sizeof (struct Lisp_String
));
3182 data_size
= PAD (nbytes
+ 1);
3186 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3187 error ("Pure Lisp storage exhausted");
3189 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3190 pureptr
+= string_size
;
3191 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3192 pureptr
+= data_size
;
3195 s
->size_byte
= multibyte
? nbytes
: -1;
3196 bcopy (data
, s
->data
, nbytes
);
3197 s
->data
[nbytes
] = '\0';
3198 s
->intervals
= NULL_INTERVAL
;
3200 XSETSTRING (string
, s
);
3205 /* Return a cons allocated from pure space. Give it pure copies
3206 of CAR as car and CDR as cdr. */
3209 pure_cons (car
, cdr
)
3210 Lisp_Object car
, cdr
;
3212 register Lisp_Object
new;
3214 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3215 error ("Pure Lisp storage exhausted");
3216 XSETCONS (new, PUREBEG
+ pureptr
);
3217 pureptr
+= sizeof (struct Lisp_Cons
);
3218 XCAR (new) = Fpurecopy (car
);
3219 XCDR (new) = Fpurecopy (cdr
);
3224 /* Value is a float object with value NUM allocated from pure space. */
3227 make_pure_float (num
)
3230 register Lisp_Object
new;
3232 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3233 (double) boundary. Some architectures (like the sparc) require
3234 this, and I suspect that floats are rare enough that it's no
3235 tragedy for those that do. */
3238 char *p
= PUREBEG
+ pureptr
;
3242 alignment
= __alignof (struct Lisp_Float
);
3244 alignment
= sizeof (struct Lisp_Float
);
3247 alignment
= sizeof (struct Lisp_Float
);
3249 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3250 pureptr
= p
- PUREBEG
;
3253 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3254 error ("Pure Lisp storage exhausted");
3255 XSETFLOAT (new, PUREBEG
+ pureptr
);
3256 pureptr
+= sizeof (struct Lisp_Float
);
3257 XFLOAT_DATA (new) = num
;
3258 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3263 /* Return a vector with room for LEN Lisp_Objects allocated from
3267 make_pure_vector (len
)
3270 register Lisp_Object
new;
3271 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3272 + (len
- 1) * sizeof (Lisp_Object
));
3274 if (pureptr
+ size
> PURESIZE
)
3275 error ("Pure Lisp storage exhausted");
3277 XSETVECTOR (new, PUREBEG
+ pureptr
);
3279 XVECTOR (new)->size
= len
;
3284 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3285 "Make a copy of OBJECT in pure storage.\n\
3286 Recursively copies contents of vectors and cons cells.\n\
3287 Does not copy symbols. Copies strings without text properties.")
3289 register Lisp_Object obj
;
3291 if (NILP (Vpurify_flag
))
3294 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3295 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3299 return pure_cons (XCAR (obj
), XCDR (obj
));
3300 else if (FLOATP (obj
))
3301 return make_pure_float (XFLOAT_DATA (obj
));
3302 else if (STRINGP (obj
))
3303 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3304 STRING_BYTES (XSTRING (obj
)),
3305 STRING_MULTIBYTE (obj
));
3306 else if (COMPILEDP (obj
) || VECTORP (obj
))
3308 register struct Lisp_Vector
*vec
;
3309 register int i
, size
;
3311 size
= XVECTOR (obj
)->size
;
3312 if (size
& PSEUDOVECTOR_FLAG
)
3313 size
&= PSEUDOVECTOR_SIZE_MASK
;
3314 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3315 for (i
= 0; i
< size
; i
++)
3316 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3317 if (COMPILEDP (obj
))
3318 XSETCOMPILED (obj
, vec
);
3320 XSETVECTOR (obj
, vec
);
3323 else if (MARKERP (obj
))
3324 error ("Attempt to copy a marker to pure storage");
3331 /***********************************************************************
3333 ***********************************************************************/
3335 /* Recording what needs to be marked for gc. */
3337 struct gcpro
*gcprolist
;
3339 /* Addresses of staticpro'd variables. */
3341 #define NSTATICS 1024
3342 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3344 /* Index of next unused slot in staticvec. */
3349 /* Put an entry in staticvec, pointing at the variable with address
3353 staticpro (varaddress
)
3354 Lisp_Object
*varaddress
;
3356 staticvec
[staticidx
++] = varaddress
;
3357 if (staticidx
>= NSTATICS
)
3365 struct catchtag
*next
;
3370 struct backtrace
*next
;
3371 Lisp_Object
*function
;
3372 Lisp_Object
*args
; /* Points to vector of args. */
3373 int nargs
; /* Length of vector. */
3374 /* If nargs is UNEVALLED, args points to slot holding list of
3381 /***********************************************************************
3383 ***********************************************************************/
3385 /* Temporarily prevent garbage collection. */
3388 inhibit_garbage_collection ()
3390 int count
= specpdl_ptr
- specpdl
;
3392 int nbits
= min (VALBITS
, BITS_PER_INT
);
3394 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3396 specbind (Qgc_cons_threshold
, number
);
3402 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3403 "Reclaim storage for Lisp objects no longer needed.\n\
3404 Returns info on amount of space in use:\n\
3405 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3406 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3407 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3408 (USED-STRINGS . FREE-STRINGS))\n\
3409 Garbage collection happens automatically if you cons more than\n\
3410 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3413 register struct gcpro
*tail
;
3414 register struct specbinding
*bind
;
3415 struct catchtag
*catch;
3416 struct handler
*handler
;
3417 register struct backtrace
*backlist
;
3418 char stack_top_variable
;
3421 Lisp_Object total
[7];
3423 /* In case user calls debug_print during GC,
3424 don't let that cause a recursive GC. */
3425 consing_since_gc
= 0;
3427 /* Save what's currently displayed in the echo area. */
3428 message_p
= push_message ();
3430 /* Save a copy of the contents of the stack, for debugging. */
3431 #if MAX_SAVE_STACK > 0
3432 if (NILP (Vpurify_flag
))
3434 i
= &stack_top_variable
- stack_bottom
;
3436 if (i
< MAX_SAVE_STACK
)
3438 if (stack_copy
== 0)
3439 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3440 else if (stack_copy_size
< i
)
3441 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3444 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3445 bcopy (stack_bottom
, stack_copy
, i
);
3447 bcopy (&stack_top_variable
, stack_copy
, i
);
3451 #endif /* MAX_SAVE_STACK > 0 */
3453 if (garbage_collection_messages
)
3454 message1_nolog ("Garbage collecting...");
3458 shrink_regexp_cache ();
3460 /* Don't keep undo information around forever. */
3462 register struct buffer
*nextb
= all_buffers
;
3466 /* If a buffer's undo list is Qt, that means that undo is
3467 turned off in that buffer. Calling truncate_undo_list on
3468 Qt tends to return NULL, which effectively turns undo back on.
3469 So don't call truncate_undo_list if undo_list is Qt. */
3470 if (! EQ (nextb
->undo_list
, Qt
))
3472 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3474 nextb
= nextb
->next
;
3480 /* clear_marks (); */
3482 /* Mark all the special slots that serve as the roots of accessibility.
3484 Usually the special slots to mark are contained in particular structures.
3485 Then we know no slot is marked twice because the structures don't overlap.
3486 In some cases, the structures point to the slots to be marked.
3487 For these, we use MARKBIT to avoid double marking of the slot. */
3489 for (i
= 0; i
< staticidx
; i
++)
3490 mark_object (staticvec
[i
]);
3492 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3493 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3496 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3497 for (i
= 0; i
< tail
->nvars
; i
++)
3498 if (!XMARKBIT (tail
->var
[i
]))
3500 mark_object (&tail
->var
[i
]);
3501 XMARK (tail
->var
[i
]);
3506 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3508 mark_object (&bind
->symbol
);
3509 mark_object (&bind
->old_value
);
3511 for (catch = catchlist
; catch; catch = catch->next
)
3513 mark_object (&catch->tag
);
3514 mark_object (&catch->val
);
3516 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3518 mark_object (&handler
->handler
);
3519 mark_object (&handler
->var
);
3521 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3523 if (!XMARKBIT (*backlist
->function
))
3525 mark_object (backlist
->function
);
3526 XMARK (*backlist
->function
);
3528 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3531 i
= backlist
->nargs
- 1;
3533 if (!XMARKBIT (backlist
->args
[i
]))
3535 mark_object (&backlist
->args
[i
]);
3536 XMARK (backlist
->args
[i
]);
3541 /* Look thru every buffer's undo list
3542 for elements that update markers that were not marked,
3545 register struct buffer
*nextb
= all_buffers
;
3549 /* If a buffer's undo list is Qt, that means that undo is
3550 turned off in that buffer. Calling truncate_undo_list on
3551 Qt tends to return NULL, which effectively turns undo back on.
3552 So don't call truncate_undo_list if undo_list is Qt. */
3553 if (! EQ (nextb
->undo_list
, Qt
))
3555 Lisp_Object tail
, prev
;
3556 tail
= nextb
->undo_list
;
3558 while (CONSP (tail
))
3560 if (GC_CONSP (XCAR (tail
))
3561 && GC_MARKERP (XCAR (XCAR (tail
)))
3562 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3565 nextb
->undo_list
= tail
= XCDR (tail
);
3567 tail
= XCDR (prev
) = XCDR (tail
);
3577 nextb
= nextb
->next
;
3581 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3587 /* Clear the mark bits that we set in certain root slots. */
3589 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3590 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3591 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3592 for (i
= 0; i
< tail
->nvars
; i
++)
3593 XUNMARK (tail
->var
[i
]);
3596 unmark_byte_stack ();
3597 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3599 XUNMARK (*backlist
->function
);
3600 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3603 i
= backlist
->nargs
- 1;
3605 XUNMARK (backlist
->args
[i
]);
3607 XUNMARK (buffer_defaults
.name
);
3608 XUNMARK (buffer_local_symbols
.name
);
3610 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3616 /* clear_marks (); */
3619 consing_since_gc
= 0;
3620 if (gc_cons_threshold
< 10000)
3621 gc_cons_threshold
= 10000;
3623 if (garbage_collection_messages
)
3625 if (message_p
|| minibuf_level
> 0)
3628 message1_nolog ("Garbage collecting...done");
3633 total
[0] = Fcons (make_number (total_conses
),
3634 make_number (total_free_conses
));
3635 total
[1] = Fcons (make_number (total_symbols
),
3636 make_number (total_free_symbols
));
3637 total
[2] = Fcons (make_number (total_markers
),
3638 make_number (total_free_markers
));
3639 total
[3] = Fcons (make_number (total_string_size
),
3640 make_number (total_vector_size
));
3641 total
[4] = Fcons (make_number (total_floats
),
3642 make_number (total_free_floats
));
3643 total
[5] = Fcons (make_number (total_intervals
),
3644 make_number (total_free_intervals
));
3645 total
[6] = Fcons (make_number (total_strings
),
3646 make_number (total_free_strings
));
3648 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3650 /* Compute average percentage of zombies. */
3653 for (i
= 0; i
< 7; ++i
)
3654 nlive
+= XFASTINT (XCAR (total
[i
]));
3656 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3657 max_live
= max (nlive
, max_live
);
3658 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3659 max_zombies
= max (nzombies
, max_zombies
);
3664 return Flist (7, total
);
3668 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3669 only interesting objects referenced from glyphs are strings. */
3672 mark_glyph_matrix (matrix
)
3673 struct glyph_matrix
*matrix
;
3675 struct glyph_row
*row
= matrix
->rows
;
3676 struct glyph_row
*end
= row
+ matrix
->nrows
;
3678 for (; row
< end
; ++row
)
3682 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3684 struct glyph
*glyph
= row
->glyphs
[area
];
3685 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3687 for (; glyph
< end_glyph
; ++glyph
)
3688 if (GC_STRINGP (glyph
->object
)
3689 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3690 mark_object (&glyph
->object
);
3696 /* Mark Lisp faces in the face cache C. */
3700 struct face_cache
*c
;
3705 for (i
= 0; i
< c
->used
; ++i
)
3707 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3711 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3712 mark_object (&face
->lface
[j
]);
3719 #ifdef HAVE_WINDOW_SYSTEM
3721 /* Mark Lisp objects in image IMG. */
3727 mark_object (&img
->spec
);
3729 if (!NILP (img
->data
.lisp_val
))
3730 mark_object (&img
->data
.lisp_val
);
3734 /* Mark Lisp objects in image cache of frame F. It's done this way so
3735 that we don't have to include xterm.h here. */
3738 mark_image_cache (f
)
3741 forall_images_in_image_cache (f
, mark_image
);
3744 #endif /* HAVE_X_WINDOWS */
3748 /* Mark reference to a Lisp_Object.
3749 If the object referred to has not been seen yet, recursively mark
3750 all the references contained in it. */
3752 #define LAST_MARKED_SIZE 500
3753 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3754 int last_marked_index
;
3757 mark_object (argptr
)
3758 Lisp_Object
*argptr
;
3760 Lisp_Object
*objptr
= argptr
;
3761 register Lisp_Object obj
;
3768 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3771 last_marked
[last_marked_index
++] = objptr
;
3772 if (last_marked_index
== LAST_MARKED_SIZE
)
3773 last_marked_index
= 0;
3775 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3779 register struct Lisp_String
*ptr
= XSTRING (obj
);
3780 MARK_INTERVAL_TREE (ptr
->intervals
);
3785 case Lisp_Vectorlike
:
3786 if (GC_BUFFERP (obj
))
3788 if (!XMARKBIT (XBUFFER (obj
)->name
))
3791 else if (GC_SUBRP (obj
))
3793 else if (GC_COMPILEDP (obj
))
3794 /* We could treat this just like a vector, but it is better to
3795 save the COMPILED_CONSTANTS element for last and avoid
3798 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3799 register EMACS_INT size
= ptr
->size
;
3800 /* See comment above under Lisp_Vector. */
3801 struct Lisp_Vector
*volatile ptr1
= ptr
;
3804 if (size
& ARRAY_MARK_FLAG
)
3805 break; /* Already marked */
3806 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3807 size
&= PSEUDOVECTOR_SIZE_MASK
;
3808 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3810 if (i
!= COMPILED_CONSTANTS
)
3811 mark_object (&ptr1
->contents
[i
]);
3813 /* This cast should be unnecessary, but some Mips compiler complains
3814 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3815 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
3818 else if (GC_FRAMEP (obj
))
3820 /* See comment above under Lisp_Vector for why this is volatile. */
3821 register struct frame
*volatile ptr
= XFRAME (obj
);
3822 register EMACS_INT size
= ptr
->size
;
3824 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3825 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3827 mark_object (&ptr
->name
);
3828 mark_object (&ptr
->icon_name
);
3829 mark_object (&ptr
->title
);
3830 mark_object (&ptr
->focus_frame
);
3831 mark_object (&ptr
->selected_window
);
3832 mark_object (&ptr
->minibuffer_window
);
3833 mark_object (&ptr
->param_alist
);
3834 mark_object (&ptr
->scroll_bars
);
3835 mark_object (&ptr
->condemned_scroll_bars
);
3836 mark_object (&ptr
->menu_bar_items
);
3837 mark_object (&ptr
->face_alist
);
3838 mark_object (&ptr
->menu_bar_vector
);
3839 mark_object (&ptr
->buffer_predicate
);
3840 mark_object (&ptr
->buffer_list
);
3841 mark_object (&ptr
->menu_bar_window
);
3842 mark_object (&ptr
->tool_bar_window
);
3843 mark_face_cache (ptr
->face_cache
);
3844 #ifdef HAVE_WINDOW_SYSTEM
3845 mark_image_cache (ptr
);
3846 mark_object (&ptr
->desired_tool_bar_items
);
3847 mark_object (&ptr
->current_tool_bar_items
);
3848 mark_object (&ptr
->desired_tool_bar_string
);
3849 mark_object (&ptr
->current_tool_bar_string
);
3850 #endif /* HAVE_WINDOW_SYSTEM */
3852 else if (GC_BOOL_VECTOR_P (obj
))
3854 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3856 if (ptr
->size
& ARRAY_MARK_FLAG
)
3857 break; /* Already marked */
3858 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3860 else if (GC_WINDOWP (obj
))
3862 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3863 struct window
*w
= XWINDOW (obj
);
3864 register EMACS_INT size
= ptr
->size
;
3865 /* The reason we use ptr1 is to avoid an apparent hardware bug
3866 that happens occasionally on the FSF's HP 300s.
3867 The bug is that a2 gets clobbered by recursive calls to mark_object.
3868 The clobberage seems to happen during function entry,
3869 perhaps in the moveml instruction.
3870 Yes, this is a crock, but we have to do it. */
3871 struct Lisp_Vector
*volatile ptr1
= ptr
;
3874 /* Stop if already marked. */
3875 if (size
& ARRAY_MARK_FLAG
)
3879 ptr
->size
|= ARRAY_MARK_FLAG
;
3881 /* There is no Lisp data above The member CURRENT_MATRIX in
3882 struct WINDOW. Stop marking when that slot is reached. */
3884 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
3886 mark_object (&ptr1
->contents
[i
]);
3888 /* Mark glyphs for leaf windows. Marking window matrices is
3889 sufficient because frame matrices use the same glyph
3891 if (NILP (w
->hchild
)
3893 && w
->current_matrix
)
3895 mark_glyph_matrix (w
->current_matrix
);
3896 mark_glyph_matrix (w
->desired_matrix
);
3899 else if (GC_HASH_TABLE_P (obj
))
3901 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
3902 EMACS_INT size
= h
->size
;
3904 /* Stop if already marked. */
3905 if (size
& ARRAY_MARK_FLAG
)
3909 h
->size
|= ARRAY_MARK_FLAG
;
3911 /* Mark contents. */
3912 mark_object (&h
->test
);
3913 mark_object (&h
->weak
);
3914 mark_object (&h
->rehash_size
);
3915 mark_object (&h
->rehash_threshold
);
3916 mark_object (&h
->hash
);
3917 mark_object (&h
->next
);
3918 mark_object (&h
->index
);
3919 mark_object (&h
->user_hash_function
);
3920 mark_object (&h
->user_cmp_function
);
3922 /* If hash table is not weak, mark all keys and values.
3923 For weak tables, mark only the vector. */
3924 if (GC_NILP (h
->weak
))
3925 mark_object (&h
->key_and_value
);
3927 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
3932 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3933 register EMACS_INT size
= ptr
->size
;
3934 /* The reason we use ptr1 is to avoid an apparent hardware bug
3935 that happens occasionally on the FSF's HP 300s.
3936 The bug is that a2 gets clobbered by recursive calls to mark_object.
3937 The clobberage seems to happen during function entry,
3938 perhaps in the moveml instruction.
3939 Yes, this is a crock, but we have to do it. */
3940 struct Lisp_Vector
*volatile ptr1
= ptr
;
3943 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3944 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3945 if (size
& PSEUDOVECTOR_FLAG
)
3946 size
&= PSEUDOVECTOR_SIZE_MASK
;
3948 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3949 mark_object (&ptr1
->contents
[i
]);
3955 /* See comment above under Lisp_Vector for why this is volatile. */
3956 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
3957 struct Lisp_Symbol
*ptrx
;
3959 if (XMARKBIT (ptr
->plist
)) break;
3961 mark_object ((Lisp_Object
*) &ptr
->value
);
3962 mark_object (&ptr
->function
);
3963 mark_object (&ptr
->plist
);
3965 if (!PURE_POINTER_P (ptr
->name
))
3966 MARK_STRING (ptr
->name
);
3967 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
3969 /* Note that we do not mark the obarray of the symbol.
3970 It is safe not to do so because nothing accesses that
3971 slot except to check whether it is nil. */
3975 /* For the benefit of the last_marked log. */
3976 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
3977 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
3978 XSETSYMBOL (obj
, ptrx
);
3979 /* We can't goto loop here because *objptr doesn't contain an
3980 actual Lisp_Object with valid datatype field. */
3987 switch (XMISCTYPE (obj
))
3989 case Lisp_Misc_Marker
:
3990 XMARK (XMARKER (obj
)->chain
);
3991 /* DO NOT mark thru the marker's chain.
3992 The buffer's markers chain does not preserve markers from gc;
3993 instead, markers are removed from the chain when freed by gc. */
3996 case Lisp_Misc_Buffer_Local_Value
:
3997 case Lisp_Misc_Some_Buffer_Local_Value
:
3999 register struct Lisp_Buffer_Local_Value
*ptr
4000 = XBUFFER_LOCAL_VALUE (obj
);
4001 if (XMARKBIT (ptr
->realvalue
)) break;
4002 XMARK (ptr
->realvalue
);
4003 /* If the cdr is nil, avoid recursion for the car. */
4004 if (EQ (ptr
->cdr
, Qnil
))
4006 objptr
= &ptr
->realvalue
;
4009 mark_object (&ptr
->realvalue
);
4010 mark_object (&ptr
->buffer
);
4011 mark_object (&ptr
->frame
);
4012 /* See comment above under Lisp_Vector for why not use ptr here. */
4013 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
4017 case Lisp_Misc_Intfwd
:
4018 case Lisp_Misc_Boolfwd
:
4019 case Lisp_Misc_Objfwd
:
4020 case Lisp_Misc_Buffer_Objfwd
:
4021 case Lisp_Misc_Kboard_Objfwd
:
4022 /* Don't bother with Lisp_Buffer_Objfwd,
4023 since all markable slots in current buffer marked anyway. */
4024 /* Don't need to do Lisp_Objfwd, since the places they point
4025 are protected with staticpro. */
4028 case Lisp_Misc_Overlay
:
4030 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4031 if (!XMARKBIT (ptr
->plist
))
4034 mark_object (&ptr
->start
);
4035 mark_object (&ptr
->end
);
4036 objptr
= &ptr
->plist
;
4049 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4050 if (XMARKBIT (ptr
->car
)) break;
4052 /* If the cdr is nil, avoid recursion for the car. */
4053 if (EQ (ptr
->cdr
, Qnil
))
4058 mark_object (&ptr
->car
);
4059 /* See comment above under Lisp_Vector for why not use ptr here. */
4060 objptr
= &XCDR (obj
);
4065 XMARK (XFLOAT (obj
)->type
);
4076 /* Mark the pointers in a buffer structure. */
4082 register struct buffer
*buffer
= XBUFFER (buf
);
4083 register Lisp_Object
*ptr
;
4084 Lisp_Object base_buffer
;
4086 /* This is the buffer's markbit */
4087 mark_object (&buffer
->name
);
4088 XMARK (buffer
->name
);
4090 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4092 if (CONSP (buffer
->undo_list
))
4095 tail
= buffer
->undo_list
;
4097 while (CONSP (tail
))
4099 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4101 if (XMARKBIT (ptr
->car
))
4104 if (GC_CONSP (ptr
->car
)
4105 && ! XMARKBIT (XCAR (ptr
->car
))
4106 && GC_MARKERP (XCAR (ptr
->car
)))
4108 XMARK (XCAR (ptr
->car
));
4109 mark_object (&XCDR (ptr
->car
));
4112 mark_object (&ptr
->car
);
4114 if (CONSP (ptr
->cdr
))
4120 mark_object (&XCDR (tail
));
4123 mark_object (&buffer
->undo_list
);
4125 for (ptr
= &buffer
->name
+ 1;
4126 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4130 /* If this is an indirect buffer, mark its base buffer. */
4131 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4133 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4134 mark_buffer (base_buffer
);
4139 /* Mark the pointers in the kboard objects. */
4146 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4148 if (kb
->kbd_macro_buffer
)
4149 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4151 mark_object (&kb
->Voverriding_terminal_local_map
);
4152 mark_object (&kb
->Vlast_command
);
4153 mark_object (&kb
->Vreal_last_command
);
4154 mark_object (&kb
->Vprefix_arg
);
4155 mark_object (&kb
->Vlast_prefix_arg
);
4156 mark_object (&kb
->kbd_queue
);
4157 mark_object (&kb
->defining_kbd_macro
);
4158 mark_object (&kb
->Vlast_kbd_macro
);
4159 mark_object (&kb
->Vsystem_key_alist
);
4160 mark_object (&kb
->system_key_syms
);
4161 mark_object (&kb
->Vdefault_minibuffer_frame
);
4166 /* Value is non-zero if OBJ will survive the current GC because it's
4167 either marked or does not need to be marked to survive. */
4175 switch (XGCTYPE (obj
))
4182 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4186 switch (XMISCTYPE (obj
))
4188 case Lisp_Misc_Marker
:
4189 survives_p
= XMARKBIT (obj
);
4192 case Lisp_Misc_Buffer_Local_Value
:
4193 case Lisp_Misc_Some_Buffer_Local_Value
:
4194 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4197 case Lisp_Misc_Intfwd
:
4198 case Lisp_Misc_Boolfwd
:
4199 case Lisp_Misc_Objfwd
:
4200 case Lisp_Misc_Buffer_Objfwd
:
4201 case Lisp_Misc_Kboard_Objfwd
:
4205 case Lisp_Misc_Overlay
:
4206 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4216 struct Lisp_String
*s
= XSTRING (obj
);
4217 survives_p
= STRING_MARKED_P (s
);
4221 case Lisp_Vectorlike
:
4222 if (GC_BUFFERP (obj
))
4223 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4224 else if (GC_SUBRP (obj
))
4227 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4231 survives_p
= XMARKBIT (XCAR (obj
));
4235 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4242 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4247 /* Sweep: find all structures not marked, and free them. */
4252 /* Remove or mark entries in weak hash tables.
4253 This must be done before any object is unmarked. */
4254 sweep_weak_hash_tables ();
4258 /* Put all unmarked conses on free list */
4260 register struct cons_block
*cblk
;
4261 struct cons_block
**cprev
= &cons_block
;
4262 register int lim
= cons_block_index
;
4263 register int num_free
= 0, num_used
= 0;
4267 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4271 for (i
= 0; i
< lim
; i
++)
4272 if (!XMARKBIT (cblk
->conses
[i
].car
))
4275 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4276 cons_free_list
= &cblk
->conses
[i
];
4278 cons_free_list
->car
= Vdead
;
4284 XUNMARK (cblk
->conses
[i
].car
);
4286 lim
= CONS_BLOCK_SIZE
;
4287 /* If this block contains only free conses and we have already
4288 seen more than two blocks worth of free conses then deallocate
4290 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4292 *cprev
= cblk
->next
;
4293 /* Unhook from the free list. */
4294 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4300 num_free
+= this_free
;
4301 cprev
= &cblk
->next
;
4304 total_conses
= num_used
;
4305 total_free_conses
= num_free
;
4308 /* Put all unmarked floats on free list */
4310 register struct float_block
*fblk
;
4311 struct float_block
**fprev
= &float_block
;
4312 register int lim
= float_block_index
;
4313 register int num_free
= 0, num_used
= 0;
4315 float_free_list
= 0;
4317 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4321 for (i
= 0; i
< lim
; i
++)
4322 if (!XMARKBIT (fblk
->floats
[i
].type
))
4325 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4326 float_free_list
= &fblk
->floats
[i
];
4328 float_free_list
->type
= Vdead
;
4334 XUNMARK (fblk
->floats
[i
].type
);
4336 lim
= FLOAT_BLOCK_SIZE
;
4337 /* If this block contains only free floats and we have already
4338 seen more than two blocks worth of free floats then deallocate
4340 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4342 *fprev
= fblk
->next
;
4343 /* Unhook from the free list. */
4344 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4350 num_free
+= this_free
;
4351 fprev
= &fblk
->next
;
4354 total_floats
= num_used
;
4355 total_free_floats
= num_free
;
4358 /* Put all unmarked intervals on free list */
4360 register struct interval_block
*iblk
;
4361 struct interval_block
**iprev
= &interval_block
;
4362 register int lim
= interval_block_index
;
4363 register int num_free
= 0, num_used
= 0;
4365 interval_free_list
= 0;
4367 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4372 for (i
= 0; i
< lim
; i
++)
4374 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4376 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4377 interval_free_list
= &iblk
->intervals
[i
];
4383 XUNMARK (iblk
->intervals
[i
].plist
);
4386 lim
= INTERVAL_BLOCK_SIZE
;
4387 /* If this block contains only free intervals and we have already
4388 seen more than two blocks worth of free intervals then
4389 deallocate this block. */
4390 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4392 *iprev
= iblk
->next
;
4393 /* Unhook from the free list. */
4394 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4396 n_interval_blocks
--;
4400 num_free
+= this_free
;
4401 iprev
= &iblk
->next
;
4404 total_intervals
= num_used
;
4405 total_free_intervals
= num_free
;
4408 /* Put all unmarked symbols on free list */
4410 register struct symbol_block
*sblk
;
4411 struct symbol_block
**sprev
= &symbol_block
;
4412 register int lim
= symbol_block_index
;
4413 register int num_free
= 0, num_used
= 0;
4415 symbol_free_list
= 0;
4417 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4421 for (i
= 0; i
< lim
; i
++)
4422 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4424 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4425 symbol_free_list
= &sblk
->symbols
[i
];
4427 symbol_free_list
->function
= Vdead
;
4434 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4435 UNMARK_STRING (sblk
->symbols
[i
].name
);
4436 XUNMARK (sblk
->symbols
[i
].plist
);
4438 lim
= SYMBOL_BLOCK_SIZE
;
4439 /* If this block contains only free symbols and we have already
4440 seen more than two blocks worth of free symbols then deallocate
4442 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4444 *sprev
= sblk
->next
;
4445 /* Unhook from the free list. */
4446 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4452 num_free
+= this_free
;
4453 sprev
= &sblk
->next
;
4456 total_symbols
= num_used
;
4457 total_free_symbols
= num_free
;
4460 /* Put all unmarked misc's on free list.
4461 For a marker, first unchain it from the buffer it points into. */
4463 register struct marker_block
*mblk
;
4464 struct marker_block
**mprev
= &marker_block
;
4465 register int lim
= marker_block_index
;
4466 register int num_free
= 0, num_used
= 0;
4468 marker_free_list
= 0;
4470 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4474 EMACS_INT already_free
= -1;
4476 for (i
= 0; i
< lim
; i
++)
4478 Lisp_Object
*markword
;
4479 switch (mblk
->markers
[i
].u_marker
.type
)
4481 case Lisp_Misc_Marker
:
4482 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4484 case Lisp_Misc_Buffer_Local_Value
:
4485 case Lisp_Misc_Some_Buffer_Local_Value
:
4486 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4488 case Lisp_Misc_Overlay
:
4489 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4491 case Lisp_Misc_Free
:
4492 /* If the object was already free, keep it
4493 on the free list. */
4494 markword
= (Lisp_Object
*) &already_free
;
4500 if (markword
&& !XMARKBIT (*markword
))
4503 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4505 /* tem1 avoids Sun compiler bug */
4506 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4507 XSETMARKER (tem
, tem1
);
4508 unchain_marker (tem
);
4510 /* Set the type of the freed object to Lisp_Misc_Free.
4511 We could leave the type alone, since nobody checks it,
4512 but this might catch bugs faster. */
4513 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4514 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4515 marker_free_list
= &mblk
->markers
[i
];
4522 XUNMARK (*markword
);
4525 lim
= MARKER_BLOCK_SIZE
;
4526 /* If this block contains only free markers and we have already
4527 seen more than two blocks worth of free markers then deallocate
4529 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4531 *mprev
= mblk
->next
;
4532 /* Unhook from the free list. */
4533 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4539 num_free
+= this_free
;
4540 mprev
= &mblk
->next
;
4544 total_markers
= num_used
;
4545 total_free_markers
= num_free
;
4548 /* Free all unmarked buffers */
4550 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4553 if (!XMARKBIT (buffer
->name
))
4556 prev
->next
= buffer
->next
;
4558 all_buffers
= buffer
->next
;
4559 next
= buffer
->next
;
4565 XUNMARK (buffer
->name
);
4566 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4567 prev
= buffer
, buffer
= buffer
->next
;
4571 /* Free all unmarked vectors */
4573 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4574 total_vector_size
= 0;
4577 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4580 prev
->next
= vector
->next
;
4582 all_vectors
= vector
->next
;
4583 next
= vector
->next
;
4591 vector
->size
&= ~ARRAY_MARK_FLAG
;
4592 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4593 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4595 total_vector_size
+= vector
->size
;
4596 prev
= vector
, vector
= vector
->next
;
4604 /* Debugging aids. */
4606 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4607 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4608 This may be helpful in debugging Emacs's memory usage.\n\
4609 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4614 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4619 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4620 "Return a list of counters that measure how much consing there has been.\n\
4621 Each of these counters increments for a certain kind of object.\n\
4622 The counters wrap around from the largest positive integer to zero.\n\
4623 Garbage collection does not decrease them.\n\
4624 The elements of the value are as follows:\n\
4625 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4626 All are in units of 1 = one object consed\n\
4627 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4629 MISCS include overlays, markers, and some internal types.\n\
4630 Frames, windows, buffers, and subprocesses count as vectors\n\
4631 (but the contents of a buffer's text do not count here).")
4634 Lisp_Object consed
[8];
4637 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4639 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4641 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4643 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4645 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4647 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4649 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4651 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4653 return Flist (8, consed
);
4656 int suppress_checking
;
4658 die (msg
, file
, line
)
4663 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4668 /* Initialization */
4673 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4677 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4680 pure_size
= PURESIZE
;
4683 ignore_warnings
= 1;
4684 #ifdef DOUG_LEA_MALLOC
4685 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4686 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4687 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4697 malloc_hysteresis
= 32;
4699 malloc_hysteresis
= 0;
4702 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4704 ignore_warnings
= 0;
4706 byte_stack_list
= 0;
4708 consing_since_gc
= 0;
4709 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4710 #ifdef VIRT_ADDR_VARIES
4711 malloc_sbrk_unused
= 1<<22; /* A large number */
4712 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4713 #endif /* VIRT_ADDR_VARIES */
4720 byte_stack_list
= 0;
4722 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4723 setjmp_tested_p
= longjmps_done
= 0;
4731 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4732 "*Number of bytes of consing between garbage collections.\n\
4733 Garbage collection can happen automatically once this many bytes have been\n\
4734 allocated since the last garbage collection. All data types count.\n\n\
4735 Garbage collection happens automatically only when `eval' is called.\n\n\
4736 By binding this temporarily to a large number, you can effectively\n\
4737 prevent garbage collection during a part of the program.");
4739 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4740 "Number of bytes of sharable Lisp data allocated so far.");
4742 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4743 "Number of cons cells that have been consed so far.");
4745 DEFVAR_INT ("floats-consed", &floats_consed
,
4746 "Number of floats that have been consed so far.");
4748 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4749 "Number of vector cells that have been consed so far.");
4751 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4752 "Number of symbols that have been consed so far.");
4754 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4755 "Number of string characters that have been consed so far.");
4757 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4758 "Number of miscellaneous objects that have been consed so far.");
4760 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4761 "Number of intervals that have been consed so far.");
4763 DEFVAR_INT ("strings-consed", &strings_consed
,
4764 "Number of strings that have been consed so far.");
4766 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4767 "Non-nil means loading Lisp code in order to dump an executable.\n\
4768 This means that certain objects should be allocated in shared (pure) space.");
4770 DEFVAR_INT ("undo-limit", &undo_limit
,
4771 "Keep no more undo information once it exceeds this size.\n\
4772 This limit is applied when garbage collection happens.\n\
4773 The size is counted as the number of bytes occupied,\n\
4774 which includes both saved text and other data.");
4777 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
4778 "Don't keep more than this much size of undo information.\n\
4779 A command which pushes past this size is itself forgotten.\n\
4780 This limit is applied when garbage collection happens.\n\
4781 The size is counted as the number of bytes occupied,\n\
4782 which includes both saved text and other data.");
4783 undo_strong_limit
= 30000;
4785 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
4786 "Non-nil means display messages at start and end of garbage collection.");
4787 garbage_collection_messages
= 0;
4789 /* We build this in advance because if we wait until we need it, we might
4790 not be able to allocate the memory to hold it. */
4792 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
4793 staticpro (&memory_signal_data
);
4795 staticpro (&Qgc_cons_threshold
);
4796 Qgc_cons_threshold
= intern ("gc-cons-threshold");
4798 staticpro (&Qchar_table_extra_slots
);
4799 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
4804 defsubr (&Smake_byte_code
);
4805 defsubr (&Smake_list
);
4806 defsubr (&Smake_vector
);
4807 defsubr (&Smake_char_table
);
4808 defsubr (&Smake_string
);
4809 defsubr (&Smake_bool_vector
);
4810 defsubr (&Smake_symbol
);
4811 defsubr (&Smake_marker
);
4812 defsubr (&Spurecopy
);
4813 defsubr (&Sgarbage_collect
);
4814 defsubr (&Smemory_limit
);
4815 defsubr (&Smemory_use_counts
);
4817 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4818 defsubr (&Sgc_status
);