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) ((S)->size |= MARKBIT)
101 #define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
102 #define STRING_MARKED_P(S) ((S)->size & MARKBIT)
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); \
802 /* Number support. If NO_UNION_TYPE isn't in effect, we
803 can't create number objects in macros. */
811 obj
.s
.type
= Lisp_Int
;
816 /***********************************************************************
818 ***********************************************************************/
820 /* Lisp_Strings are allocated in string_block structures. When a new
821 string_block is allocated, all the Lisp_Strings it contains are
822 added to a free-list stiing_free_list. When a new Lisp_String is
823 needed, it is taken from that list. During the sweep phase of GC,
824 string_blocks that are entirely free are freed, except two which
827 String data is allocated from sblock structures. Strings larger
828 than LARGE_STRING_BYTES, get their own sblock, data for smaller
829 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
831 Sblocks consist internally of sdata structures, one for each
832 Lisp_String. The sdata structure points to the Lisp_String it
833 belongs to. The Lisp_String points back to the `u.data' member of
836 When a Lisp_String is freed during GC, it is put back on
837 string_free_list, and its `data' member and its sdata's `string'
838 pointer is set to null. The size of the string is recorded in the
839 `u.nbytes' member of the sdata. So, sdata structures that are no
840 longer used, can be easily recognized, and it's easy to compact the
841 sblocks of small strings which we do in compact_small_strings. */
843 /* Size in bytes of an sblock structure used for small strings. This
844 is 8192 minus malloc overhead. */
846 #define SBLOCK_SIZE 8188
848 /* Strings larger than this are considered large strings. String data
849 for large strings is allocated from individual sblocks. */
851 #define LARGE_STRING_BYTES 1024
853 /* Structure describing string memory sub-allocated from an sblock.
854 This is where the contents of Lisp strings are stored. */
858 /* Back-pointer to the string this sdata belongs to. If null, this
859 structure is free, and the NBYTES member of the union below
860 contains the string's byte size (the same value that STRING_BYTES
861 would return if STRING were non-null). If non-null, STRING_BYTES
862 (STRING) is the size of the data, and DATA contains the string's
864 struct Lisp_String
*string
;
868 /* When STRING in non-null. */
869 unsigned char data
[1];
871 /* When STRING is null. */
876 /* Structure describing a block of memory which is sub-allocated to
877 obtain string data memory for strings. Blocks for small strings
878 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
879 as large as needed. */
886 /* Pointer to the next free sdata block. This points past the end
887 of the sblock if there isn't any space left in this block. */
888 struct sdata
*next_free
;
891 struct sdata first_data
;
894 /* Number of Lisp strings in a string_block structure. The 1020 is
895 1024 minus malloc overhead. */
897 #define STRINGS_IN_STRING_BLOCK \
898 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
900 /* Structure describing a block from which Lisp_String structures
905 struct string_block
*next
;
906 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
909 /* Head and tail of the list of sblock structures holding Lisp string
910 data. We always allocate from current_sblock. The NEXT pointers
911 in the sblock structures go from oldest_sblock to current_sblock. */
913 static struct sblock
*oldest_sblock
, *current_sblock
;
915 /* List of sblocks for large strings. */
917 static struct sblock
*large_sblocks
;
919 /* List of string_block structures, and how many there are. */
921 static struct string_block
*string_blocks
;
922 static int n_string_blocks
;
924 /* Free-list of Lisp_Strings. */
926 static struct Lisp_String
*string_free_list
;
928 /* Number of live and free Lisp_Strings. */
930 static int total_strings
, total_free_strings
;
932 /* Number of bytes used by live strings. */
934 static int total_string_size
;
936 /* Given a pointer to a Lisp_String S which is on the free-list
937 string_free_list, return a pointer to its successor in the
940 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
942 /* Return a pointer to the sdata structure belonging to Lisp string S.
943 S must be live, i.e. S->data must not be null. S->data is actually
944 a pointer to the `u.data' member of its sdata structure; the
945 structure starts at a constant offset in front of that. */
947 #define SDATA_OF_STRING(S) \
948 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
950 /* Value is the size of an sdata structure large enough to hold NBYTES
951 bytes of string data. The value returned includes a terminating
952 NUL byte, the size of the sdata structure, and padding. */
954 #define SDATA_SIZE(NBYTES) \
955 ((sizeof (struct Lisp_String *) \
957 + sizeof (EMACS_INT) - 1) \
958 & ~(sizeof (EMACS_INT) - 1))
961 /* Initialize string allocation. Called from init_alloc_once. */
966 total_strings
= total_free_strings
= total_string_size
= 0;
967 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
968 string_blocks
= NULL
;
970 string_free_list
= NULL
;
974 /* Return a new Lisp_String. */
976 static struct Lisp_String
*
979 struct Lisp_String
*s
;
981 /* If the free-list is empty, allocate a new string_block, and
982 add all the Lisp_Strings in it to the free-list. */
983 if (string_free_list
== NULL
)
985 struct string_block
*b
;
988 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
989 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
990 bzero (b
, sizeof *b
);
991 b
->next
= string_blocks
;
995 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
998 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
999 string_free_list
= s
;
1002 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
1005 /* Pop a Lisp_String off the free-list. */
1006 s
= string_free_list
;
1007 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1009 /* Probably not strictly necessary, but play it safe. */
1010 bzero (s
, sizeof *s
);
1012 --total_free_strings
;
1015 consing_since_gc
+= sizeof *s
;
1021 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1022 plus a NUL byte at the end. Allocate an sdata structure for S, and
1023 set S->data to its `u.data' member. Store a NUL byte at the end of
1024 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1025 S->data if it was initially non-null. */
1028 allocate_string_data (s
, nchars
, nbytes
)
1029 struct Lisp_String
*s
;
1036 /* Determine the number of bytes needed to store NBYTES bytes
1038 needed
= SDATA_SIZE (nbytes
);
1040 if (nbytes
> LARGE_STRING_BYTES
)
1042 int size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1044 #ifdef DOUG_LEA_MALLOC
1045 /* Prevent mmap'ing the chunk (which is potentially very large). */
1046 mallopt (M_MMAP_MAX
, 0);
1049 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1051 #ifdef DOUG_LEA_MALLOC
1052 /* Back to a reasonable maximum of mmap'ed areas. */
1053 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1056 b
->next_free
= &b
->first_data
;
1057 b
->first_data
.string
= NULL
;
1058 b
->next
= large_sblocks
;
1061 else if (current_sblock
== NULL
1062 || (((char *) current_sblock
+ SBLOCK_SIZE
1063 - (char *) current_sblock
->next_free
)
1066 /* Not enough room in the current sblock. */
1067 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1068 b
->next_free
= &b
->first_data
;
1069 b
->first_data
.string
= NULL
;
1073 current_sblock
->next
= b
;
1081 /* If S had already data assigned, mark that as free by setting
1082 its string back-pointer to null, and recording the size of
1086 data
= SDATA_OF_STRING (s
);
1087 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1088 data
->string
= NULL
;
1091 data
= b
->next_free
;
1093 s
->data
= data
->u
.data
;
1095 s
->size_byte
= nbytes
;
1096 s
->data
[nbytes
] = '\0';
1097 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1099 consing_since_gc
+= needed
;
1103 /* Sweep and compact strings. */
1108 struct string_block
*b
, *next
;
1109 struct string_block
*live_blocks
= NULL
;
1111 string_free_list
= NULL
;
1112 total_strings
= total_free_strings
= 0;
1113 total_string_size
= 0;
1115 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1116 for (b
= string_blocks
; b
; b
= next
)
1119 struct Lisp_String
*free_list_before
= string_free_list
;
1123 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1125 struct Lisp_String
*s
= b
->strings
+ i
;
1129 /* String was not on free-list before. */
1130 if (STRING_MARKED_P (s
))
1132 /* String is live; unmark it and its intervals. */
1135 if (!NULL_INTERVAL_P (s
->intervals
))
1136 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1139 total_string_size
+= STRING_BYTES (s
);
1143 /* String is dead. Put it on the free-list. */
1144 struct sdata
*data
= SDATA_OF_STRING (s
);
1146 /* Save the size of S in its sdata so that we know
1147 how large that is. Reset the sdata's string
1148 back-pointer so that we know it's free. */
1149 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1150 data
->string
= NULL
;
1152 /* Reset the strings's `data' member so that we
1156 /* Put the string on the free-list. */
1157 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1158 string_free_list
= s
;
1164 /* S was on the free-list before. Put it there again. */
1165 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1166 string_free_list
= s
;
1171 /* Free blocks that contain free Lisp_Strings only, except
1172 the first two of them. */
1173 if (nfree
== STRINGS_IN_STRING_BLOCK
1174 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1178 string_free_list
= free_list_before
;
1182 total_free_strings
+= nfree
;
1183 b
->next
= live_blocks
;
1188 string_blocks
= live_blocks
;
1189 free_large_strings ();
1190 compact_small_strings ();
1194 /* Free dead large strings. */
1197 free_large_strings ()
1199 struct sblock
*b
, *next
;
1200 struct sblock
*live_blocks
= NULL
;
1202 for (b
= large_sblocks
; b
; b
= next
)
1206 if (b
->first_data
.string
== NULL
)
1210 b
->next
= live_blocks
;
1215 large_sblocks
= live_blocks
;
1219 /* Compact data of small strings. Free sblocks that don't contain
1220 data of live strings after compaction. */
1223 compact_small_strings ()
1225 struct sblock
*b
, *tb
, *next
;
1226 struct sdata
*from
, *to
, *end
, *tb_end
;
1227 struct sdata
*to_end
, *from_end
;
1229 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1230 to, and TB_END is the end of TB. */
1232 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1233 to
= &tb
->first_data
;
1235 /* Step through the blocks from the oldest to the youngest. We
1236 expect that old blocks will stabilize over time, so that less
1237 copying will happen this way. */
1238 for (b
= oldest_sblock
; b
; b
= b
->next
)
1241 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1243 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1245 /* Compute the next FROM here because copying below may
1246 overwrite data we need to compute it. */
1250 nbytes
= GC_STRING_BYTES (from
->string
);
1252 nbytes
= from
->u
.nbytes
;
1254 nbytes
= SDATA_SIZE (nbytes
);
1255 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1257 /* FROM->string non-null means it's alive. Copy its data. */
1260 /* If TB is full, proceed with the next sblock. */
1261 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1262 if (to_end
> tb_end
)
1266 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1267 to
= &tb
->first_data
;
1268 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1271 /* Copy, and update the string's `data' pointer. */
1274 bcopy (from
, to
, nbytes
);
1275 to
->string
->data
= to
->u
.data
;
1278 /* Advance past the sdata we copied to. */
1284 /* The rest of the sblocks following TB don't contain live data, so
1285 we can free them. */
1286 for (b
= tb
->next
; b
; b
= next
)
1294 current_sblock
= tb
;
1298 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1299 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1300 Both LENGTH and INIT must be numbers.")
1302 Lisp_Object length
, init
;
1304 register Lisp_Object val
;
1305 register unsigned char *p
, *end
;
1308 CHECK_NATNUM (length
, 0);
1309 CHECK_NUMBER (init
, 1);
1312 if (SINGLE_BYTE_CHAR_P (c
))
1314 nbytes
= XINT (length
);
1315 val
= make_uninit_string (nbytes
);
1316 p
= XSTRING (val
)->data
;
1317 end
= p
+ XSTRING (val
)->size
;
1323 unsigned char str
[4];
1324 int len
= CHAR_STRING (c
, str
);
1326 nbytes
= len
* XINT (length
);
1327 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1328 p
= XSTRING (val
)->data
;
1332 bcopy (str
, p
, len
);
1342 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1343 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1344 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1346 Lisp_Object length
, init
;
1348 register Lisp_Object val
;
1349 struct Lisp_Bool_Vector
*p
;
1351 int length_in_chars
, length_in_elts
, bits_per_value
;
1353 CHECK_NATNUM (length
, 0);
1355 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1357 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1358 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1360 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1361 slot `size' of the struct Lisp_Bool_Vector. */
1362 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1363 p
= XBOOL_VECTOR (val
);
1365 /* Get rid of any bits that would cause confusion. */
1367 XSETBOOL_VECTOR (val
, p
);
1368 p
->size
= XFASTINT (length
);
1370 real_init
= (NILP (init
) ? 0 : -1);
1371 for (i
= 0; i
< length_in_chars
; i
++)
1372 p
->data
[i
] = real_init
;
1374 /* Clear the extraneous bits in the last byte. */
1375 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1376 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1377 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1383 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1384 of characters from the contents. This string may be unibyte or
1385 multibyte, depending on the contents. */
1388 make_string (contents
, nbytes
)
1392 register Lisp_Object val
;
1393 int nchars
, multibyte_nbytes
;
1395 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1396 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1397 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1398 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1399 /* CONTENTS contains no multibyte sequences or contains an invalid
1400 multibyte sequence. We must make unibyte string. */
1401 SET_STRING_BYTES (XSTRING (val
), -1);
1406 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1409 make_unibyte_string (contents
, length
)
1413 register Lisp_Object val
;
1414 val
= make_uninit_string (length
);
1415 bcopy (contents
, XSTRING (val
)->data
, length
);
1416 SET_STRING_BYTES (XSTRING (val
), -1);
1421 /* Make a multibyte string from NCHARS characters occupying NBYTES
1422 bytes at CONTENTS. */
1425 make_multibyte_string (contents
, nchars
, nbytes
)
1429 register Lisp_Object val
;
1430 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1431 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1436 /* Make a string from NCHARS characters occupying NBYTES bytes at
1437 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1440 make_string_from_bytes (contents
, nchars
, nbytes
)
1444 register Lisp_Object val
;
1445 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1446 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1447 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1448 SET_STRING_BYTES (XSTRING (val
), -1);
1453 /* Make a string from NCHARS characters occupying NBYTES bytes at
1454 CONTENTS. The argument MULTIBYTE controls whether to label the
1455 string as multibyte. */
1458 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1463 register Lisp_Object val
;
1464 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1465 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1467 SET_STRING_BYTES (XSTRING (val
), -1);
1472 /* Make a string from the data at STR, treating it as multibyte if the
1479 return make_string (str
, strlen (str
));
1483 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1484 occupying LENGTH bytes. */
1487 make_uninit_string (length
)
1491 val
= make_uninit_multibyte_string (length
, length
);
1492 SET_STRING_BYTES (XSTRING (val
), -1);
1497 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1498 which occupy NBYTES bytes. */
1501 make_uninit_multibyte_string (nchars
, nbytes
)
1505 struct Lisp_String
*s
;
1510 s
= allocate_string ();
1511 allocate_string_data (s
, nchars
, nbytes
);
1512 XSETSTRING (string
, s
);
1513 string_chars_consed
+= nbytes
;
1519 /***********************************************************************
1521 ***********************************************************************/
1523 /* We store float cells inside of float_blocks, allocating a new
1524 float_block with malloc whenever necessary. Float cells reclaimed
1525 by GC are put on a free list to be reallocated before allocating
1526 any new float cells from the latest float_block.
1528 Each float_block is just under 1020 bytes long, since malloc really
1529 allocates in units of powers of two and uses 4 bytes for its own
1532 #define FLOAT_BLOCK_SIZE \
1533 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1537 struct float_block
*next
;
1538 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1541 /* Current float_block. */
1543 struct float_block
*float_block
;
1545 /* Index of first unused Lisp_Float in the current float_block. */
1547 int float_block_index
;
1549 /* Total number of float blocks now in use. */
1553 /* Free-list of Lisp_Floats. */
1555 struct Lisp_Float
*float_free_list
;
1558 /* Initialze float allocation. */
1563 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1565 float_block
->next
= 0;
1566 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1567 float_block_index
= 0;
1568 float_free_list
= 0;
1573 /* Explicitly free a float cell by putting it on the free-list. */
1577 struct Lisp_Float
*ptr
;
1579 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1583 float_free_list
= ptr
;
1587 /* Return a new float object with value FLOAT_VALUE. */
1590 make_float (float_value
)
1593 register Lisp_Object val
;
1595 if (float_free_list
)
1597 /* We use the data field for chaining the free list
1598 so that we won't use the same field that has the mark bit. */
1599 XSETFLOAT (val
, float_free_list
);
1600 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1604 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1606 register struct float_block
*new;
1608 new = (struct float_block
*) lisp_malloc (sizeof *new,
1610 VALIDATE_LISP_STORAGE (new, sizeof *new);
1611 new->next
= float_block
;
1613 float_block_index
= 0;
1616 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1619 XFLOAT_DATA (val
) = float_value
;
1620 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1621 consing_since_gc
+= sizeof (struct Lisp_Float
);
1628 /***********************************************************************
1630 ***********************************************************************/
1632 /* We store cons cells inside of cons_blocks, allocating a new
1633 cons_block with malloc whenever necessary. Cons cells reclaimed by
1634 GC are put on a free list to be reallocated before allocating
1635 any new cons cells from the latest cons_block.
1637 Each cons_block is just under 1020 bytes long,
1638 since malloc really allocates in units of powers of two
1639 and uses 4 bytes for its own overhead. */
1641 #define CONS_BLOCK_SIZE \
1642 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1646 struct cons_block
*next
;
1647 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1650 /* Current cons_block. */
1652 struct cons_block
*cons_block
;
1654 /* Index of first unused Lisp_Cons in the current block. */
1656 int cons_block_index
;
1658 /* Free-list of Lisp_Cons structures. */
1660 struct Lisp_Cons
*cons_free_list
;
1662 /* Total number of cons blocks now in use. */
1667 /* Initialize cons allocation. */
1672 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1674 cons_block
->next
= 0;
1675 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1676 cons_block_index
= 0;
1682 /* Explicitly free a cons cell by putting it on the free-list. */
1686 struct Lisp_Cons
*ptr
;
1688 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1692 cons_free_list
= ptr
;
1696 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
1697 "Create a new cons, give it CAR and CDR as components, and return it.")
1699 Lisp_Object car
, cdr
;
1701 register Lisp_Object val
;
1705 /* We use the cdr for chaining the free list
1706 so that we won't use the same field that has the mark bit. */
1707 XSETCONS (val
, cons_free_list
);
1708 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
1712 if (cons_block_index
== CONS_BLOCK_SIZE
)
1714 register struct cons_block
*new;
1715 new = (struct cons_block
*) lisp_malloc (sizeof *new,
1717 VALIDATE_LISP_STORAGE (new, sizeof *new);
1718 new->next
= cons_block
;
1720 cons_block_index
= 0;
1723 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
1728 consing_since_gc
+= sizeof (struct Lisp_Cons
);
1729 cons_cells_consed
++;
1734 /* Make a list of 2, 3, 4 or 5 specified objects. */
1738 Lisp_Object arg1
, arg2
;
1740 return Fcons (arg1
, Fcons (arg2
, Qnil
));
1745 list3 (arg1
, arg2
, arg3
)
1746 Lisp_Object arg1
, arg2
, arg3
;
1748 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
1753 list4 (arg1
, arg2
, arg3
, arg4
)
1754 Lisp_Object arg1
, arg2
, arg3
, arg4
;
1756 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
1761 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
1762 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
1764 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
1765 Fcons (arg5
, Qnil
)))));
1769 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
1770 "Return a newly created list with specified arguments as elements.\n\
1771 Any number of arguments, even zero arguments, are allowed.")
1774 register Lisp_Object
*args
;
1776 register Lisp_Object val
;
1782 val
= Fcons (args
[nargs
], val
);
1788 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
1789 "Return a newly created list of length LENGTH, with each element being INIT.")
1791 register Lisp_Object length
, init
;
1793 register Lisp_Object val
;
1796 CHECK_NATNUM (length
, 0);
1797 size
= XFASTINT (length
);
1801 val
= Fcons (init
, val
);
1807 /***********************************************************************
1809 ***********************************************************************/
1811 /* Singly-linked list of all vectors. */
1813 struct Lisp_Vector
*all_vectors
;
1815 /* Total number of vector-like objects now in use. */
1820 /* Value is a pointer to a newly allocated Lisp_Vector structure
1821 with room for LEN Lisp_Objects. */
1823 struct Lisp_Vector
*
1824 allocate_vectorlike (len
)
1827 struct Lisp_Vector
*p
;
1830 #ifdef DOUG_LEA_MALLOC
1831 /* Prevent mmap'ing the chunk (which is potentially very large).. */
1832 mallopt (M_MMAP_MAX
, 0);
1835 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
1836 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
1838 #ifdef DOUG_LEA_MALLOC
1839 /* Back to a reasonable maximum of mmap'ed areas. */
1840 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1843 VALIDATE_LISP_STORAGE (p
, 0);
1844 consing_since_gc
+= nbytes
;
1845 vector_cells_consed
+= len
;
1847 p
->next
= all_vectors
;
1854 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
1855 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1856 See also the function `vector'.")
1858 register Lisp_Object length
, init
;
1861 register EMACS_INT sizei
;
1863 register struct Lisp_Vector
*p
;
1865 CHECK_NATNUM (length
, 0);
1866 sizei
= XFASTINT (length
);
1868 p
= allocate_vectorlike (sizei
);
1870 for (index
= 0; index
< sizei
; index
++)
1871 p
->contents
[index
] = init
;
1873 XSETVECTOR (vector
, p
);
1878 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
1879 "Return a newly created char-table, with purpose PURPOSE.\n\
1880 Each element is initialized to INIT, which defaults to nil.\n\
1881 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
1882 The property's value should be an integer between 0 and 10.")
1884 register Lisp_Object purpose
, init
;
1888 CHECK_SYMBOL (purpose
, 1);
1889 n
= Fget (purpose
, Qchar_table_extra_slots
);
1890 CHECK_NUMBER (n
, 0);
1891 if (XINT (n
) < 0 || XINT (n
) > 10)
1892 args_out_of_range (n
, Qnil
);
1893 /* Add 2 to the size for the defalt and parent slots. */
1894 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
1896 XCHAR_TABLE (vector
)->top
= Qt
;
1897 XCHAR_TABLE (vector
)->parent
= Qnil
;
1898 XCHAR_TABLE (vector
)->purpose
= purpose
;
1899 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1904 /* Return a newly created sub char table with default value DEFALT.
1905 Since a sub char table does not appear as a top level Emacs Lisp
1906 object, we don't need a Lisp interface to make it. */
1909 make_sub_char_table (defalt
)
1913 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
1914 XCHAR_TABLE (vector
)->top
= Qnil
;
1915 XCHAR_TABLE (vector
)->defalt
= defalt
;
1916 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1921 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
1922 "Return a newly created vector with specified arguments as elements.\n\
1923 Any number of arguments, even zero arguments, are allowed.")
1928 register Lisp_Object len
, val
;
1930 register struct Lisp_Vector
*p
;
1932 XSETFASTINT (len
, nargs
);
1933 val
= Fmake_vector (len
, Qnil
);
1935 for (index
= 0; index
< nargs
; index
++)
1936 p
->contents
[index
] = args
[index
];
1941 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
1942 "Create a byte-code object with specified arguments as elements.\n\
1943 The arguments should be the arglist, bytecode-string, constant vector,\n\
1944 stack size, (optional) doc string, and (optional) interactive spec.\n\
1945 The first four arguments are required; at most six have any\n\
1951 register Lisp_Object len
, val
;
1953 register struct Lisp_Vector
*p
;
1955 XSETFASTINT (len
, nargs
);
1956 if (!NILP (Vpurify_flag
))
1957 val
= make_pure_vector ((EMACS_INT
) nargs
);
1959 val
= Fmake_vector (len
, Qnil
);
1961 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
1962 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
1963 earlier because they produced a raw 8-bit string for byte-code
1964 and now such a byte-code string is loaded as multibyte while
1965 raw 8-bit characters converted to multibyte form. Thus, now we
1966 must convert them back to the original unibyte form. */
1967 args
[1] = Fstring_as_unibyte (args
[1]);
1970 for (index
= 0; index
< nargs
; index
++)
1972 if (!NILP (Vpurify_flag
))
1973 args
[index
] = Fpurecopy (args
[index
]);
1974 p
->contents
[index
] = args
[index
];
1976 XSETCOMPILED (val
, p
);
1982 /***********************************************************************
1984 ***********************************************************************/
1986 /* Each symbol_block is just under 1020 bytes long, since malloc
1987 really allocates in units of powers of two and uses 4 bytes for its
1990 #define SYMBOL_BLOCK_SIZE \
1991 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
1995 struct symbol_block
*next
;
1996 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
1999 /* Current symbol block and index of first unused Lisp_Symbol
2002 struct symbol_block
*symbol_block
;
2003 int symbol_block_index
;
2005 /* List of free symbols. */
2007 struct Lisp_Symbol
*symbol_free_list
;
2009 /* Total number of symbol blocks now in use. */
2011 int n_symbol_blocks
;
2014 /* Initialize symbol allocation. */
2019 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
2021 symbol_block
->next
= 0;
2022 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
2023 symbol_block_index
= 0;
2024 symbol_free_list
= 0;
2025 n_symbol_blocks
= 1;
2029 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2030 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2031 Its value and function definition are void, and its property list is nil.")
2035 register Lisp_Object val
;
2036 register struct Lisp_Symbol
*p
;
2038 CHECK_STRING (name
, 0);
2040 if (symbol_free_list
)
2042 XSETSYMBOL (val
, symbol_free_list
);
2043 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2047 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2049 struct symbol_block
*new;
2050 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2052 VALIDATE_LISP_STORAGE (new, sizeof *new);
2053 new->next
= symbol_block
;
2055 symbol_block_index
= 0;
2058 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2062 p
->name
= XSTRING (name
);
2065 p
->value
= Qunbound
;
2066 p
->function
= Qunbound
;
2068 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2075 /***********************************************************************
2076 Marker (Misc) Allocation
2077 ***********************************************************************/
2079 /* Allocation of markers and other objects that share that structure.
2080 Works like allocation of conses. */
2082 #define MARKER_BLOCK_SIZE \
2083 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2087 struct marker_block
*next
;
2088 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2091 struct marker_block
*marker_block
;
2092 int marker_block_index
;
2094 union Lisp_Misc
*marker_free_list
;
2096 /* Total number of marker blocks now in use. */
2098 int n_marker_blocks
;
2103 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2105 marker_block
->next
= 0;
2106 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2107 marker_block_index
= 0;
2108 marker_free_list
= 0;
2109 n_marker_blocks
= 1;
2112 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2119 if (marker_free_list
)
2121 XSETMISC (val
, marker_free_list
);
2122 marker_free_list
= marker_free_list
->u_free
.chain
;
2126 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2128 struct marker_block
*new;
2129 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2131 VALIDATE_LISP_STORAGE (new, sizeof *new);
2132 new->next
= marker_block
;
2134 marker_block_index
= 0;
2137 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2140 consing_since_gc
+= sizeof (union Lisp_Misc
);
2141 misc_objects_consed
++;
2145 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2146 "Return a newly allocated marker which does not point at any place.")
2149 register Lisp_Object val
;
2150 register struct Lisp_Marker
*p
;
2152 val
= allocate_misc ();
2153 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2159 p
->insertion_type
= 0;
2163 /* Put MARKER back on the free list after using it temporarily. */
2166 free_marker (marker
)
2169 unchain_marker (marker
);
2171 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2172 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2173 marker_free_list
= XMISC (marker
);
2175 total_free_markers
++;
2179 /* Return a newly created vector or string with specified arguments as
2180 elements. If all the arguments are characters that can fit
2181 in a string of events, make a string; otherwise, make a vector.
2183 Any number of arguments, even zero arguments, are allowed. */
2186 make_event_array (nargs
, args
)
2192 for (i
= 0; i
< nargs
; i
++)
2193 /* The things that fit in a string
2194 are characters that are in 0...127,
2195 after discarding the meta bit and all the bits above it. */
2196 if (!INTEGERP (args
[i
])
2197 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2198 return Fvector (nargs
, args
);
2200 /* Since the loop exited, we know that all the things in it are
2201 characters, so we can make a string. */
2205 result
= Fmake_string (make_number (nargs
), make_number (0));
2206 for (i
= 0; i
< nargs
; i
++)
2208 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2209 /* Move the meta bit to the right place for a string char. */
2210 if (XINT (args
[i
]) & CHAR_META
)
2211 XSTRING (result
)->data
[i
] |= 0x80;
2220 /************************************************************************
2222 ************************************************************************/
2227 /* Base address of stack. Set in main. */
2229 Lisp_Object
*stack_base
;
2231 /* A node in the red-black tree describing allocated memory containing
2232 Lisp data. Each such block is recorded with its start and end
2233 address when it is allocated, and removed from the tree when it
2236 A red-black tree is a balanced binary tree with the following
2239 1. Every node is either red or black.
2240 2. Every leaf is black.
2241 3. If a node is red, then both of its children are black.
2242 4. Every simple path from a node to a descendant leaf contains
2243 the same number of black nodes.
2244 5. The root is always black.
2246 When nodes are inserted into the tree, or deleted from the tree,
2247 the tree is "fixed" so that these properties are always true.
2249 A red-black tree with N internal nodes has height at most 2
2250 log(N+1). Searches, insertions and deletions are done in O(log N).
2251 Please see a text book about data structures for a detailed
2252 description of red-black trees. Any book worth its salt should
2257 struct mem_node
*left
, *right
, *parent
;
2259 /* Start and end of allocated region. */
2263 enum {MEM_BLACK
, MEM_RED
} color
;
2269 /* Root of the tree describing allocated Lisp memory. */
2271 static struct mem_node
*mem_root
;
2273 /* Sentinel node of the tree. */
2275 static struct mem_node mem_z
;
2276 #define MEM_NIL &mem_z
2279 /* Initialize this part of alloc.c. */
2284 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2285 mem_z
.parent
= NULL
;
2286 mem_z
.color
= MEM_BLACK
;
2287 mem_z
.start
= mem_z
.end
= NULL
;
2292 /* Value is a pointer to the mem_node containing START. Value is
2293 MEM_NIL if there is no node in the tree containing START. */
2295 static INLINE
struct mem_node
*
2301 /* Make the search always successful to speed up the loop below. */
2302 mem_z
.start
= start
;
2303 mem_z
.end
= (char *) start
+ 1;
2306 while (start
< p
->start
|| start
>= p
->end
)
2307 p
= start
< p
->start
? p
->left
: p
->right
;
2312 /* Insert a new node into the tree for a block of memory with start
2313 address START, end address END, and type TYPE. Value is a
2314 pointer to the node that was inserted. */
2316 static struct mem_node
*
2317 mem_insert (start
, end
, type
)
2321 struct mem_node
*c
, *parent
, *x
;
2323 /* See where in the tree a node for START belongs. In this
2324 particular application, it shouldn't happen that a node is already
2325 present. For debugging purposes, let's check that. */
2329 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2331 while (c
!= MEM_NIL
)
2333 if (start
>= c
->start
&& start
< c
->end
)
2336 c
= start
< c
->start
? c
->left
: c
->right
;
2339 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2341 while (c
!= MEM_NIL
)
2344 c
= start
< c
->start
? c
->left
: c
->right
;
2347 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2349 /* Create a new node. */
2350 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2355 x
->left
= x
->right
= MEM_NIL
;
2358 /* Insert it as child of PARENT or install it as root. */
2361 if (start
< parent
->start
)
2369 /* Re-establish red-black tree properties. */
2370 mem_insert_fixup (x
);
2375 /* Re-establish the red-black properties of the tree, and thereby
2376 balance the tree, after node X has been inserted; X is always red. */
2379 mem_insert_fixup (x
)
2382 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2384 /* X is red and its parent is red. This is a violation of
2385 red-black tree property #3. */
2387 if (x
->parent
== x
->parent
->parent
->left
)
2389 /* We're on the left side of our grandparent, and Y is our
2391 struct mem_node
*y
= x
->parent
->parent
->right
;
2393 if (y
->color
== MEM_RED
)
2395 /* Uncle and parent are red but should be black because
2396 X is red. Change the colors accordingly and proceed
2397 with the grandparent. */
2398 x
->parent
->color
= MEM_BLACK
;
2399 y
->color
= MEM_BLACK
;
2400 x
->parent
->parent
->color
= MEM_RED
;
2401 x
= x
->parent
->parent
;
2405 /* Parent and uncle have different colors; parent is
2406 red, uncle is black. */
2407 if (x
== x
->parent
->right
)
2410 mem_rotate_left (x
);
2413 x
->parent
->color
= MEM_BLACK
;
2414 x
->parent
->parent
->color
= MEM_RED
;
2415 mem_rotate_right (x
->parent
->parent
);
2420 /* This is the symmetrical case of above. */
2421 struct mem_node
*y
= x
->parent
->parent
->left
;
2423 if (y
->color
== MEM_RED
)
2425 x
->parent
->color
= MEM_BLACK
;
2426 y
->color
= MEM_BLACK
;
2427 x
->parent
->parent
->color
= MEM_RED
;
2428 x
= x
->parent
->parent
;
2432 if (x
== x
->parent
->left
)
2435 mem_rotate_right (x
);
2438 x
->parent
->color
= MEM_BLACK
;
2439 x
->parent
->parent
->color
= MEM_RED
;
2440 mem_rotate_left (x
->parent
->parent
);
2445 /* The root may have been changed to red due to the algorithm. Set
2446 it to black so that property #5 is satisfied. */
2447 mem_root
->color
= MEM_BLACK
;
2463 /* Turn y's left sub-tree into x's right sub-tree. */
2466 if (y
->left
!= MEM_NIL
)
2467 y
->left
->parent
= x
;
2469 /* Y's parent was x's parent. */
2471 y
->parent
= x
->parent
;
2473 /* Get the parent to point to y instead of x. */
2476 if (x
== x
->parent
->left
)
2477 x
->parent
->left
= y
;
2479 x
->parent
->right
= y
;
2484 /* Put x on y's left. */
2498 mem_rotate_right (x
)
2501 struct mem_node
*y
= x
->left
;
2504 if (y
->right
!= MEM_NIL
)
2505 y
->right
->parent
= x
;
2508 y
->parent
= x
->parent
;
2511 if (x
== x
->parent
->right
)
2512 x
->parent
->right
= y
;
2514 x
->parent
->left
= y
;
2525 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2531 struct mem_node
*x
, *y
;
2533 if (!z
|| z
== MEM_NIL
)
2536 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2541 while (y
->left
!= MEM_NIL
)
2545 if (y
->left
!= MEM_NIL
)
2550 x
->parent
= y
->parent
;
2553 if (y
== y
->parent
->left
)
2554 y
->parent
->left
= x
;
2556 y
->parent
->right
= x
;
2563 z
->start
= y
->start
;
2568 if (y
->color
== MEM_BLACK
)
2569 mem_delete_fixup (x
);
2574 /* Re-establish the red-black properties of the tree, after a
2578 mem_delete_fixup (x
)
2581 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2583 if (x
== x
->parent
->left
)
2585 struct mem_node
*w
= x
->parent
->right
;
2587 if (w
->color
== MEM_RED
)
2589 w
->color
= MEM_BLACK
;
2590 x
->parent
->color
= MEM_RED
;
2591 mem_rotate_left (x
->parent
);
2592 w
= x
->parent
->right
;
2595 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2602 if (w
->right
->color
== MEM_BLACK
)
2604 w
->left
->color
= MEM_BLACK
;
2606 mem_rotate_right (w
);
2607 w
= x
->parent
->right
;
2609 w
->color
= x
->parent
->color
;
2610 x
->parent
->color
= MEM_BLACK
;
2611 w
->right
->color
= MEM_BLACK
;
2612 mem_rotate_left (x
->parent
);
2618 struct mem_node
*w
= x
->parent
->left
;
2620 if (w
->color
== MEM_RED
)
2622 w
->color
= MEM_BLACK
;
2623 x
->parent
->color
= MEM_RED
;
2624 mem_rotate_right (x
->parent
);
2625 w
= x
->parent
->left
;
2628 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2635 if (w
->left
->color
== MEM_BLACK
)
2637 w
->right
->color
= MEM_BLACK
;
2639 mem_rotate_left (w
);
2640 w
= x
->parent
->left
;
2643 w
->color
= x
->parent
->color
;
2644 x
->parent
->color
= MEM_BLACK
;
2645 w
->left
->color
= MEM_BLACK
;
2646 mem_rotate_right (x
->parent
);
2652 x
->color
= MEM_BLACK
;
2656 /* Value is non-zero if P is a pointer to a live Lisp string on
2657 the heap. M is a pointer to the mem_block for P. */
2660 live_string_p (m
, p
)
2664 if (m
->type
== MEM_TYPE_STRING
)
2666 struct string_block
*b
= (struct string_block
*) m
->start
;
2667 int offset
= (char *) p
- (char *) &b
->strings
[0];
2669 /* P must point to the start of a Lisp_String structure, and it
2670 must not be on the free-list. */
2671 return (offset
% sizeof b
->strings
[0] == 0
2672 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2679 /* Value is non-zero if P is a pointer to a live Lisp cons on
2680 the heap. M is a pointer to the mem_block for P. */
2687 if (m
->type
== MEM_TYPE_CONS
)
2689 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2690 int offset
= (char *) p
- (char *) &b
->conses
[0];
2692 /* P must point to the start of a Lisp_Cons, not be
2693 one of the unused cells in the current cons block,
2694 and not be on the free-list. */
2695 return (offset
% sizeof b
->conses
[0] == 0
2697 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2698 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2705 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2706 the heap. M is a pointer to the mem_block for P. */
2709 live_symbol_p (m
, p
)
2713 if (m
->type
== MEM_TYPE_SYMBOL
)
2715 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2716 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2718 /* P must point to the start of a Lisp_Symbol, not be
2719 one of the unused cells in the current symbol block,
2720 and not be on the free-list. */
2721 return (offset
% sizeof b
->symbols
[0] == 0
2722 && (b
!= symbol_block
2723 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2724 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2731 /* Value is non-zero if P is a pointer to a live Lisp float on
2732 the heap. M is a pointer to the mem_block for P. */
2739 if (m
->type
== MEM_TYPE_FLOAT
)
2741 struct float_block
*b
= (struct float_block
*) m
->start
;
2742 int offset
= (char *) p
- (char *) &b
->floats
[0];
2744 /* P must point to the start of a Lisp_Float, not be
2745 one of the unused cells in the current float block,
2746 and not be on the free-list. */
2747 return (offset
% sizeof b
->floats
[0] == 0
2748 && (b
!= float_block
2749 || offset
/ sizeof b
->floats
[0] < float_block_index
)
2750 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
2757 /* Value is non-zero if P is a pointer to a live Lisp Misc on
2758 the heap. M is a pointer to the mem_block for P. */
2765 if (m
->type
== MEM_TYPE_MISC
)
2767 struct marker_block
*b
= (struct marker_block
*) m
->start
;
2768 int offset
= (char *) p
- (char *) &b
->markers
[0];
2770 /* P must point to the start of a Lisp_Misc, not be
2771 one of the unused cells in the current misc block,
2772 and not be on the free-list. */
2773 return (offset
% sizeof b
->markers
[0] == 0
2774 && (b
!= marker_block
2775 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
2776 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
2783 /* Value is non-zero if P is a pointer to a live vector-like object.
2784 M is a pointer to the mem_block for P. */
2787 live_vector_p (m
, p
)
2791 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
2795 /* Value is non-zero of P is a pointer to a live buffer. M is a
2796 pointer to the mem_block for P. */
2799 live_buffer_p (m
, p
)
2803 /* P must point to the start of the block, and the buffer
2804 must not have been killed. */
2805 return (m
->type
== MEM_TYPE_BUFFER
2807 && !NILP (((struct buffer
*) p
)->name
));
2811 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2813 /* Array of objects that are kept alive because the C stack contains
2814 a pattern that looks like a reference to them . */
2816 #define MAX_ZOMBIES 10
2817 static Lisp_Object zombies
[MAX_ZOMBIES
];
2819 /* Number of zombie objects. */
2821 static int nzombies
;
2823 /* Number of garbage collections. */
2827 /* Average percentage of zombies per collection. */
2829 static double avg_zombies
;
2831 /* Max. number of live and zombie objects. */
2833 static int max_live
, max_zombies
;
2835 /* Average number of live objects per GC. */
2837 static double avg_live
;
2839 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
2840 "Show information about live and zombie objects.")
2843 Lisp_Object args
[7];
2844 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2845 args
[1] = make_number (ngcs
);
2846 args
[2] = make_float (avg_live
);
2847 args
[3] = make_float (avg_zombies
);
2848 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
2849 args
[5] = make_number (max_live
);
2850 args
[6] = make_number (max_zombies
);
2851 return Fmessage (7, args
);
2854 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2857 /* Mark OBJ if we can prove it's a Lisp_Object. */
2860 mark_maybe_object (obj
)
2863 void *po
= (void *) XPNTR (obj
);
2864 struct mem_node
*m
= mem_find (po
);
2870 switch (XGCTYPE (obj
))
2873 mark_p
= (live_string_p (m
, po
)
2874 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
2878 mark_p
= (live_cons_p (m
, po
)
2879 && !XMARKBIT (XCONS (obj
)->car
));
2883 mark_p
= (live_symbol_p (m
, po
)
2884 && !XMARKBIT (XSYMBOL (obj
)->plist
));
2888 mark_p
= (live_float_p (m
, po
)
2889 && !XMARKBIT (XFLOAT (obj
)->type
));
2892 case Lisp_Vectorlike
:
2893 /* Note: can't check GC_BUFFERP before we know it's a
2894 buffer because checking that dereferences the pointer
2895 PO which might point anywhere. */
2896 if (live_vector_p (m
, po
))
2897 mark_p
= (!GC_SUBRP (obj
)
2898 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
2899 else if (live_buffer_p (m
, po
))
2900 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
2904 if (live_misc_p (m
, po
))
2906 switch (XMISCTYPE (obj
))
2908 case Lisp_Misc_Marker
:
2909 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
2912 case Lisp_Misc_Buffer_Local_Value
:
2913 case Lisp_Misc_Some_Buffer_Local_Value
:
2914 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2917 case Lisp_Misc_Overlay
:
2918 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
2927 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2928 if (nzombies
< MAX_ZOMBIES
)
2929 zombies
[nzombies
] = *p
;
2937 /* Mark Lisp objects in the address range START..END. */
2940 mark_memory (start
, end
)
2945 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2949 /* Make START the pointer to the start of the memory region,
2950 if it isn't already. */
2958 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
2959 mark_maybe_object (*p
);
2963 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2965 static int setjmp_tested_p
, longjmps_done
;
2967 #define SETJMP_WILL_LIKELY_WORK "\
2969 Emacs garbage collector has been changed to use conservative stack\n\
2970 marking. Emacs has determined that the method it uses to do the\n\
2971 marking will likely work on your system, but this isn't sure.\n\
2973 If you are a system-programmer, or can get the help of a local wizard\n\
2974 who is, please take a look at the function mark_stack in alloc.c, and\n\
2975 verify that the methods used are appropriate for your system.\n\
2977 Please mail the result to <gerd@gnu.org>.\n\
2980 #define SETJMP_WILL_NOT_WORK "\
2982 Emacs garbage collector has been changed to use conservative stack\n\
2983 marking. Emacs has determined that the default method it uses to do the\n\
2984 marking will not work on your system. We will need a system-dependent\n\
2985 solution for your system.\n\
2987 Please take a look at the function mark_stack in alloc.c, and\n\
2988 try to find a way to make it work on your system.\n\
2989 Please mail the result to <gerd@gnu.org>.\n\
2993 /* Perform a quick check if it looks like setjmp saves registers in a
2994 jmp_buf. Print a message to stderr saying so. When this test
2995 succeeds, this is _not_ a proof that setjmp is sufficient for
2996 conservative stack marking. Only the sources or a disassembly
3007 /* Arrange for X to be put in a register. */
3013 if (longjmps_done
== 1)
3015 /* Came here after the longjmp at the end of the function.
3017 If x == 1, the longjmp has restored the register to its
3018 value before the setjmp, and we can hope that setjmp
3019 saves all such registers in the jmp_buf, although that
3022 For other values of X, either something really strange is
3023 taking place, or the setjmp just didn't save the register. */
3026 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3029 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3036 if (longjmps_done
== 1)
3040 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3043 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3045 /* Abort if anything GCPRO'd doesn't survive the GC. */
3053 for (p
= gcprolist
; p
; p
= p
->next
)
3054 for (i
= 0; i
< p
->nvars
; ++i
)
3055 if (!survives_gc_p (p
->var
[i
]))
3059 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3066 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3067 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3069 fprintf (stderr
, " %d = ", i
);
3070 debug_print (zombies
[i
]);
3074 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3077 /* Mark live Lisp objects on the C stack.
3079 There are several system-dependent problems to consider when
3080 porting this to new architectures:
3084 We have to mark Lisp objects in CPU registers that can hold local
3085 variables or are used to pass parameters.
3087 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3088 something that either saves relevant registers on the stack, or
3089 calls mark_maybe_object passing it each register's contents.
3091 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3092 implementation assumes that calling setjmp saves registers we need
3093 to see in a jmp_buf which itself lies on the stack. This doesn't
3094 have to be true! It must be verified for each system, possibly
3095 by taking a look at the source code of setjmp.
3099 Architectures differ in the way their processor stack is organized.
3100 For example, the stack might look like this
3103 | Lisp_Object | size = 4
3105 | something else | size = 2
3107 | Lisp_Object | size = 4
3111 In such a case, not every Lisp_Object will be aligned equally. To
3112 find all Lisp_Object on the stack it won't be sufficient to walk
3113 the stack in steps of 4 bytes. Instead, two passes will be
3114 necessary, one starting at the start of the stack, and a second
3115 pass starting at the start of the stack + 2. Likewise, if the
3116 minimal alignment of Lisp_Objects on the stack is 1, four passes
3117 would be necessary, each one starting with one byte more offset
3118 from the stack start.
3120 The current code assumes by default that Lisp_Objects are aligned
3121 equally on the stack. */
3127 int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3130 /* This trick flushes the register windows so that all the state of
3131 the process is contained in the stack. */
3136 /* Save registers that we need to see on the stack. We need to see
3137 registers used to hold register variables and registers used to
3139 #ifdef GC_SAVE_REGISTERS_ON_STACK
3140 GC_SAVE_REGISTERS_ON_STACK (end
);
3141 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3143 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3144 setjmp will definitely work, test it
3145 and print a message with the result
3147 if (!setjmp_tested_p
)
3149 setjmp_tested_p
= 1;
3152 #endif /* GC_SETJMP_WORKS */
3155 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3156 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3158 /* This assumes that the stack is a contiguous region in memory. If
3159 that's not the case, something has to be done here to iterate
3160 over the stack segments. */
3161 #if GC_LISP_OBJECT_ALIGNMENT == 1
3162 mark_memory (stack_base
, end
);
3163 mark_memory ((char *) stack_base
+ 1, end
);
3164 mark_memory ((char *) stack_base
+ 2, end
);
3165 mark_memory ((char *) stack_base
+ 3, end
);
3166 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3167 mark_memory (stack_base
, end
);
3168 mark_memory ((char *) stack_base
+ 2, end
);
3170 mark_memory (stack_base
, end
);
3173 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3179 #endif /* GC_MARK_STACK != 0 */
3183 /***********************************************************************
3184 Pure Storage Management
3185 ***********************************************************************/
3187 /* Return a string allocated in pure space. DATA is a buffer holding
3188 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3189 non-zero means make the result string multibyte.
3191 Must get an error if pure storage is full, since if it cannot hold
3192 a large string it may be able to hold conses that point to that
3193 string; then the string is not protected from gc. */
3196 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3202 struct Lisp_String
*s
;
3203 int string_size
, data_size
;
3205 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3207 string_size
= PAD (sizeof (struct Lisp_String
));
3208 data_size
= PAD (nbytes
+ 1);
3212 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3213 error ("Pure Lisp storage exhausted");
3215 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3216 pureptr
+= string_size
;
3217 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3218 pureptr
+= data_size
;
3221 s
->size_byte
= multibyte
? nbytes
: -1;
3222 bcopy (data
, s
->data
, nbytes
);
3223 s
->data
[nbytes
] = '\0';
3224 s
->intervals
= NULL_INTERVAL
;
3226 XSETSTRING (string
, s
);
3231 /* Return a cons allocated from pure space. Give it pure copies
3232 of CAR as car and CDR as cdr. */
3235 pure_cons (car
, cdr
)
3236 Lisp_Object car
, cdr
;
3238 register Lisp_Object
new;
3240 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3241 error ("Pure Lisp storage exhausted");
3242 XSETCONS (new, PUREBEG
+ pureptr
);
3243 pureptr
+= sizeof (struct Lisp_Cons
);
3244 XCAR (new) = Fpurecopy (car
);
3245 XCDR (new) = Fpurecopy (cdr
);
3250 /* Value is a float object with value NUM allocated from pure space. */
3253 make_pure_float (num
)
3256 register Lisp_Object
new;
3258 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3259 (double) boundary. Some architectures (like the sparc) require
3260 this, and I suspect that floats are rare enough that it's no
3261 tragedy for those that do. */
3264 char *p
= PUREBEG
+ pureptr
;
3268 alignment
= __alignof (struct Lisp_Float
);
3270 alignment
= sizeof (struct Lisp_Float
);
3273 alignment
= sizeof (struct Lisp_Float
);
3275 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3276 pureptr
= p
- PUREBEG
;
3279 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3280 error ("Pure Lisp storage exhausted");
3281 XSETFLOAT (new, PUREBEG
+ pureptr
);
3282 pureptr
+= sizeof (struct Lisp_Float
);
3283 XFLOAT_DATA (new) = num
;
3284 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3289 /* Return a vector with room for LEN Lisp_Objects allocated from
3293 make_pure_vector (len
)
3296 register Lisp_Object
new;
3297 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3298 + (len
- 1) * sizeof (Lisp_Object
));
3300 if (pureptr
+ size
> PURESIZE
)
3301 error ("Pure Lisp storage exhausted");
3303 XSETVECTOR (new, PUREBEG
+ pureptr
);
3305 XVECTOR (new)->size
= len
;
3310 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3311 "Make a copy of OBJECT in pure storage.\n\
3312 Recursively copies contents of vectors and cons cells.\n\
3313 Does not copy symbols. Copies strings without text properties.")
3315 register Lisp_Object obj
;
3317 if (NILP (Vpurify_flag
))
3320 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3321 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3325 return pure_cons (XCAR (obj
), XCDR (obj
));
3326 else if (FLOATP (obj
))
3327 return make_pure_float (XFLOAT_DATA (obj
));
3328 else if (STRINGP (obj
))
3329 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3330 STRING_BYTES (XSTRING (obj
)),
3331 STRING_MULTIBYTE (obj
));
3332 else if (COMPILEDP (obj
) || VECTORP (obj
))
3334 register struct Lisp_Vector
*vec
;
3335 register int i
, size
;
3337 size
= XVECTOR (obj
)->size
;
3338 if (size
& PSEUDOVECTOR_FLAG
)
3339 size
&= PSEUDOVECTOR_SIZE_MASK
;
3340 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3341 for (i
= 0; i
< size
; i
++)
3342 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3343 if (COMPILEDP (obj
))
3344 XSETCOMPILED (obj
, vec
);
3346 XSETVECTOR (obj
, vec
);
3349 else if (MARKERP (obj
))
3350 error ("Attempt to copy a marker to pure storage");
3357 /***********************************************************************
3359 ***********************************************************************/
3361 /* Recording what needs to be marked for gc. */
3363 struct gcpro
*gcprolist
;
3365 /* Addresses of staticpro'd variables. */
3367 #define NSTATICS 1024
3368 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3370 /* Index of next unused slot in staticvec. */
3375 /* Put an entry in staticvec, pointing at the variable with address
3379 staticpro (varaddress
)
3380 Lisp_Object
*varaddress
;
3382 staticvec
[staticidx
++] = varaddress
;
3383 if (staticidx
>= NSTATICS
)
3391 struct catchtag
*next
;
3396 struct backtrace
*next
;
3397 Lisp_Object
*function
;
3398 Lisp_Object
*args
; /* Points to vector of args. */
3399 int nargs
; /* Length of vector. */
3400 /* If nargs is UNEVALLED, args points to slot holding list of
3407 /***********************************************************************
3409 ***********************************************************************/
3411 /* Temporarily prevent garbage collection. */
3414 inhibit_garbage_collection ()
3416 int count
= specpdl_ptr
- specpdl
;
3418 int nbits
= min (VALBITS
, BITS_PER_INT
);
3420 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3422 specbind (Qgc_cons_threshold
, number
);
3428 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3429 "Reclaim storage for Lisp objects no longer needed.\n\
3430 Returns info on amount of space in use:\n\
3431 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3432 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3433 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3434 (USED-STRINGS . FREE-STRINGS))\n\
3435 Garbage collection happens automatically if you cons more than\n\
3436 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3439 register struct gcpro
*tail
;
3440 register struct specbinding
*bind
;
3441 struct catchtag
*catch;
3442 struct handler
*handler
;
3443 register struct backtrace
*backlist
;
3444 char stack_top_variable
;
3447 Lisp_Object total
[7];
3449 /* In case user calls debug_print during GC,
3450 don't let that cause a recursive GC. */
3451 consing_since_gc
= 0;
3453 /* Save what's currently displayed in the echo area. */
3454 message_p
= push_message ();
3456 /* Save a copy of the contents of the stack, for debugging. */
3457 #if MAX_SAVE_STACK > 0
3458 if (NILP (Vpurify_flag
))
3460 i
= &stack_top_variable
- stack_bottom
;
3462 if (i
< MAX_SAVE_STACK
)
3464 if (stack_copy
== 0)
3465 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3466 else if (stack_copy_size
< i
)
3467 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3470 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3471 bcopy (stack_bottom
, stack_copy
, i
);
3473 bcopy (&stack_top_variable
, stack_copy
, i
);
3477 #endif /* MAX_SAVE_STACK > 0 */
3479 if (garbage_collection_messages
)
3480 message1_nolog ("Garbage collecting...");
3484 shrink_regexp_cache ();
3486 /* Don't keep undo information around forever. */
3488 register struct buffer
*nextb
= all_buffers
;
3492 /* If a buffer's undo list is Qt, that means that undo is
3493 turned off in that buffer. Calling truncate_undo_list on
3494 Qt tends to return NULL, which effectively turns undo back on.
3495 So don't call truncate_undo_list if undo_list is Qt. */
3496 if (! EQ (nextb
->undo_list
, Qt
))
3498 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3500 nextb
= nextb
->next
;
3506 /* clear_marks (); */
3508 /* Mark all the special slots that serve as the roots of accessibility.
3510 Usually the special slots to mark are contained in particular structures.
3511 Then we know no slot is marked twice because the structures don't overlap.
3512 In some cases, the structures point to the slots to be marked.
3513 For these, we use MARKBIT to avoid double marking of the slot. */
3515 for (i
= 0; i
< staticidx
; i
++)
3516 mark_object (staticvec
[i
]);
3518 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3519 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3522 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3523 for (i
= 0; i
< tail
->nvars
; i
++)
3524 if (!XMARKBIT (tail
->var
[i
]))
3526 mark_object (&tail
->var
[i
]);
3527 XMARK (tail
->var
[i
]);
3532 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3534 mark_object (&bind
->symbol
);
3535 mark_object (&bind
->old_value
);
3537 for (catch = catchlist
; catch; catch = catch->next
)
3539 mark_object (&catch->tag
);
3540 mark_object (&catch->val
);
3542 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3544 mark_object (&handler
->handler
);
3545 mark_object (&handler
->var
);
3547 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3549 if (!XMARKBIT (*backlist
->function
))
3551 mark_object (backlist
->function
);
3552 XMARK (*backlist
->function
);
3554 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3557 i
= backlist
->nargs
- 1;
3559 if (!XMARKBIT (backlist
->args
[i
]))
3561 mark_object (&backlist
->args
[i
]);
3562 XMARK (backlist
->args
[i
]);
3567 /* Look thru every buffer's undo list
3568 for elements that update markers that were not marked,
3571 register struct buffer
*nextb
= all_buffers
;
3575 /* If a buffer's undo list is Qt, that means that undo is
3576 turned off in that buffer. Calling truncate_undo_list on
3577 Qt tends to return NULL, which effectively turns undo back on.
3578 So don't call truncate_undo_list if undo_list is Qt. */
3579 if (! EQ (nextb
->undo_list
, Qt
))
3581 Lisp_Object tail
, prev
;
3582 tail
= nextb
->undo_list
;
3584 while (CONSP (tail
))
3586 if (GC_CONSP (XCAR (tail
))
3587 && GC_MARKERP (XCAR (XCAR (tail
)))
3588 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3591 nextb
->undo_list
= tail
= XCDR (tail
);
3593 tail
= XCDR (prev
) = XCDR (tail
);
3603 nextb
= nextb
->next
;
3607 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3613 /* Clear the mark bits that we set in certain root slots. */
3615 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3616 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3617 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3618 for (i
= 0; i
< tail
->nvars
; i
++)
3619 XUNMARK (tail
->var
[i
]);
3622 unmark_byte_stack ();
3623 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3625 XUNMARK (*backlist
->function
);
3626 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3629 i
= backlist
->nargs
- 1;
3631 XUNMARK (backlist
->args
[i
]);
3633 XUNMARK (buffer_defaults
.name
);
3634 XUNMARK (buffer_local_symbols
.name
);
3636 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3642 /* clear_marks (); */
3645 consing_since_gc
= 0;
3646 if (gc_cons_threshold
< 10000)
3647 gc_cons_threshold
= 10000;
3649 if (garbage_collection_messages
)
3651 if (message_p
|| minibuf_level
> 0)
3654 message1_nolog ("Garbage collecting...done");
3659 total
[0] = Fcons (make_number (total_conses
),
3660 make_number (total_free_conses
));
3661 total
[1] = Fcons (make_number (total_symbols
),
3662 make_number (total_free_symbols
));
3663 total
[2] = Fcons (make_number (total_markers
),
3664 make_number (total_free_markers
));
3665 total
[3] = Fcons (make_number (total_string_size
),
3666 make_number (total_vector_size
));
3667 total
[4] = Fcons (make_number (total_floats
),
3668 make_number (total_free_floats
));
3669 total
[5] = Fcons (make_number (total_intervals
),
3670 make_number (total_free_intervals
));
3671 total
[6] = Fcons (make_number (total_strings
),
3672 make_number (total_free_strings
));
3674 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3676 /* Compute average percentage of zombies. */
3679 for (i
= 0; i
< 7; ++i
)
3680 nlive
+= XFASTINT (XCAR (total
[i
]));
3682 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3683 max_live
= max (nlive
, max_live
);
3684 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3685 max_zombies
= max (nzombies
, max_zombies
);
3690 return Flist (7, total
);
3694 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3695 only interesting objects referenced from glyphs are strings. */
3698 mark_glyph_matrix (matrix
)
3699 struct glyph_matrix
*matrix
;
3701 struct glyph_row
*row
= matrix
->rows
;
3702 struct glyph_row
*end
= row
+ matrix
->nrows
;
3704 for (; row
< end
; ++row
)
3708 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3710 struct glyph
*glyph
= row
->glyphs
[area
];
3711 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3713 for (; glyph
< end_glyph
; ++glyph
)
3714 if (GC_STRINGP (glyph
->object
)
3715 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3716 mark_object (&glyph
->object
);
3722 /* Mark Lisp faces in the face cache C. */
3726 struct face_cache
*c
;
3731 for (i
= 0; i
< c
->used
; ++i
)
3733 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3737 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3738 mark_object (&face
->lface
[j
]);
3745 #ifdef HAVE_WINDOW_SYSTEM
3747 /* Mark Lisp objects in image IMG. */
3753 mark_object (&img
->spec
);
3755 if (!NILP (img
->data
.lisp_val
))
3756 mark_object (&img
->data
.lisp_val
);
3760 /* Mark Lisp objects in image cache of frame F. It's done this way so
3761 that we don't have to include xterm.h here. */
3764 mark_image_cache (f
)
3767 forall_images_in_image_cache (f
, mark_image
);
3770 #endif /* HAVE_X_WINDOWS */
3774 /* Mark reference to a Lisp_Object.
3775 If the object referred to has not been seen yet, recursively mark
3776 all the references contained in it. */
3778 #define LAST_MARKED_SIZE 500
3779 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3780 int last_marked_index
;
3783 mark_object (argptr
)
3784 Lisp_Object
*argptr
;
3786 Lisp_Object
*objptr
= argptr
;
3787 register Lisp_Object obj
;
3794 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3797 last_marked
[last_marked_index
++] = objptr
;
3798 if (last_marked_index
== LAST_MARKED_SIZE
)
3799 last_marked_index
= 0;
3801 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3805 register struct Lisp_String
*ptr
= XSTRING (obj
);
3806 MARK_INTERVAL_TREE (ptr
->intervals
);
3811 case Lisp_Vectorlike
:
3812 if (GC_BUFFERP (obj
))
3814 if (!XMARKBIT (XBUFFER (obj
)->name
))
3817 else if (GC_SUBRP (obj
))
3819 else if (GC_COMPILEDP (obj
))
3820 /* We could treat this just like a vector, but it is better to
3821 save the COMPILED_CONSTANTS element for last and avoid
3824 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3825 register EMACS_INT size
= ptr
->size
;
3826 /* See comment above under Lisp_Vector. */
3827 struct Lisp_Vector
*volatile ptr1
= ptr
;
3830 if (size
& ARRAY_MARK_FLAG
)
3831 break; /* Already marked */
3832 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3833 size
&= PSEUDOVECTOR_SIZE_MASK
;
3834 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3836 if (i
!= COMPILED_CONSTANTS
)
3837 mark_object (&ptr1
->contents
[i
]);
3839 /* This cast should be unnecessary, but some Mips compiler complains
3840 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3841 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
3844 else if (GC_FRAMEP (obj
))
3846 /* See comment above under Lisp_Vector for why this is volatile. */
3847 register struct frame
*volatile ptr
= XFRAME (obj
);
3848 register EMACS_INT size
= ptr
->size
;
3850 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3851 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3853 mark_object (&ptr
->name
);
3854 mark_object (&ptr
->icon_name
);
3855 mark_object (&ptr
->title
);
3856 mark_object (&ptr
->focus_frame
);
3857 mark_object (&ptr
->selected_window
);
3858 mark_object (&ptr
->minibuffer_window
);
3859 mark_object (&ptr
->param_alist
);
3860 mark_object (&ptr
->scroll_bars
);
3861 mark_object (&ptr
->condemned_scroll_bars
);
3862 mark_object (&ptr
->menu_bar_items
);
3863 mark_object (&ptr
->face_alist
);
3864 mark_object (&ptr
->menu_bar_vector
);
3865 mark_object (&ptr
->buffer_predicate
);
3866 mark_object (&ptr
->buffer_list
);
3867 mark_object (&ptr
->menu_bar_window
);
3868 mark_object (&ptr
->tool_bar_window
);
3869 mark_face_cache (ptr
->face_cache
);
3870 #ifdef HAVE_WINDOW_SYSTEM
3871 mark_image_cache (ptr
);
3872 mark_object (&ptr
->desired_tool_bar_items
);
3873 mark_object (&ptr
->current_tool_bar_items
);
3874 mark_object (&ptr
->desired_tool_bar_string
);
3875 mark_object (&ptr
->current_tool_bar_string
);
3876 #endif /* HAVE_WINDOW_SYSTEM */
3878 else if (GC_BOOL_VECTOR_P (obj
))
3880 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3882 if (ptr
->size
& ARRAY_MARK_FLAG
)
3883 break; /* Already marked */
3884 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3886 else if (GC_WINDOWP (obj
))
3888 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3889 struct window
*w
= XWINDOW (obj
);
3890 register EMACS_INT size
= ptr
->size
;
3891 /* The reason we use ptr1 is to avoid an apparent hardware bug
3892 that happens occasionally on the FSF's HP 300s.
3893 The bug is that a2 gets clobbered by recursive calls to mark_object.
3894 The clobberage seems to happen during function entry,
3895 perhaps in the moveml instruction.
3896 Yes, this is a crock, but we have to do it. */
3897 struct Lisp_Vector
*volatile ptr1
= ptr
;
3900 /* Stop if already marked. */
3901 if (size
& ARRAY_MARK_FLAG
)
3905 ptr
->size
|= ARRAY_MARK_FLAG
;
3907 /* There is no Lisp data above The member CURRENT_MATRIX in
3908 struct WINDOW. Stop marking when that slot is reached. */
3910 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
3912 mark_object (&ptr1
->contents
[i
]);
3914 /* Mark glyphs for leaf windows. Marking window matrices is
3915 sufficient because frame matrices use the same glyph
3917 if (NILP (w
->hchild
)
3919 && w
->current_matrix
)
3921 mark_glyph_matrix (w
->current_matrix
);
3922 mark_glyph_matrix (w
->desired_matrix
);
3925 else if (GC_HASH_TABLE_P (obj
))
3927 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
3928 EMACS_INT size
= h
->size
;
3930 /* Stop if already marked. */
3931 if (size
& ARRAY_MARK_FLAG
)
3935 h
->size
|= ARRAY_MARK_FLAG
;
3937 /* Mark contents. */
3938 mark_object (&h
->test
);
3939 mark_object (&h
->weak
);
3940 mark_object (&h
->rehash_size
);
3941 mark_object (&h
->rehash_threshold
);
3942 mark_object (&h
->hash
);
3943 mark_object (&h
->next
);
3944 mark_object (&h
->index
);
3945 mark_object (&h
->user_hash_function
);
3946 mark_object (&h
->user_cmp_function
);
3948 /* If hash table is not weak, mark all keys and values.
3949 For weak tables, mark only the vector. */
3950 if (GC_NILP (h
->weak
))
3951 mark_object (&h
->key_and_value
);
3953 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
3958 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3959 register EMACS_INT size
= ptr
->size
;
3960 /* The reason we use ptr1 is to avoid an apparent hardware bug
3961 that happens occasionally on the FSF's HP 300s.
3962 The bug is that a2 gets clobbered by recursive calls to mark_object.
3963 The clobberage seems to happen during function entry,
3964 perhaps in the moveml instruction.
3965 Yes, this is a crock, but we have to do it. */
3966 struct Lisp_Vector
*volatile ptr1
= ptr
;
3969 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3970 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3971 if (size
& PSEUDOVECTOR_FLAG
)
3972 size
&= PSEUDOVECTOR_SIZE_MASK
;
3974 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3975 mark_object (&ptr1
->contents
[i
]);
3981 /* See comment above under Lisp_Vector for why this is volatile. */
3982 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
3983 struct Lisp_Symbol
*ptrx
;
3985 if (XMARKBIT (ptr
->plist
)) break;
3987 mark_object ((Lisp_Object
*) &ptr
->value
);
3988 mark_object (&ptr
->function
);
3989 mark_object (&ptr
->plist
);
3991 if (!PURE_POINTER_P (ptr
->name
))
3992 MARK_STRING (ptr
->name
);
3993 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
3995 /* Note that we do not mark the obarray of the symbol.
3996 It is safe not to do so because nothing accesses that
3997 slot except to check whether it is nil. */
4001 /* For the benefit of the last_marked log. */
4002 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4003 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4004 XSETSYMBOL (obj
, ptrx
);
4005 /* We can't goto loop here because *objptr doesn't contain an
4006 actual Lisp_Object with valid datatype field. */
4013 switch (XMISCTYPE (obj
))
4015 case Lisp_Misc_Marker
:
4016 XMARK (XMARKER (obj
)->chain
);
4017 /* DO NOT mark thru the marker's chain.
4018 The buffer's markers chain does not preserve markers from gc;
4019 instead, markers are removed from the chain when freed by gc. */
4022 case Lisp_Misc_Buffer_Local_Value
:
4023 case Lisp_Misc_Some_Buffer_Local_Value
:
4025 register struct Lisp_Buffer_Local_Value
*ptr
4026 = XBUFFER_LOCAL_VALUE (obj
);
4027 if (XMARKBIT (ptr
->realvalue
)) break;
4028 XMARK (ptr
->realvalue
);
4029 /* If the cdr is nil, avoid recursion for the car. */
4030 if (EQ (ptr
->cdr
, Qnil
))
4032 objptr
= &ptr
->realvalue
;
4035 mark_object (&ptr
->realvalue
);
4036 mark_object (&ptr
->buffer
);
4037 mark_object (&ptr
->frame
);
4038 /* See comment above under Lisp_Vector for why not use ptr here. */
4039 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
4043 case Lisp_Misc_Intfwd
:
4044 case Lisp_Misc_Boolfwd
:
4045 case Lisp_Misc_Objfwd
:
4046 case Lisp_Misc_Buffer_Objfwd
:
4047 case Lisp_Misc_Kboard_Objfwd
:
4048 /* Don't bother with Lisp_Buffer_Objfwd,
4049 since all markable slots in current buffer marked anyway. */
4050 /* Don't need to do Lisp_Objfwd, since the places they point
4051 are protected with staticpro. */
4054 case Lisp_Misc_Overlay
:
4056 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4057 if (!XMARKBIT (ptr
->plist
))
4060 mark_object (&ptr
->start
);
4061 mark_object (&ptr
->end
);
4062 objptr
= &ptr
->plist
;
4075 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4076 if (XMARKBIT (ptr
->car
)) break;
4078 /* If the cdr is nil, avoid recursion for the car. */
4079 if (EQ (ptr
->cdr
, Qnil
))
4084 mark_object (&ptr
->car
);
4085 /* See comment above under Lisp_Vector for why not use ptr here. */
4086 objptr
= &XCDR (obj
);
4091 XMARK (XFLOAT (obj
)->type
);
4102 /* Mark the pointers in a buffer structure. */
4108 register struct buffer
*buffer
= XBUFFER (buf
);
4109 register Lisp_Object
*ptr
;
4110 Lisp_Object base_buffer
;
4112 /* This is the buffer's markbit */
4113 mark_object (&buffer
->name
);
4114 XMARK (buffer
->name
);
4116 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4118 if (CONSP (buffer
->undo_list
))
4121 tail
= buffer
->undo_list
;
4123 while (CONSP (tail
))
4125 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4127 if (XMARKBIT (ptr
->car
))
4130 if (GC_CONSP (ptr
->car
)
4131 && ! XMARKBIT (XCAR (ptr
->car
))
4132 && GC_MARKERP (XCAR (ptr
->car
)))
4134 XMARK (XCAR (ptr
->car
));
4135 mark_object (&XCDR (ptr
->car
));
4138 mark_object (&ptr
->car
);
4140 if (CONSP (ptr
->cdr
))
4146 mark_object (&XCDR (tail
));
4149 mark_object (&buffer
->undo_list
);
4151 for (ptr
= &buffer
->name
+ 1;
4152 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4156 /* If this is an indirect buffer, mark its base buffer. */
4157 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4159 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4160 mark_buffer (base_buffer
);
4165 /* Mark the pointers in the kboard objects. */
4172 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4174 if (kb
->kbd_macro_buffer
)
4175 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4177 mark_object (&kb
->Voverriding_terminal_local_map
);
4178 mark_object (&kb
->Vlast_command
);
4179 mark_object (&kb
->Vreal_last_command
);
4180 mark_object (&kb
->Vprefix_arg
);
4181 mark_object (&kb
->Vlast_prefix_arg
);
4182 mark_object (&kb
->kbd_queue
);
4183 mark_object (&kb
->defining_kbd_macro
);
4184 mark_object (&kb
->Vlast_kbd_macro
);
4185 mark_object (&kb
->Vsystem_key_alist
);
4186 mark_object (&kb
->system_key_syms
);
4187 mark_object (&kb
->Vdefault_minibuffer_frame
);
4192 /* Value is non-zero if OBJ will survive the current GC because it's
4193 either marked or does not need to be marked to survive. */
4201 switch (XGCTYPE (obj
))
4208 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4212 switch (XMISCTYPE (obj
))
4214 case Lisp_Misc_Marker
:
4215 survives_p
= XMARKBIT (obj
);
4218 case Lisp_Misc_Buffer_Local_Value
:
4219 case Lisp_Misc_Some_Buffer_Local_Value
:
4220 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4223 case Lisp_Misc_Intfwd
:
4224 case Lisp_Misc_Boolfwd
:
4225 case Lisp_Misc_Objfwd
:
4226 case Lisp_Misc_Buffer_Objfwd
:
4227 case Lisp_Misc_Kboard_Objfwd
:
4231 case Lisp_Misc_Overlay
:
4232 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4242 struct Lisp_String
*s
= XSTRING (obj
);
4243 survives_p
= STRING_MARKED_P (s
);
4247 case Lisp_Vectorlike
:
4248 if (GC_BUFFERP (obj
))
4249 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4250 else if (GC_SUBRP (obj
))
4253 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4257 survives_p
= XMARKBIT (XCAR (obj
));
4261 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4268 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4273 /* Sweep: find all structures not marked, and free them. */
4278 /* Remove or mark entries in weak hash tables.
4279 This must be done before any object is unmarked. */
4280 sweep_weak_hash_tables ();
4284 /* Put all unmarked conses on free list */
4286 register struct cons_block
*cblk
;
4287 struct cons_block
**cprev
= &cons_block
;
4288 register int lim
= cons_block_index
;
4289 register int num_free
= 0, num_used
= 0;
4293 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4297 for (i
= 0; i
< lim
; i
++)
4298 if (!XMARKBIT (cblk
->conses
[i
].car
))
4301 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4302 cons_free_list
= &cblk
->conses
[i
];
4304 cons_free_list
->car
= Vdead
;
4310 XUNMARK (cblk
->conses
[i
].car
);
4312 lim
= CONS_BLOCK_SIZE
;
4313 /* If this block contains only free conses and we have already
4314 seen more than two blocks worth of free conses then deallocate
4316 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4318 *cprev
= cblk
->next
;
4319 /* Unhook from the free list. */
4320 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4326 num_free
+= this_free
;
4327 cprev
= &cblk
->next
;
4330 total_conses
= num_used
;
4331 total_free_conses
= num_free
;
4334 /* Put all unmarked floats on free list */
4336 register struct float_block
*fblk
;
4337 struct float_block
**fprev
= &float_block
;
4338 register int lim
= float_block_index
;
4339 register int num_free
= 0, num_used
= 0;
4341 float_free_list
= 0;
4343 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4347 for (i
= 0; i
< lim
; i
++)
4348 if (!XMARKBIT (fblk
->floats
[i
].type
))
4351 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4352 float_free_list
= &fblk
->floats
[i
];
4354 float_free_list
->type
= Vdead
;
4360 XUNMARK (fblk
->floats
[i
].type
);
4362 lim
= FLOAT_BLOCK_SIZE
;
4363 /* If this block contains only free floats and we have already
4364 seen more than two blocks worth of free floats then deallocate
4366 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4368 *fprev
= fblk
->next
;
4369 /* Unhook from the free list. */
4370 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4376 num_free
+= this_free
;
4377 fprev
= &fblk
->next
;
4380 total_floats
= num_used
;
4381 total_free_floats
= num_free
;
4384 /* Put all unmarked intervals on free list */
4386 register struct interval_block
*iblk
;
4387 struct interval_block
**iprev
= &interval_block
;
4388 register int lim
= interval_block_index
;
4389 register int num_free
= 0, num_used
= 0;
4391 interval_free_list
= 0;
4393 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4398 for (i
= 0; i
< lim
; i
++)
4400 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4402 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4403 interval_free_list
= &iblk
->intervals
[i
];
4409 XUNMARK (iblk
->intervals
[i
].plist
);
4412 lim
= INTERVAL_BLOCK_SIZE
;
4413 /* If this block contains only free intervals and we have already
4414 seen more than two blocks worth of free intervals then
4415 deallocate this block. */
4416 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4418 *iprev
= iblk
->next
;
4419 /* Unhook from the free list. */
4420 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4422 n_interval_blocks
--;
4426 num_free
+= this_free
;
4427 iprev
= &iblk
->next
;
4430 total_intervals
= num_used
;
4431 total_free_intervals
= num_free
;
4434 /* Put all unmarked symbols on free list */
4436 register struct symbol_block
*sblk
;
4437 struct symbol_block
**sprev
= &symbol_block
;
4438 register int lim
= symbol_block_index
;
4439 register int num_free
= 0, num_used
= 0;
4441 symbol_free_list
= 0;
4443 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4447 for (i
= 0; i
< lim
; i
++)
4448 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4450 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4451 symbol_free_list
= &sblk
->symbols
[i
];
4453 symbol_free_list
->function
= Vdead
;
4460 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4461 UNMARK_STRING (sblk
->symbols
[i
].name
);
4462 XUNMARK (sblk
->symbols
[i
].plist
);
4464 lim
= SYMBOL_BLOCK_SIZE
;
4465 /* If this block contains only free symbols and we have already
4466 seen more than two blocks worth of free symbols then deallocate
4468 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4470 *sprev
= sblk
->next
;
4471 /* Unhook from the free list. */
4472 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4478 num_free
+= this_free
;
4479 sprev
= &sblk
->next
;
4482 total_symbols
= num_used
;
4483 total_free_symbols
= num_free
;
4486 /* Put all unmarked misc's on free list.
4487 For a marker, first unchain it from the buffer it points into. */
4489 register struct marker_block
*mblk
;
4490 struct marker_block
**mprev
= &marker_block
;
4491 register int lim
= marker_block_index
;
4492 register int num_free
= 0, num_used
= 0;
4494 marker_free_list
= 0;
4496 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4500 EMACS_INT already_free
= -1;
4502 for (i
= 0; i
< lim
; i
++)
4504 Lisp_Object
*markword
;
4505 switch (mblk
->markers
[i
].u_marker
.type
)
4507 case Lisp_Misc_Marker
:
4508 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4510 case Lisp_Misc_Buffer_Local_Value
:
4511 case Lisp_Misc_Some_Buffer_Local_Value
:
4512 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4514 case Lisp_Misc_Overlay
:
4515 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4517 case Lisp_Misc_Free
:
4518 /* If the object was already free, keep it
4519 on the free list. */
4520 markword
= (Lisp_Object
*) &already_free
;
4526 if (markword
&& !XMARKBIT (*markword
))
4529 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4531 /* tem1 avoids Sun compiler bug */
4532 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4533 XSETMARKER (tem
, tem1
);
4534 unchain_marker (tem
);
4536 /* Set the type of the freed object to Lisp_Misc_Free.
4537 We could leave the type alone, since nobody checks it,
4538 but this might catch bugs faster. */
4539 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4540 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4541 marker_free_list
= &mblk
->markers
[i
];
4548 XUNMARK (*markword
);
4551 lim
= MARKER_BLOCK_SIZE
;
4552 /* If this block contains only free markers and we have already
4553 seen more than two blocks worth of free markers then deallocate
4555 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4557 *mprev
= mblk
->next
;
4558 /* Unhook from the free list. */
4559 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4565 num_free
+= this_free
;
4566 mprev
= &mblk
->next
;
4570 total_markers
= num_used
;
4571 total_free_markers
= num_free
;
4574 /* Free all unmarked buffers */
4576 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4579 if (!XMARKBIT (buffer
->name
))
4582 prev
->next
= buffer
->next
;
4584 all_buffers
= buffer
->next
;
4585 next
= buffer
->next
;
4591 XUNMARK (buffer
->name
);
4592 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4593 prev
= buffer
, buffer
= buffer
->next
;
4597 /* Free all unmarked vectors */
4599 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4600 total_vector_size
= 0;
4603 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4606 prev
->next
= vector
->next
;
4608 all_vectors
= vector
->next
;
4609 next
= vector
->next
;
4617 vector
->size
&= ~ARRAY_MARK_FLAG
;
4618 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4619 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4621 total_vector_size
+= vector
->size
;
4622 prev
= vector
, vector
= vector
->next
;
4630 /* Debugging aids. */
4632 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4633 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4634 This may be helpful in debugging Emacs's memory usage.\n\
4635 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4640 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4645 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4646 "Return a list of counters that measure how much consing there has been.\n\
4647 Each of these counters increments for a certain kind of object.\n\
4648 The counters wrap around from the largest positive integer to zero.\n\
4649 Garbage collection does not decrease them.\n\
4650 The elements of the value are as follows:\n\
4651 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4652 All are in units of 1 = one object consed\n\
4653 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4655 MISCS include overlays, markers, and some internal types.\n\
4656 Frames, windows, buffers, and subprocesses count as vectors\n\
4657 (but the contents of a buffer's text do not count here).")
4660 Lisp_Object consed
[8];
4663 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4665 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4667 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4669 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4671 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4673 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4675 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4677 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4679 return Flist (8, consed
);
4682 int suppress_checking
;
4684 die (msg
, file
, line
)
4689 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4694 /* Initialization */
4699 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4703 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4706 pure_size
= PURESIZE
;
4709 ignore_warnings
= 1;
4710 #ifdef DOUG_LEA_MALLOC
4711 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4712 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4713 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4723 malloc_hysteresis
= 32;
4725 malloc_hysteresis
= 0;
4728 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4730 ignore_warnings
= 0;
4732 byte_stack_list
= 0;
4734 consing_since_gc
= 0;
4735 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4736 #ifdef VIRT_ADDR_VARIES
4737 malloc_sbrk_unused
= 1<<22; /* A large number */
4738 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4739 #endif /* VIRT_ADDR_VARIES */
4746 byte_stack_list
= 0;
4748 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4749 setjmp_tested_p
= longjmps_done
= 0;
4757 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4758 "*Number of bytes of consing between garbage collections.\n\
4759 Garbage collection can happen automatically once this many bytes have been\n\
4760 allocated since the last garbage collection. All data types count.\n\n\
4761 Garbage collection happens automatically only when `eval' is called.\n\n\
4762 By binding this temporarily to a large number, you can effectively\n\
4763 prevent garbage collection during a part of the program.");
4765 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4766 "Number of bytes of sharable Lisp data allocated so far.");
4768 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4769 "Number of cons cells that have been consed so far.");
4771 DEFVAR_INT ("floats-consed", &floats_consed
,
4772 "Number of floats that have been consed so far.");
4774 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4775 "Number of vector cells that have been consed so far.");
4777 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4778 "Number of symbols that have been consed so far.");
4780 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4781 "Number of string characters that have been consed so far.");
4783 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4784 "Number of miscellaneous objects that have been consed so far.");
4786 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4787 "Number of intervals that have been consed so far.");
4789 DEFVAR_INT ("strings-consed", &strings_consed
,
4790 "Number of strings that have been consed so far.");
4792 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4793 "Non-nil means loading Lisp code in order to dump an executable.\n\
4794 This means that certain objects should be allocated in shared (pure) space.");
4796 DEFVAR_INT ("undo-limit", &undo_limit
,
4797 "Keep no more undo information once it exceeds this size.\n\
4798 This limit is applied when garbage collection happens.\n\
4799 The size is counted as the number of bytes occupied,\n\
4800 which includes both saved text and other data.");
4803 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
4804 "Don't keep more than this much size of undo information.\n\
4805 A command which pushes past this size is itself forgotten.\n\
4806 This limit is applied when garbage collection happens.\n\
4807 The size is counted as the number of bytes occupied,\n\
4808 which includes both saved text and other data.");
4809 undo_strong_limit
= 30000;
4811 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
4812 "Non-nil means display messages at start and end of garbage collection.");
4813 garbage_collection_messages
= 0;
4815 /* We build this in advance because if we wait until we need it, we might
4816 not be able to allocate the memory to hold it. */
4818 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
4819 staticpro (&memory_signal_data
);
4821 staticpro (&Qgc_cons_threshold
);
4822 Qgc_cons_threshold
= intern ("gc-cons-threshold");
4824 staticpro (&Qchar_table_extra_slots
);
4825 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
4830 defsubr (&Smake_byte_code
);
4831 defsubr (&Smake_list
);
4832 defsubr (&Smake_vector
);
4833 defsubr (&Smake_char_table
);
4834 defsubr (&Smake_string
);
4835 defsubr (&Smake_bool_vector
);
4836 defsubr (&Smake_symbol
);
4837 defsubr (&Smake_marker
);
4838 defsubr (&Spurecopy
);
4839 defsubr (&Sgarbage_collect
);
4840 defsubr (&Smemory_limit
);
4841 defsubr (&Smemory_use_counts
);
4843 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4844 defsubr (&Sgc_status
);