1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 /* Note that this declares bzero on OSF/1. How dumb. */
29 /* This file is part of the core Lisp implementation, and thus must
30 deal with the real data structures. If the Lisp implementation is
31 replaced, this file likely will not be used. */
33 #undef HIDE_LISP_IMPLEMENTATION
35 #include "intervals.h"
40 #include "blockinput.h"
43 #include "syssignal.h"
48 #ifdef DOUG_LEA_MALLOC
51 #define __malloc_size_t int
53 /* Specify maximum number of areas to mmap. It would be nice to use a
54 value that explicitly means "no limit". */
56 #define MMAP_MAX_AREAS 100000000
58 #else /* not DOUG_LEA_MALLOC */
60 /* The following come from gmalloc.c. */
62 #if defined (STDC_HEADERS)
64 #define __malloc_size_t size_t
66 #define __malloc_size_t unsigned int
68 extern __malloc_size_t _bytes_used
;
69 extern int __malloc_extra_blocks
;
71 #endif /* not DOUG_LEA_MALLOC */
73 #define max(A,B) ((A) > (B) ? (A) : (B))
74 #define min(A,B) ((A) < (B) ? (A) : (B))
76 /* Macro to verify that storage intended for Lisp objects is not
77 out of range to fit in the space for a pointer.
78 ADDRESS is the start of the block, and SIZE
79 is the amount of space within which objects can start. */
81 #define VALIDATE_LISP_STORAGE(address, size) \
85 XSETCONS (val, (char *) address + size); \
86 if ((char *) XCONS (val) != (char *) address + size) \
93 /* Value of _bytes_used, when spare_memory was freed. */
95 static __malloc_size_t bytes_used_when_full
;
97 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
98 to a struct Lisp_String. */
100 #define MARK_STRING(S) XMARK ((S)->size)
101 #define UNMARK_STRING(S) XUNMARK ((S)->size)
102 #define STRING_MARKED_P(S) XMARKBIT ((S)->size)
104 /* Value is the number of bytes/chars of S, a pointer to a struct
105 Lisp_String. This must be used instead of STRING_BYTES (S) or
106 S->size during GC, because S->size contains the mark bit for
109 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
110 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
112 /* Number of bytes of consing done since the last gc. */
114 int consing_since_gc
;
116 /* Count the amount of consing of various sorts of space. */
118 int cons_cells_consed
;
120 int vector_cells_consed
;
122 int string_chars_consed
;
123 int misc_objects_consed
;
124 int intervals_consed
;
127 /* Number of bytes of consing since GC before another GC should be done. */
129 int gc_cons_threshold
;
131 /* Nonzero during GC. */
135 /* Nonzero means display messages at beginning and end of GC. */
137 int garbage_collection_messages
;
139 #ifndef VIRT_ADDR_VARIES
141 #endif /* VIRT_ADDR_VARIES */
142 int malloc_sbrk_used
;
144 #ifndef VIRT_ADDR_VARIES
146 #endif /* VIRT_ADDR_VARIES */
147 int malloc_sbrk_unused
;
149 /* Two limits controlling how much undo information to keep. */
152 int undo_strong_limit
;
154 /* Number of live and free conses etc. */
156 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
157 static int total_free_conses
, total_free_markers
, total_free_symbols
;
158 static int total_free_floats
, total_floats
;
160 /* Points to memory space allocated as "spare", to be freed if we run
163 static char *spare_memory
;
165 /* Amount of spare memory to keep in reserve. */
167 #define SPARE_MEMORY (1 << 14)
169 /* Number of extra blocks malloc should get when it needs more core. */
171 static int malloc_hysteresis
;
173 /* Nonzero when malloc is called for allocating Lisp object space.
174 Currently set but not used. */
176 int allocating_for_lisp
;
178 /* Non-nil means defun should do purecopy on the function definition. */
180 Lisp_Object Vpurify_flag
;
184 /* Force it into data space! */
186 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,};
187 #define PUREBEG (char *) pure
189 #else /* not HAVE_SHM */
191 #define pure PURE_SEG_BITS /* Use shared memory segment */
192 #define PUREBEG (char *)PURE_SEG_BITS
194 /* This variable is used only by the XPNTR macro when HAVE_SHM is
195 defined. If we used the PURESIZE macro directly there, that would
196 make most of Emacs dependent on puresize.h, which we don't want -
197 you should be able to change that without too much recompilation.
198 So map_in_data initializes pure_size, and the dependencies work
203 #endif /* not HAVE_SHM */
205 /* Value is non-zero if P points into pure space. */
207 #define PURE_POINTER_P(P) \
208 (((PNTR_COMPARISON_TYPE) (P) \
209 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
210 && ((PNTR_COMPARISON_TYPE) (P) \
211 >= (PNTR_COMPARISON_TYPE) pure))
213 /* Index in pure at which next pure object will be allocated.. */
217 /* If nonzero, this is a warning delivered by malloc and not yet
220 char *pending_malloc_warning
;
222 /* Pre-computed signal argument for use when memory is exhausted. */
224 Lisp_Object memory_signal_data
;
226 /* Maximum amount of C stack to save when a GC happens. */
228 #ifndef MAX_SAVE_STACK
229 #define MAX_SAVE_STACK 16000
232 /* Buffer in which we save a copy of the C stack at each GC. */
237 /* Non-zero means ignore malloc warnings. Set during initialization.
238 Currently not used. */
242 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
244 static void mark_buffer
P_ ((Lisp_Object
));
245 static void mark_kboards
P_ ((void));
246 static void gc_sweep
P_ ((void));
247 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
248 static void mark_face_cache
P_ ((struct face_cache
*));
250 #ifdef HAVE_WINDOW_SYSTEM
251 static void mark_image
P_ ((struct image
*));
252 static void mark_image_cache
P_ ((struct frame
*));
253 #endif /* HAVE_WINDOW_SYSTEM */
255 static struct Lisp_String
*allocate_string
P_ ((void));
256 static void compact_small_strings
P_ ((void));
257 static void free_large_strings
P_ ((void));
258 static void sweep_strings
P_ ((void));
260 extern int message_enable_multibyte
;
262 /* When scanning the C stack for live Lisp objects, Emacs keeps track
263 of what memory allocated via lisp_malloc is intended for what
264 purpose. This enumeration specifies the type of memory. */
280 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
281 #include <stdio.h> /* For fprintf. */
284 /* A unique object in pure space used to make some Lisp objects
285 on free lists recognizable in O(1). */
290 static void *lisp_malloc
P_ ((int, enum mem_type
));
291 static void mark_stack
P_ ((void));
292 static void init_stack
P_ ((Lisp_Object
*));
293 static int live_vector_p
P_ ((struct mem_node
*, void *));
294 static int live_buffer_p
P_ ((struct mem_node
*, void *));
295 static int live_string_p
P_ ((struct mem_node
*, void *));
296 static int live_cons_p
P_ ((struct mem_node
*, void *));
297 static int live_symbol_p
P_ ((struct mem_node
*, void *));
298 static int live_float_p
P_ ((struct mem_node
*, void *));
299 static int live_misc_p
P_ ((struct mem_node
*, void *));
300 static void mark_maybe_object
P_ ((Lisp_Object
));
301 static void mark_memory
P_ ((void *, void *));
302 static void mem_init
P_ ((void));
303 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
304 static void mem_insert_fixup
P_ ((struct mem_node
*));
305 static void mem_rotate_left
P_ ((struct mem_node
*));
306 static void mem_rotate_right
P_ ((struct mem_node
*));
307 static void mem_delete
P_ ((struct mem_node
*));
308 static void mem_delete_fixup
P_ ((struct mem_node
*));
309 static INLINE
struct mem_node
*mem_find
P_ ((void *));
311 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
312 static void check_gcpros
P_ ((void));
315 #endif /* GC_MARK_STACK != 0 */
318 /************************************************************************
320 ************************************************************************/
322 /* Write STR to Vstandard_output plus some advice on how to free some
323 memory. Called when memory gets low. */
326 malloc_warning_1 (str
)
329 Fprinc (str
, Vstandard_output
);
330 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
331 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
332 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
337 /* Function malloc calls this if it finds we are near exhausting
344 pending_malloc_warning
= str
;
348 /* Display a malloc warning in buffer *Danger*. */
351 display_malloc_warning ()
353 register Lisp_Object val
;
355 val
= build_string (pending_malloc_warning
);
356 pending_malloc_warning
= 0;
357 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
361 #ifdef DOUG_LEA_MALLOC
362 # define BYTES_USED (mallinfo ().arena)
364 # define BYTES_USED _bytes_used
368 /* Called if malloc returns zero. */
373 #ifndef SYSTEM_MALLOC
374 bytes_used_when_full
= BYTES_USED
;
377 /* The first time we get here, free the spare memory. */
384 /* This used to call error, but if we've run out of memory, we could
385 get infinite recursion trying to build the string. */
387 Fsignal (Qnil
, memory_signal_data
);
391 /* Called if we can't allocate relocatable space for a buffer. */
394 buffer_memory_full ()
396 /* If buffers use the relocating allocator, no need to free
397 spare_memory, because we may have plenty of malloc space left
398 that we could get, and if we don't, the malloc that fails will
399 itself cause spare_memory to be freed. If buffers don't use the
400 relocating allocator, treat this like any other failing
407 /* This used to call error, but if we've run out of memory, we could
408 get infinite recursion trying to build the string. */
410 Fsignal (Qerror
, memory_signal_data
);
414 /* Like malloc but check for no memory and block interrupt input.. */
423 val
= (long *) malloc (size
);
432 /* Like realloc but check for no memory and block interrupt input.. */
435 xrealloc (block
, size
)
442 /* We must call malloc explicitly when BLOCK is 0, since some
443 reallocs don't do this. */
445 val
= (long *) malloc (size
);
447 val
= (long *) realloc (block
, size
);
450 if (!val
&& size
) memory_full ();
455 /* Like free but block interrupt input.. */
467 /* Like malloc but used for allocating Lisp data. NBYTES is the
468 number of bytes to allocate, TYPE describes the intended use of the
469 allcated memory block (for strings, for conses, ...). */
472 lisp_malloc (nbytes
, type
)
479 allocating_for_lisp
++;
480 val
= (void *) malloc (nbytes
);
481 allocating_for_lisp
--;
488 if (type
!= MEM_TYPE_NON_LISP
)
489 mem_insert (val
, (char *) val
+ nbytes
, type
);
496 /* Return a new buffer structure allocated from the heap with
497 a call to lisp_malloc. */
502 return (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
507 /* Free BLOCK. This must be called to free memory allocated with a
508 call to lisp_malloc. */
515 allocating_for_lisp
++;
518 mem_delete (mem_find (block
));
520 allocating_for_lisp
--;
525 /* Arranging to disable input signals while we're in malloc.
527 This only works with GNU malloc. To help out systems which can't
528 use GNU malloc, all the calls to malloc, realloc, and free
529 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
530 pairs; unfortunately, we have no idea what C library functions
531 might call malloc, so we can't really protect them unless you're
532 using GNU malloc. Fortunately, most of the major operating can use
535 #ifndef SYSTEM_MALLOC
537 extern void * (*__malloc_hook
) ();
538 static void * (*old_malloc_hook
) ();
539 extern void * (*__realloc_hook
) ();
540 static void * (*old_realloc_hook
) ();
541 extern void (*__free_hook
) ();
542 static void (*old_free_hook
) ();
544 /* This function is used as the hook for free to call. */
547 emacs_blocked_free (ptr
)
551 __free_hook
= old_free_hook
;
553 /* If we released our reserve (due to running out of memory),
554 and we have a fair amount free once again,
555 try to set aside another reserve in case we run out once more. */
556 if (spare_memory
== 0
557 /* Verify there is enough space that even with the malloc
558 hysteresis this call won't run out again.
559 The code here is correct as long as SPARE_MEMORY
560 is substantially larger than the block size malloc uses. */
561 && (bytes_used_when_full
562 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
563 spare_memory
= (char *) malloc (SPARE_MEMORY
);
565 __free_hook
= emacs_blocked_free
;
570 /* If we released our reserve (due to running out of memory),
571 and we have a fair amount free once again,
572 try to set aside another reserve in case we run out once more.
574 This is called when a relocatable block is freed in ralloc.c. */
577 refill_memory_reserve ()
579 if (spare_memory
== 0)
580 spare_memory
= (char *) malloc (SPARE_MEMORY
);
584 /* This function is the malloc hook that Emacs uses. */
587 emacs_blocked_malloc (size
)
593 __malloc_hook
= old_malloc_hook
;
594 #ifdef DOUG_LEA_MALLOC
595 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
597 __malloc_extra_blocks
= malloc_hysteresis
;
599 value
= (void *) malloc (size
);
600 __malloc_hook
= emacs_blocked_malloc
;
607 /* This function is the realloc hook that Emacs uses. */
610 emacs_blocked_realloc (ptr
, size
)
617 __realloc_hook
= old_realloc_hook
;
618 value
= (void *) realloc (ptr
, size
);
619 __realloc_hook
= emacs_blocked_realloc
;
626 /* Called from main to set up malloc to use our hooks. */
629 uninterrupt_malloc ()
631 if (__free_hook
!= emacs_blocked_free
)
632 old_free_hook
= __free_hook
;
633 __free_hook
= emacs_blocked_free
;
635 if (__malloc_hook
!= emacs_blocked_malloc
)
636 old_malloc_hook
= __malloc_hook
;
637 __malloc_hook
= emacs_blocked_malloc
;
639 if (__realloc_hook
!= emacs_blocked_realloc
)
640 old_realloc_hook
= __realloc_hook
;
641 __realloc_hook
= emacs_blocked_realloc
;
644 #endif /* not SYSTEM_MALLOC */
648 /***********************************************************************
650 ***********************************************************************/
652 /* Number of intervals allocated in an interval_block structure.
653 The 1020 is 1024 minus malloc overhead. */
655 #define INTERVAL_BLOCK_SIZE \
656 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
658 /* Intervals are allocated in chunks in form of an interval_block
661 struct interval_block
663 struct interval_block
*next
;
664 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
667 /* Current interval block. Its `next' pointer points to older
670 struct interval_block
*interval_block
;
672 /* Index in interval_block above of the next unused interval
675 static int interval_block_index
;
677 /* Number of free and live intervals. */
679 static int total_free_intervals
, total_intervals
;
681 /* List of free intervals. */
683 INTERVAL interval_free_list
;
685 /* Total number of interval blocks now in use. */
687 int n_interval_blocks
;
690 /* Initialize interval allocation. */
696 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
698 interval_block
->next
= 0;
699 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
700 interval_block_index
= 0;
701 interval_free_list
= 0;
702 n_interval_blocks
= 1;
706 /* Return a new interval. */
713 if (interval_free_list
)
715 val
= interval_free_list
;
716 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
720 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
722 register struct interval_block
*newi
;
724 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
727 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
728 newi
->next
= interval_block
;
729 interval_block
= newi
;
730 interval_block_index
= 0;
733 val
= &interval_block
->intervals
[interval_block_index
++];
735 consing_since_gc
+= sizeof (struct interval
);
737 RESET_INTERVAL (val
);
742 /* Mark Lisp objects in interval I. */
745 mark_interval (i
, dummy
)
749 if (XMARKBIT (i
->plist
))
751 mark_object (&i
->plist
);
756 /* Mark the interval tree rooted in TREE. Don't call this directly;
757 use the macro MARK_INTERVAL_TREE instead. */
760 mark_interval_tree (tree
)
761 register INTERVAL tree
;
763 /* No need to test if this tree has been marked already; this
764 function is always called through the MARK_INTERVAL_TREE macro,
765 which takes care of that. */
767 /* XMARK expands to an assignment; the LHS of an assignment can't be
769 XMARK (tree
->up
.obj
);
771 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
775 /* Mark the interval tree rooted in I. */
777 #define MARK_INTERVAL_TREE(i) \
779 if (!NULL_INTERVAL_P (i) \
780 && ! XMARKBIT (i->up.obj)) \
781 mark_interval_tree (i); \
785 /* The oddity in the call to XUNMARK is necessary because XUNMARK
786 expands to an assignment to its argument, and most C compilers
787 don't support casts on the left operand of `='. */
789 #define UNMARK_BALANCE_INTERVALS(i) \
791 if (! NULL_INTERVAL_P (i)) \
793 XUNMARK ((i)->up.obj); \
794 (i) = balance_intervals (i); \
800 /***********************************************************************
802 ***********************************************************************/
804 /* Lisp_Strings are allocated in string_block structures. When a new
805 string_block is allocated, all the Lisp_Strings it contains are
806 added to a free-list stiing_free_list. When a new Lisp_String is
807 needed, it is taken from that list. During the sweep phase of GC,
808 string_blocks that are entirely free are freed, except two which
811 String data is allocated from sblock structures. Strings larger
812 than LARGE_STRING_BYTES, get their own sblock, data for smaller
813 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
815 Sblocks consist internally of sdata structures, one for each
816 Lisp_String. The sdata structure points to the Lisp_String it
817 belongs to. The Lisp_String points back to the `u.data' member of
820 When a Lisp_String is freed during GC, it is put back on
821 string_free_list, and its `data' member and its sdata's `string'
822 pointer is set to null. The size of the string is recorded in the
823 `u.nbytes' member of the sdata. So, sdata structures that are no
824 longer used, can be easily recognized, and it's easy to compact the
825 sblocks of small strings which we do in compact_small_strings. */
827 /* Size in bytes of an sblock structure used for small strings. This
828 is 8192 minus malloc overhead. */
830 #define SBLOCK_SIZE 8188
832 /* Strings larger than this are considered large strings. String data
833 for large strings is allocated from individual sblocks. */
835 #define LARGE_STRING_BYTES 1024
837 /* Structure describing string memory sub-allocated from an sblock.
838 This is where the contents of Lisp strings are stored. */
842 /* Back-pointer to the string this sdata belongs to. If null, this
843 structure is free, and the NBYTES member of the union below
844 contains the string's byte size (the same value that STRING_BYTES
845 would return if STRING were non-null). If non-null, STRING_BYTES
846 (STRING) is the size of the data, and DATA contains the string's
848 struct Lisp_String
*string
;
852 /* When STRING in non-null. */
853 unsigned char data
[1];
855 /* When STRING is null. */
860 /* Structure describing a block of memory which is sub-allocated to
861 obtain string data memory for strings. Blocks for small strings
862 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
863 as large as needed. */
870 /* Pointer to the next free sdata block. This points past the end
871 of the sblock if there isn't any space left in this block. */
872 struct sdata
*next_free
;
875 struct sdata first_data
;
878 /* Number of Lisp strings in a string_block structure. The 1020 is
879 1024 minus malloc overhead. */
881 #define STRINGS_IN_STRING_BLOCK \
882 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
884 /* Structure describing a block from which Lisp_String structures
889 struct string_block
*next
;
890 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
893 /* Head and tail of the list of sblock structures holding Lisp string
894 data. We always allocate from current_sblock. The NEXT pointers
895 in the sblock structures go from oldest_sblock to current_sblock. */
897 static struct sblock
*oldest_sblock
, *current_sblock
;
899 /* List of sblocks for large strings. */
901 static struct sblock
*large_sblocks
;
903 /* List of string_block structures, and how many there are. */
905 static struct string_block
*string_blocks
;
906 static int n_string_blocks
;
908 /* Free-list of Lisp_Strings. */
910 static struct Lisp_String
*string_free_list
;
912 /* Number of live and free Lisp_Strings. */
914 static int total_strings
, total_free_strings
;
916 /* Number of bytes used by live strings. */
918 static int total_string_size
;
920 /* Given a pointer to a Lisp_String S which is on the free-list
921 string_free_list, return a pointer to its successor in the
924 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
926 /* Return a pointer to the sdata structure belonging to Lisp string S.
927 S must be live, i.e. S->data must not be null. S->data is actually
928 a pointer to the `u.data' member of its sdata structure; the
929 structure starts at a constant offset in front of that. */
931 #define SDATA_OF_STRING(S) \
932 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
934 /* Value is the size of an sdata structure large enough to hold NBYTES
935 bytes of string data. The value returned includes a terminating
936 NUL byte, the size of the sdata structure, and padding. */
938 #define SDATA_SIZE(NBYTES) \
939 ((sizeof (struct Lisp_String *) \
941 + sizeof (EMACS_INT) - 1) \
942 & ~(sizeof (EMACS_INT) - 1))
945 /* Initialize string allocation. Called from init_alloc_once. */
950 total_strings
= total_free_strings
= total_string_size
= 0;
951 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
952 string_blocks
= NULL
;
954 string_free_list
= NULL
;
958 /* Return a new Lisp_String. */
960 static struct Lisp_String
*
963 struct Lisp_String
*s
;
965 /* If the free-list is empty, allocate a new string_block, and
966 add all the Lisp_Strings in it to the free-list. */
967 if (string_free_list
== NULL
)
969 struct string_block
*b
;
972 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
973 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
974 bzero (b
, sizeof *b
);
975 b
->next
= string_blocks
;
979 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
982 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
983 string_free_list
= s
;
986 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
989 /* Pop a Lisp_String off the free-list. */
990 s
= string_free_list
;
991 string_free_list
= NEXT_FREE_LISP_STRING (s
);
993 /* Probably not strictly necessary, but play it safe. */
994 bzero (s
, sizeof *s
);
996 --total_free_strings
;
999 consing_since_gc
+= sizeof *s
;
1005 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1006 plus a NUL byte at the end. Allocate an sdata structure for S, and
1007 set S->data to its `u.data' member. Store a NUL byte at the end of
1008 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1009 S->data if it was initially non-null. */
1012 allocate_string_data (s
, nchars
, nbytes
)
1013 struct Lisp_String
*s
;
1020 /* Determine the number of bytes needed to store NBYTES bytes
1022 needed
= SDATA_SIZE (nbytes
);
1024 if (nbytes
> LARGE_STRING_BYTES
)
1026 int size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1028 #ifdef DOUG_LEA_MALLOC
1029 /* Prevent mmap'ing the chunk (which is potentially very large). */
1030 mallopt (M_MMAP_MAX
, 0);
1033 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1035 #ifdef DOUG_LEA_MALLOC
1036 /* Back to a reasonable maximum of mmap'ed areas. */
1037 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1040 b
->next_free
= &b
->first_data
;
1041 b
->first_data
.string
= NULL
;
1042 b
->next
= large_sblocks
;
1045 else if (current_sblock
== NULL
1046 || (((char *) current_sblock
+ SBLOCK_SIZE
1047 - (char *) current_sblock
->next_free
)
1050 /* Not enough room in the current sblock. */
1051 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1052 b
->next_free
= &b
->first_data
;
1053 b
->first_data
.string
= NULL
;
1057 current_sblock
->next
= b
;
1065 /* If S had already data assigned, mark that as free by setting
1066 its string back-pointer to null, and recording the size of
1070 data
= SDATA_OF_STRING (s
);
1071 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1072 data
->string
= NULL
;
1075 data
= b
->next_free
;
1077 s
->data
= data
->u
.data
;
1079 s
->size_byte
= nbytes
;
1080 s
->data
[nbytes
] = '\0';
1081 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1083 consing_since_gc
+= needed
;
1087 /* Sweep and compact strings. */
1092 struct string_block
*b
, *next
;
1093 struct string_block
*live_blocks
= NULL
;
1095 string_free_list
= NULL
;
1096 total_strings
= total_free_strings
= 0;
1097 total_string_size
= 0;
1099 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1100 for (b
= string_blocks
; b
; b
= next
)
1103 struct Lisp_String
*free_list_before
= string_free_list
;
1107 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1109 struct Lisp_String
*s
= b
->strings
+ i
;
1113 /* String was not on free-list before. */
1114 if (STRING_MARKED_P (s
))
1116 /* String is live; unmark it and its intervals. */
1119 if (!NULL_INTERVAL_P (s
->intervals
))
1120 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1123 total_string_size
+= STRING_BYTES (s
);
1127 /* String is dead. Put it on the free-list. */
1128 struct sdata
*data
= SDATA_OF_STRING (s
);
1130 /* Save the size of S in its sdata so that we know
1131 how large that is. Reset the sdata's string
1132 back-pointer so that we know it's free. */
1133 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1134 data
->string
= NULL
;
1136 /* Reset the strings's `data' member so that we
1140 /* Put the string on the free-list. */
1141 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1142 string_free_list
= s
;
1148 /* S was on the free-list before. Put it there again. */
1149 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1150 string_free_list
= s
;
1155 /* Free blocks that contain free Lisp_Strings only, except
1156 the first two of them. */
1157 if (nfree
== STRINGS_IN_STRING_BLOCK
1158 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1162 string_free_list
= free_list_before
;
1166 total_free_strings
+= nfree
;
1167 b
->next
= live_blocks
;
1172 string_blocks
= live_blocks
;
1173 free_large_strings ();
1174 compact_small_strings ();
1178 /* Free dead large strings. */
1181 free_large_strings ()
1183 struct sblock
*b
, *next
;
1184 struct sblock
*live_blocks
= NULL
;
1186 for (b
= large_sblocks
; b
; b
= next
)
1190 if (b
->first_data
.string
== NULL
)
1194 b
->next
= live_blocks
;
1199 large_sblocks
= live_blocks
;
1203 /* Compact data of small strings. Free sblocks that don't contain
1204 data of live strings after compaction. */
1207 compact_small_strings ()
1209 struct sblock
*b
, *tb
, *next
;
1210 struct sdata
*from
, *to
, *end
, *tb_end
;
1211 struct sdata
*to_end
, *from_end
;
1213 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1214 to, and TB_END is the end of TB. */
1216 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1217 to
= &tb
->first_data
;
1219 /* Step through the blocks from the oldest to the youngest. We
1220 expect that old blocks will stabilize over time, so that less
1221 copying will happen this way. */
1222 for (b
= oldest_sblock
; b
; b
= b
->next
)
1225 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1227 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1229 /* Compute the next FROM here because copying below may
1230 overwrite data we need to compute it. */
1234 nbytes
= GC_STRING_BYTES (from
->string
);
1236 nbytes
= from
->u
.nbytes
;
1238 nbytes
= SDATA_SIZE (nbytes
);
1239 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1241 /* FROM->string non-null means it's alive. Copy its data. */
1244 /* If TB is full, proceed with the next sblock. */
1245 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1246 if (to_end
> tb_end
)
1250 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1251 to
= &tb
->first_data
;
1252 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1255 /* Copy, and update the string's `data' pointer. */
1258 bcopy (from
, to
, nbytes
);
1259 to
->string
->data
= to
->u
.data
;
1262 /* Advance past the sdata we copied to. */
1268 /* The rest of the sblocks following TB don't contain live data, so
1269 we can free them. */
1270 for (b
= tb
->next
; b
; b
= next
)
1278 current_sblock
= tb
;
1282 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1283 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1284 Both LENGTH and INIT must be numbers.")
1286 Lisp_Object length
, init
;
1288 register Lisp_Object val
;
1289 register unsigned char *p
, *end
;
1292 CHECK_NATNUM (length
, 0);
1293 CHECK_NUMBER (init
, 1);
1296 if (SINGLE_BYTE_CHAR_P (c
))
1298 nbytes
= XINT (length
);
1299 val
= make_uninit_string (nbytes
);
1300 p
= XSTRING (val
)->data
;
1301 end
= p
+ XSTRING (val
)->size
;
1307 unsigned char str
[4];
1308 int len
= CHAR_STRING (c
, str
);
1310 nbytes
= len
* XINT (length
);
1311 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1312 p
= XSTRING (val
)->data
;
1316 bcopy (str
, p
, len
);
1326 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1327 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1328 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1330 Lisp_Object length
, init
;
1332 register Lisp_Object val
;
1333 struct Lisp_Bool_Vector
*p
;
1335 int length_in_chars
, length_in_elts
, bits_per_value
;
1337 CHECK_NATNUM (length
, 0);
1339 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1341 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1342 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1344 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1345 slot `size' of the struct Lisp_Bool_Vector. */
1346 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1347 p
= XBOOL_VECTOR (val
);
1349 /* Get rid of any bits that would cause confusion. */
1351 XSETBOOL_VECTOR (val
, p
);
1352 p
->size
= XFASTINT (length
);
1354 real_init
= (NILP (init
) ? 0 : -1);
1355 for (i
= 0; i
< length_in_chars
; i
++)
1356 p
->data
[i
] = real_init
;
1358 /* Clear the extraneous bits in the last byte. */
1359 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1360 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1361 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1367 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1368 of characters from the contents. This string may be unibyte or
1369 multibyte, depending on the contents. */
1372 make_string (contents
, nbytes
)
1376 register Lisp_Object val
;
1377 int nchars
= chars_in_text (contents
, nbytes
);
1378 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1379 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1380 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1381 SET_STRING_BYTES (XSTRING (val
), -1);
1386 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1389 make_unibyte_string (contents
, length
)
1393 register Lisp_Object val
;
1394 val
= make_uninit_string (length
);
1395 bcopy (contents
, XSTRING (val
)->data
, length
);
1396 SET_STRING_BYTES (XSTRING (val
), -1);
1401 /* Make a multibyte string from NCHARS characters occupying NBYTES
1402 bytes at CONTENTS. */
1405 make_multibyte_string (contents
, nchars
, nbytes
)
1409 register Lisp_Object val
;
1410 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1411 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1416 /* Make a string from NCHARS characters occupying NBYTES bytes at
1417 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1420 make_string_from_bytes (contents
, nchars
, nbytes
)
1424 register Lisp_Object val
;
1425 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1426 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1427 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1428 SET_STRING_BYTES (XSTRING (val
), -1);
1433 /* Make a string from NCHARS characters occupying NBYTES bytes at
1434 CONTENTS. The argument MULTIBYTE controls whether to label the
1435 string as multibyte. */
1438 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1443 register Lisp_Object val
;
1444 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1445 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1447 SET_STRING_BYTES (XSTRING (val
), -1);
1452 /* Make a string from the data at STR, treating it as multibyte if the
1459 return make_string (str
, strlen (str
));
1463 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1464 occupying LENGTH bytes. */
1467 make_uninit_string (length
)
1471 val
= make_uninit_multibyte_string (length
, length
);
1472 SET_STRING_BYTES (XSTRING (val
), -1);
1477 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1478 which occupy NBYTES bytes. */
1481 make_uninit_multibyte_string (nchars
, nbytes
)
1485 struct Lisp_String
*s
;
1490 s
= allocate_string ();
1491 allocate_string_data (s
, nchars
, nbytes
);
1492 XSETSTRING (string
, s
);
1493 string_chars_consed
+= nbytes
;
1499 /***********************************************************************
1501 ***********************************************************************/
1503 /* We store float cells inside of float_blocks, allocating a new
1504 float_block with malloc whenever necessary. Float cells reclaimed
1505 by GC are put on a free list to be reallocated before allocating
1506 any new float cells from the latest float_block.
1508 Each float_block is just under 1020 bytes long, since malloc really
1509 allocates in units of powers of two and uses 4 bytes for its own
1512 #define FLOAT_BLOCK_SIZE \
1513 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1517 struct float_block
*next
;
1518 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1521 /* Current float_block. */
1523 struct float_block
*float_block
;
1525 /* Index of first unused Lisp_Float in the current float_block. */
1527 int float_block_index
;
1529 /* Total number of float blocks now in use. */
1533 /* Free-list of Lisp_Floats. */
1535 struct Lisp_Float
*float_free_list
;
1538 /* Initialze float allocation. */
1543 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1545 float_block
->next
= 0;
1546 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1547 float_block_index
= 0;
1548 float_free_list
= 0;
1553 /* Explicitly free a float cell by putting it on the free-list. */
1557 struct Lisp_Float
*ptr
;
1559 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1563 float_free_list
= ptr
;
1567 /* Return a new float object with value FLOAT_VALUE. */
1570 make_float (float_value
)
1573 register Lisp_Object val
;
1575 if (float_free_list
)
1577 /* We use the data field for chaining the free list
1578 so that we won't use the same field that has the mark bit. */
1579 XSETFLOAT (val
, float_free_list
);
1580 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1584 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1586 register struct float_block
*new;
1588 new = (struct float_block
*) lisp_malloc (sizeof *new,
1590 VALIDATE_LISP_STORAGE (new, sizeof *new);
1591 new->next
= float_block
;
1593 float_block_index
= 0;
1596 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1599 XFLOAT_DATA (val
) = float_value
;
1600 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1601 consing_since_gc
+= sizeof (struct Lisp_Float
);
1608 /***********************************************************************
1610 ***********************************************************************/
1612 /* We store cons cells inside of cons_blocks, allocating a new
1613 cons_block with malloc whenever necessary. Cons cells reclaimed by
1614 GC are put on a free list to be reallocated before allocating
1615 any new cons cells from the latest cons_block.
1617 Each cons_block is just under 1020 bytes long,
1618 since malloc really allocates in units of powers of two
1619 and uses 4 bytes for its own overhead. */
1621 #define CONS_BLOCK_SIZE \
1622 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1626 struct cons_block
*next
;
1627 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1630 /* Current cons_block. */
1632 struct cons_block
*cons_block
;
1634 /* Index of first unused Lisp_Cons in the current block. */
1636 int cons_block_index
;
1638 /* Free-list of Lisp_Cons structures. */
1640 struct Lisp_Cons
*cons_free_list
;
1642 /* Total number of cons blocks now in use. */
1647 /* Initialize cons allocation. */
1652 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1654 cons_block
->next
= 0;
1655 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1656 cons_block_index
= 0;
1662 /* Explicitly free a cons cell by putting it on the free-list. */
1666 struct Lisp_Cons
*ptr
;
1668 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1672 cons_free_list
= ptr
;
1676 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
1677 "Create a new cons, give it CAR and CDR as components, and return it.")
1679 Lisp_Object car
, cdr
;
1681 register Lisp_Object val
;
1685 /* We use the cdr for chaining the free list
1686 so that we won't use the same field that has the mark bit. */
1687 XSETCONS (val
, cons_free_list
);
1688 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
1692 if (cons_block_index
== CONS_BLOCK_SIZE
)
1694 register struct cons_block
*new;
1695 new = (struct cons_block
*) lisp_malloc (sizeof *new,
1697 VALIDATE_LISP_STORAGE (new, sizeof *new);
1698 new->next
= cons_block
;
1700 cons_block_index
= 0;
1703 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
1708 consing_since_gc
+= sizeof (struct Lisp_Cons
);
1709 cons_cells_consed
++;
1714 /* Make a list of 2, 3, 4 or 5 specified objects. */
1718 Lisp_Object arg1
, arg2
;
1720 return Fcons (arg1
, Fcons (arg2
, Qnil
));
1725 list3 (arg1
, arg2
, arg3
)
1726 Lisp_Object arg1
, arg2
, arg3
;
1728 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
1733 list4 (arg1
, arg2
, arg3
, arg4
)
1734 Lisp_Object arg1
, arg2
, arg3
, arg4
;
1736 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
1741 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
1742 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
1744 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
1745 Fcons (arg5
, Qnil
)))));
1749 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
1750 "Return a newly created list with specified arguments as elements.\n\
1751 Any number of arguments, even zero arguments, are allowed.")
1754 register Lisp_Object
*args
;
1756 register Lisp_Object val
;
1762 val
= Fcons (args
[nargs
], val
);
1768 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
1769 "Return a newly created list of length LENGTH, with each element being INIT.")
1771 register Lisp_Object length
, init
;
1773 register Lisp_Object val
;
1776 CHECK_NATNUM (length
, 0);
1777 size
= XFASTINT (length
);
1781 val
= Fcons (init
, val
);
1787 /***********************************************************************
1789 ***********************************************************************/
1791 /* Singly-linked list of all vectors. */
1793 struct Lisp_Vector
*all_vectors
;
1795 /* Total number of vector-like objects now in use. */
1800 /* Value is a pointer to a newly allocated Lisp_Vector structure
1801 with room for LEN Lisp_Objects. */
1803 struct Lisp_Vector
*
1804 allocate_vectorlike (len
)
1807 struct Lisp_Vector
*p
;
1810 #ifdef DOUG_LEA_MALLOC
1811 /* Prevent mmap'ing the chunk (which is potentially very large).. */
1812 mallopt (M_MMAP_MAX
, 0);
1815 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
1816 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
1818 #ifdef DOUG_LEA_MALLOC
1819 /* Back to a reasonable maximum of mmap'ed areas. */
1820 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1823 VALIDATE_LISP_STORAGE (p
, 0);
1824 consing_since_gc
+= nbytes
;
1825 vector_cells_consed
+= len
;
1827 p
->next
= all_vectors
;
1834 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
1835 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1836 See also the function `vector'.")
1838 register Lisp_Object length
, init
;
1841 register EMACS_INT sizei
;
1843 register struct Lisp_Vector
*p
;
1845 CHECK_NATNUM (length
, 0);
1846 sizei
= XFASTINT (length
);
1848 p
= allocate_vectorlike (sizei
);
1850 for (index
= 0; index
< sizei
; index
++)
1851 p
->contents
[index
] = init
;
1853 XSETVECTOR (vector
, p
);
1858 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
1859 "Return a newly created char-table, with purpose PURPOSE.\n\
1860 Each element is initialized to INIT, which defaults to nil.\n\
1861 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
1862 The property's value should be an integer between 0 and 10.")
1864 register Lisp_Object purpose
, init
;
1868 CHECK_SYMBOL (purpose
, 1);
1869 n
= Fget (purpose
, Qchar_table_extra_slots
);
1870 CHECK_NUMBER (n
, 0);
1871 if (XINT (n
) < 0 || XINT (n
) > 10)
1872 args_out_of_range (n
, Qnil
);
1873 /* Add 2 to the size for the defalt and parent slots. */
1874 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
1876 XCHAR_TABLE (vector
)->top
= Qt
;
1877 XCHAR_TABLE (vector
)->parent
= Qnil
;
1878 XCHAR_TABLE (vector
)->purpose
= purpose
;
1879 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1884 /* Return a newly created sub char table with default value DEFALT.
1885 Since a sub char table does not appear as a top level Emacs Lisp
1886 object, we don't need a Lisp interface to make it. */
1889 make_sub_char_table (defalt
)
1893 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
1894 XCHAR_TABLE (vector
)->top
= Qnil
;
1895 XCHAR_TABLE (vector
)->defalt
= defalt
;
1896 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1901 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
1902 "Return a newly created vector with specified arguments as elements.\n\
1903 Any number of arguments, even zero arguments, are allowed.")
1908 register Lisp_Object len
, val
;
1910 register struct Lisp_Vector
*p
;
1912 XSETFASTINT (len
, nargs
);
1913 val
= Fmake_vector (len
, Qnil
);
1915 for (index
= 0; index
< nargs
; index
++)
1916 p
->contents
[index
] = args
[index
];
1921 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
1922 "Create a byte-code object with specified arguments as elements.\n\
1923 The arguments should be the arglist, bytecode-string, constant vector,\n\
1924 stack size, (optional) doc string, and (optional) interactive spec.\n\
1925 The first four arguments are required; at most six have any\n\
1931 register Lisp_Object len
, val
;
1933 register struct Lisp_Vector
*p
;
1935 XSETFASTINT (len
, nargs
);
1936 if (!NILP (Vpurify_flag
))
1937 val
= make_pure_vector ((EMACS_INT
) nargs
);
1939 val
= Fmake_vector (len
, Qnil
);
1941 for (index
= 0; index
< nargs
; index
++)
1943 if (!NILP (Vpurify_flag
))
1944 args
[index
] = Fpurecopy (args
[index
]);
1945 p
->contents
[index
] = args
[index
];
1947 XSETCOMPILED (val
, p
);
1953 /***********************************************************************
1955 ***********************************************************************/
1957 /* Each symbol_block is just under 1020 bytes long, since malloc
1958 really allocates in units of powers of two and uses 4 bytes for its
1961 #define SYMBOL_BLOCK_SIZE \
1962 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
1966 struct symbol_block
*next
;
1967 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
1970 /* Current symbol block and index of first unused Lisp_Symbol
1973 struct symbol_block
*symbol_block
;
1974 int symbol_block_index
;
1976 /* List of free symbols. */
1978 struct Lisp_Symbol
*symbol_free_list
;
1980 /* Total number of symbol blocks now in use. */
1982 int n_symbol_blocks
;
1985 /* Initialize symbol allocation. */
1990 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
1992 symbol_block
->next
= 0;
1993 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
1994 symbol_block_index
= 0;
1995 symbol_free_list
= 0;
1996 n_symbol_blocks
= 1;
2000 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2001 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2002 Its value and function definition are void, and its property list is nil.")
2006 register Lisp_Object val
;
2007 register struct Lisp_Symbol
*p
;
2009 CHECK_STRING (name
, 0);
2011 if (symbol_free_list
)
2013 XSETSYMBOL (val
, symbol_free_list
);
2014 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2018 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2020 struct symbol_block
*new;
2021 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2023 VALIDATE_LISP_STORAGE (new, sizeof *new);
2024 new->next
= symbol_block
;
2026 symbol_block_index
= 0;
2029 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2033 p
->name
= XSTRING (name
);
2036 p
->value
= Qunbound
;
2037 p
->function
= Qunbound
;
2039 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2046 /***********************************************************************
2047 Marker (Misc) Allocation
2048 ***********************************************************************/
2050 /* Allocation of markers and other objects that share that structure.
2051 Works like allocation of conses. */
2053 #define MARKER_BLOCK_SIZE \
2054 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2058 struct marker_block
*next
;
2059 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2062 struct marker_block
*marker_block
;
2063 int marker_block_index
;
2065 union Lisp_Misc
*marker_free_list
;
2067 /* Total number of marker blocks now in use. */
2069 int n_marker_blocks
;
2074 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2076 marker_block
->next
= 0;
2077 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2078 marker_block_index
= 0;
2079 marker_free_list
= 0;
2080 n_marker_blocks
= 1;
2083 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2090 if (marker_free_list
)
2092 XSETMISC (val
, marker_free_list
);
2093 marker_free_list
= marker_free_list
->u_free
.chain
;
2097 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2099 struct marker_block
*new;
2100 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2102 VALIDATE_LISP_STORAGE (new, sizeof *new);
2103 new->next
= marker_block
;
2105 marker_block_index
= 0;
2108 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2111 consing_since_gc
+= sizeof (union Lisp_Misc
);
2112 misc_objects_consed
++;
2116 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2117 "Return a newly allocated marker which does not point at any place.")
2120 register Lisp_Object val
;
2121 register struct Lisp_Marker
*p
;
2123 val
= allocate_misc ();
2124 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2130 p
->insertion_type
= 0;
2134 /* Put MARKER back on the free list after using it temporarily. */
2137 free_marker (marker
)
2140 unchain_marker (marker
);
2142 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2143 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2144 marker_free_list
= XMISC (marker
);
2146 total_free_markers
++;
2150 /* Return a newly created vector or string with specified arguments as
2151 elements. If all the arguments are characters that can fit
2152 in a string of events, make a string; otherwise, make a vector.
2154 Any number of arguments, even zero arguments, are allowed. */
2157 make_event_array (nargs
, args
)
2163 for (i
= 0; i
< nargs
; i
++)
2164 /* The things that fit in a string
2165 are characters that are in 0...127,
2166 after discarding the meta bit and all the bits above it. */
2167 if (!INTEGERP (args
[i
])
2168 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2169 return Fvector (nargs
, args
);
2171 /* Since the loop exited, we know that all the things in it are
2172 characters, so we can make a string. */
2176 result
= Fmake_string (make_number (nargs
), make_number (0));
2177 for (i
= 0; i
< nargs
; i
++)
2179 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2180 /* Move the meta bit to the right place for a string char. */
2181 if (XINT (args
[i
]) & CHAR_META
)
2182 XSTRING (result
)->data
[i
] |= 0x80;
2191 /************************************************************************
2193 ************************************************************************/
2198 /* Base address of stack. Set in main. */
2200 Lisp_Object
*stack_base
;
2202 /* A node in the red-black tree describing allocated memory containing
2203 Lisp data. Each such block is recorded with its start and end
2204 address when it is allocated, and removed from the tree when it
2207 A red-black tree is a balanced binary tree with the following
2210 1. Every node is either red or black.
2211 2. Every leaf is black.
2212 3. If a node is red, then both of its children are black.
2213 4. Every simple path from a node to a descendant leaf contains
2214 the same number of black nodes.
2215 5. The root is always black.
2217 When nodes are inserted into the tree, or deleted from the tree,
2218 the tree is "fixed" so that these properties are always true.
2220 A red-black tree with N internal nodes has height at most 2
2221 log(N+1). Searches, insertions and deletions are done in O(log N).
2222 Please see a text book about data structures for a detailed
2223 description of red-black trees. Any book worth its salt should
2228 struct mem_node
*left
, *right
, *parent
;
2230 /* Start and end of allocated region. */
2234 enum {MEM_BLACK
, MEM_RED
} color
;
2240 /* Root of the tree describing allocated Lisp memory. */
2242 static struct mem_node
*mem_root
;
2244 /* Sentinel node of the tree. */
2246 static struct mem_node mem_z
;
2247 #define MEM_NIL &mem_z
2250 /* Initialize this part of alloc.c. */
2255 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2256 mem_z
.parent
= NULL
;
2257 mem_z
.color
= MEM_BLACK
;
2258 mem_z
.start
= mem_z
.end
= NULL
;
2263 /* Value is a pointer to the mem_node containing START. Value is
2264 MEM_NIL if there is no node in the tree containing START. */
2266 static INLINE
struct mem_node
*
2272 /* Make the search always successful to speed up the loop below. */
2273 mem_z
.start
= start
;
2274 mem_z
.end
= (char *) start
+ 1;
2277 while (start
< p
->start
|| start
>= p
->end
)
2278 p
= start
< p
->start
? p
->left
: p
->right
;
2283 /* Insert a new node into the tree for a block of memory with start
2284 address START, end address END, and type TYPE. Value is a
2285 pointer to the node that was inserted. */
2287 static struct mem_node
*
2288 mem_insert (start
, end
, type
)
2292 struct mem_node
*c
, *parent
, *x
;
2294 /* See where in the tree a node for START belongs. In this
2295 particular application, it shouldn't happen that a node is already
2296 present. For debugging purposes, let's check that. */
2300 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2302 while (c
!= MEM_NIL
)
2304 if (start
>= c
->start
&& start
< c
->end
)
2307 c
= start
< c
->start
? c
->left
: c
->right
;
2310 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2312 while (c
!= MEM_NIL
)
2315 c
= start
< c
->start
? c
->left
: c
->right
;
2318 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2320 /* Create a new node. */
2321 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2326 x
->left
= x
->right
= MEM_NIL
;
2329 /* Insert it as child of PARENT or install it as root. */
2332 if (start
< parent
->start
)
2340 /* Re-establish red-black tree properties. */
2341 mem_insert_fixup (x
);
2346 /* Re-establish the red-black properties of the tree, and thereby
2347 balance the tree, after node X has been inserted; X is always red. */
2350 mem_insert_fixup (x
)
2353 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2355 /* X is red and its parent is red. This is a violation of
2356 red-black tree property #3. */
2358 if (x
->parent
== x
->parent
->parent
->left
)
2360 /* We're on the left side of our grandparent, and Y is our
2362 struct mem_node
*y
= x
->parent
->parent
->right
;
2364 if (y
->color
== MEM_RED
)
2366 /* Uncle and parent are red but should be black because
2367 X is red. Change the colors accordingly and proceed
2368 with the grandparent. */
2369 x
->parent
->color
= MEM_BLACK
;
2370 y
->color
= MEM_BLACK
;
2371 x
->parent
->parent
->color
= MEM_RED
;
2372 x
= x
->parent
->parent
;
2376 /* Parent and uncle have different colors; parent is
2377 red, uncle is black. */
2378 if (x
== x
->parent
->right
)
2381 mem_rotate_left (x
);
2384 x
->parent
->color
= MEM_BLACK
;
2385 x
->parent
->parent
->color
= MEM_RED
;
2386 mem_rotate_right (x
->parent
->parent
);
2391 /* This is the symmetrical case of above. */
2392 struct mem_node
*y
= x
->parent
->parent
->left
;
2394 if (y
->color
== MEM_RED
)
2396 x
->parent
->color
= MEM_BLACK
;
2397 y
->color
= MEM_BLACK
;
2398 x
->parent
->parent
->color
= MEM_RED
;
2399 x
= x
->parent
->parent
;
2403 if (x
== x
->parent
->left
)
2406 mem_rotate_right (x
);
2409 x
->parent
->color
= MEM_BLACK
;
2410 x
->parent
->parent
->color
= MEM_RED
;
2411 mem_rotate_left (x
->parent
->parent
);
2416 /* The root may have been changed to red due to the algorithm. Set
2417 it to black so that property #5 is satisfied. */
2418 mem_root
->color
= MEM_BLACK
;
2434 /* Turn y's left sub-tree into x's right sub-tree. */
2437 if (y
->left
!= MEM_NIL
)
2438 y
->left
->parent
= x
;
2440 /* Y's parent was x's parent. */
2442 y
->parent
= x
->parent
;
2444 /* Get the parent to point to y instead of x. */
2447 if (x
== x
->parent
->left
)
2448 x
->parent
->left
= y
;
2450 x
->parent
->right
= y
;
2455 /* Put x on y's left. */
2469 mem_rotate_right (x
)
2472 struct mem_node
*y
= x
->left
;
2475 if (y
->right
!= MEM_NIL
)
2476 y
->right
->parent
= x
;
2479 y
->parent
= x
->parent
;
2482 if (x
== x
->parent
->right
)
2483 x
->parent
->right
= y
;
2485 x
->parent
->left
= y
;
2496 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2502 struct mem_node
*x
, *y
;
2504 if (!z
|| z
== MEM_NIL
)
2507 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2512 while (y
->left
!= MEM_NIL
)
2516 if (y
->left
!= MEM_NIL
)
2521 x
->parent
= y
->parent
;
2524 if (y
== y
->parent
->left
)
2525 y
->parent
->left
= x
;
2527 y
->parent
->right
= x
;
2534 z
->start
= y
->start
;
2539 if (y
->color
== MEM_BLACK
)
2540 mem_delete_fixup (x
);
2545 /* Re-establish the red-black properties of the tree, after a
2549 mem_delete_fixup (x
)
2552 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2554 if (x
== x
->parent
->left
)
2556 struct mem_node
*w
= x
->parent
->right
;
2558 if (w
->color
== MEM_RED
)
2560 w
->color
= MEM_BLACK
;
2561 x
->parent
->color
= MEM_RED
;
2562 mem_rotate_left (x
->parent
);
2563 w
= x
->parent
->right
;
2566 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2573 if (w
->right
->color
== MEM_BLACK
)
2575 w
->left
->color
= MEM_BLACK
;
2577 mem_rotate_right (w
);
2578 w
= x
->parent
->right
;
2580 w
->color
= x
->parent
->color
;
2581 x
->parent
->color
= MEM_BLACK
;
2582 w
->right
->color
= MEM_BLACK
;
2583 mem_rotate_left (x
->parent
);
2589 struct mem_node
*w
= x
->parent
->left
;
2591 if (w
->color
== MEM_RED
)
2593 w
->color
= MEM_BLACK
;
2594 x
->parent
->color
= MEM_RED
;
2595 mem_rotate_right (x
->parent
);
2596 w
= x
->parent
->left
;
2599 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2606 if (w
->left
->color
== MEM_BLACK
)
2608 w
->right
->color
= MEM_BLACK
;
2610 mem_rotate_left (w
);
2611 w
= x
->parent
->left
;
2614 w
->color
= x
->parent
->color
;
2615 x
->parent
->color
= MEM_BLACK
;
2616 w
->left
->color
= MEM_BLACK
;
2617 mem_rotate_right (x
->parent
);
2623 x
->color
= MEM_BLACK
;
2627 /* Value is non-zero if P is a pointer to a live Lisp string on
2628 the heap. M is a pointer to the mem_block for P. */
2631 live_string_p (m
, p
)
2635 if (m
->type
== MEM_TYPE_STRING
)
2637 struct string_block
*b
= (struct string_block
*) m
->start
;
2638 int offset
= (char *) p
- (char *) &b
->strings
[0];
2640 /* P must point to the start of a Lisp_String structure, and it
2641 must not be on the free-list. */
2642 return (offset
% sizeof b
->strings
[0] == 0
2643 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2650 /* Value is non-zero if P is a pointer to a live Lisp cons on
2651 the heap. M is a pointer to the mem_block for P. */
2658 if (m
->type
== MEM_TYPE_CONS
)
2660 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2661 int offset
= (char *) p
- (char *) &b
->conses
[0];
2663 /* P must point to the start of a Lisp_Cons, not be
2664 one of the unused cells in the current cons block,
2665 and not be on the free-list. */
2666 return (offset
% sizeof b
->conses
[0] == 0
2668 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2669 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2676 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2677 the heap. M is a pointer to the mem_block for P. */
2680 live_symbol_p (m
, p
)
2684 if (m
->type
== MEM_TYPE_SYMBOL
)
2686 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2687 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2689 /* P must point to the start of a Lisp_Symbol, not be
2690 one of the unused cells in the current symbol block,
2691 and not be on the free-list. */
2692 return (offset
% sizeof b
->symbols
[0] == 0
2693 && (b
!= symbol_block
2694 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2695 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2702 /* Value is non-zero if P is a pointer to a live Lisp float on
2703 the heap. M is a pointer to the mem_block for P. */
2710 if (m
->type
== MEM_TYPE_FLOAT
)
2712 struct float_block
*b
= (struct float_block
*) m
->start
;
2713 int offset
= (char *) p
- (char *) &b
->floats
[0];
2715 /* P must point to the start of a Lisp_Float, not be
2716 one of the unused cells in the current float block,
2717 and not be on the free-list. */
2718 return (offset
% sizeof b
->floats
[0] == 0
2719 && (b
!= float_block
2720 || offset
/ sizeof b
->floats
[0] < float_block_index
)
2721 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
2728 /* Value is non-zero if P is a pointer to a live Lisp Misc on
2729 the heap. M is a pointer to the mem_block for P. */
2736 if (m
->type
== MEM_TYPE_MISC
)
2738 struct marker_block
*b
= (struct marker_block
*) m
->start
;
2739 int offset
= (char *) p
- (char *) &b
->markers
[0];
2741 /* P must point to the start of a Lisp_Misc, not be
2742 one of the unused cells in the current misc block,
2743 and not be on the free-list. */
2744 return (offset
% sizeof b
->markers
[0] == 0
2745 && (b
!= marker_block
2746 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
2747 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
2754 /* Value is non-zero if P is a pointer to a live vector-like object.
2755 M is a pointer to the mem_block for P. */
2758 live_vector_p (m
, p
)
2762 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
2766 /* Value is non-zero of P is a pointer to a live buffer. M is a
2767 pointer to the mem_block for P. */
2770 live_buffer_p (m
, p
)
2774 /* P must point to the start of the block, and the buffer
2775 must not have been killed. */
2776 return (m
->type
== MEM_TYPE_BUFFER
2778 && !NILP (((struct buffer
*) p
)->name
));
2782 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2784 /* Array of objects that are kept alive because the C stack contains
2785 a pattern that looks like a reference to them . */
2787 #define MAX_ZOMBIES 10
2788 static Lisp_Object zombies
[MAX_ZOMBIES
];
2790 /* Number of zombie objects. */
2792 static int nzombies
;
2794 /* Number of garbage collections. */
2798 /* Average percentage of zombies per collection. */
2800 static double avg_zombies
;
2802 /* Max. number of live and zombie objects. */
2804 static int max_live
, max_zombies
;
2806 /* Average number of live objects per GC. */
2808 static double avg_live
;
2810 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
2811 "Show information about live and zombie objects.")
2814 Lisp_Object args
[7];
2815 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2816 args
[1] = make_number (ngcs
);
2817 args
[2] = make_float (avg_live
);
2818 args
[3] = make_float (avg_zombies
);
2819 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
2820 args
[5] = make_number (max_live
);
2821 args
[6] = make_number (max_zombies
);
2822 return Fmessage (7, args
);
2825 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2828 /* Mark OBJ if we can prove it's a Lisp_Object. */
2831 mark_maybe_object (obj
)
2834 void *po
= (void *) XPNTR (obj
);
2835 struct mem_node
*m
= mem_find (po
);
2841 switch (XGCTYPE (obj
))
2844 mark_p
= (live_string_p (m
, po
)
2845 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
2849 mark_p
= (live_cons_p (m
, po
)
2850 && !XMARKBIT (XCONS (obj
)->car
));
2854 mark_p
= (live_symbol_p (m
, po
)
2855 && !XMARKBIT (XSYMBOL (obj
)->plist
));
2859 mark_p
= (live_float_p (m
, po
)
2860 && !XMARKBIT (XFLOAT (obj
)->type
));
2863 case Lisp_Vectorlike
:
2864 /* Note: can't check GC_BUFFERP before we know it's a
2865 buffer because checking that dereferences the pointer
2866 PO which might point anywhere. */
2867 if (live_vector_p (m
, po
))
2868 mark_p
= (!GC_SUBRP (obj
)
2869 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
2870 else if (live_buffer_p (m
, po
))
2871 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
2875 if (live_misc_p (m
, po
))
2877 switch (XMISCTYPE (obj
))
2879 case Lisp_Misc_Marker
:
2880 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
2883 case Lisp_Misc_Buffer_Local_Value
:
2884 case Lisp_Misc_Some_Buffer_Local_Value
:
2885 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2888 case Lisp_Misc_Overlay
:
2889 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
2898 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2899 if (nzombies
< MAX_ZOMBIES
)
2900 zombies
[nzombies
] = *p
;
2908 /* Mark Lisp objects in the address range START..END. */
2911 mark_memory (start
, end
)
2916 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2920 /* Make START the pointer to the start of the memory region,
2921 if it isn't already. */
2929 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
2930 mark_maybe_object (*p
);
2934 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2936 static int setjmp_tested_p
, longjmps_done
;
2938 #define SETJMP_WILL_LIKELY_WORK "\
2940 Emacs garbage collector has been changed to use conservative stack\n\
2941 marking. Emacs has determined that the method it uses to do the\n\
2942 marking will likely work on your system, but this isn't sure.\n\
2944 If you are a system-programmer, or can get the help of a local wizard\n\
2945 who is, please take a look at the function mark_stack in alloc.c, and\n\
2946 verify that the methods used are appropriate for your system.\n\
2948 Please mail the result to <gerd@gnu.org>.\n\
2951 #define SETJMP_WILL_NOT_WORK "\
2953 Emacs garbage collector has been changed to use conservative stack\n\
2954 marking. Emacs has determined that the default method it uses to do the\n\
2955 marking will not work on your system. We will need a system-dependent\n\
2956 solution for your system.\n\
2958 Please take a look at the function mark_stack in alloc.c, and\n\
2959 try to find a way to make it work on your system.\n\
2960 Please mail the result to <gerd@gnu.org>.\n\
2964 /* Perform a quick check if it looks like setjmp saves registers in a
2965 jmp_buf. Print a message to stderr saying so. When this test
2966 succeeds, this is _not_ a proof that setjmp is sufficient for
2967 conservative stack marking. Only the sources or a disassembly
2978 /* Arrange for X to be put in a register. */
2984 if (longjmps_done
== 1)
2986 /* Came here after the longjmp at the end of the function.
2988 If x == 1, the longjmp has restored the register to its
2989 value before the setjmp, and we can hope that setjmp
2990 saves all such registers in the jmp_buf, although that
2993 For other values of X, either something really strange is
2994 taking place, or the setjmp just didn't save the register. */
2997 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3000 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3007 if (longjmps_done
== 1)
3011 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3014 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3016 /* Abort if anything GCPRO'd doesn't survive the GC. */
3024 for (p
= gcprolist
; p
; p
= p
->next
)
3025 for (i
= 0; i
< p
->nvars
; ++i
)
3026 if (!survives_gc_p (p
->var
[i
]))
3030 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3037 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3038 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3040 fprintf (stderr
, " %d = ", i
);
3041 debug_print (zombies
[i
]);
3045 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3048 /* Mark live Lisp objects on the C stack.
3050 There are several system-dependent problems to consider when
3051 porting this to new architectures:
3055 We have to mark Lisp objects in CPU registers that can hold local
3056 variables or are used to pass parameters.
3058 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3059 something that either saves relevant registers on the stack, or
3060 calls mark_maybe_object passing it each register's contents.
3062 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3063 implementation assumes that calling setjmp saves registers we need
3064 to see in a jmp_buf which itself lies on the stack. This doesn't
3065 have to be true! It must be verified for each system, possibly
3066 by taking a look at the source code of setjmp.
3070 Architectures differ in the way their processor stack is organized.
3071 For example, the stack might look like this
3074 | Lisp_Object | size = 4
3076 | something else | size = 2
3078 | Lisp_Object | size = 4
3082 In such a case, not every Lisp_Object will be aligned equally. To
3083 find all Lisp_Object on the stack it won't be sufficient to walk
3084 the stack in steps of 4 bytes. Instead, two passes will be
3085 necessary, one starting at the start of the stack, and a second
3086 pass starting at the start of the stack + 2. Likewise, if the
3087 minimal alignment of Lisp_Objects on the stack is 1, four passes
3088 would be necessary, each one starting with one byte more offset
3089 from the stack start.
3091 The current code assumes by default that Lisp_Objects are aligned
3092 equally on the stack. */
3098 int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3101 /* This trick flushes the register windows so that all the state of
3102 the process is contained in the stack. */
3107 /* Save registers that we need to see on the stack. We need to see
3108 registers used to hold register variables and registers used to
3110 #ifdef GC_SAVE_REGISTERS_ON_STACK
3111 GC_SAVE_REGISTERS_ON_STACK (end
);
3112 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3114 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3115 setjmp will definitely work, test it
3116 and print a message with the result
3118 if (!setjmp_tested_p
)
3120 setjmp_tested_p
= 1;
3123 #endif /* GC_SETJMP_WORKS */
3126 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3127 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3129 /* This assumes that the stack is a contiguous region in memory. If
3130 that's not the case, something has to be done here to iterate
3131 over the stack segments. */
3132 #if GC_LISP_OBJECT_ALIGNMENT == 1
3133 mark_memory (stack_base
, end
);
3134 mark_memory ((char *) stack_base
+ 1, end
);
3135 mark_memory ((char *) stack_base
+ 2, end
);
3136 mark_memory ((char *) stack_base
+ 3, end
);
3137 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3138 mark_memory (stack_base
, end
);
3139 mark_memory ((char *) stack_base
+ 2, end
);
3141 mark_memory (stack_base
, end
);
3144 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3150 #endif /* GC_MARK_STACK != 0 */
3154 /***********************************************************************
3155 Pure Storage Management
3156 ***********************************************************************/
3158 /* Return a string allocated in pure space. DATA is a buffer holding
3159 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3160 non-zero means make the result string multibyte.
3162 Must get an error if pure storage is full, since if it cannot hold
3163 a large string it may be able to hold conses that point to that
3164 string; then the string is not protected from gc. */
3167 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3173 struct Lisp_String
*s
;
3174 int string_size
, data_size
;
3176 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3178 string_size
= PAD (sizeof (struct Lisp_String
));
3179 data_size
= PAD (nbytes
+ 1);
3183 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3184 error ("Pure Lisp storage exhausted");
3186 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3187 pureptr
+= string_size
;
3188 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3189 pureptr
+= data_size
;
3192 s
->size_byte
= multibyte
? nbytes
: -1;
3193 bcopy (data
, s
->data
, nbytes
);
3194 s
->data
[nbytes
] = '\0';
3195 s
->intervals
= NULL_INTERVAL
;
3197 XSETSTRING (string
, s
);
3202 /* Return a cons allocated from pure space. Give it pure copies
3203 of CAR as car and CDR as cdr. */
3206 pure_cons (car
, cdr
)
3207 Lisp_Object car
, cdr
;
3209 register Lisp_Object
new;
3211 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3212 error ("Pure Lisp storage exhausted");
3213 XSETCONS (new, PUREBEG
+ pureptr
);
3214 pureptr
+= sizeof (struct Lisp_Cons
);
3215 XCAR (new) = Fpurecopy (car
);
3216 XCDR (new) = Fpurecopy (cdr
);
3221 /* Value is a float object with value NUM allocated from pure space. */
3224 make_pure_float (num
)
3227 register Lisp_Object
new;
3229 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3230 (double) boundary. Some architectures (like the sparc) require
3231 this, and I suspect that floats are rare enough that it's no
3232 tragedy for those that do. */
3235 char *p
= PUREBEG
+ pureptr
;
3239 alignment
= __alignof (struct Lisp_Float
);
3241 alignment
= sizeof (struct Lisp_Float
);
3244 alignment
= sizeof (struct Lisp_Float
);
3246 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3247 pureptr
= p
- PUREBEG
;
3250 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3251 error ("Pure Lisp storage exhausted");
3252 XSETFLOAT (new, PUREBEG
+ pureptr
);
3253 pureptr
+= sizeof (struct Lisp_Float
);
3254 XFLOAT_DATA (new) = num
;
3255 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3260 /* Return a vector with room for LEN Lisp_Objects allocated from
3264 make_pure_vector (len
)
3267 register Lisp_Object
new;
3268 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3269 + (len
- 1) * sizeof (Lisp_Object
));
3271 if (pureptr
+ size
> PURESIZE
)
3272 error ("Pure Lisp storage exhausted");
3274 XSETVECTOR (new, PUREBEG
+ pureptr
);
3276 XVECTOR (new)->size
= len
;
3281 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3282 "Make a copy of OBJECT in pure storage.\n\
3283 Recursively copies contents of vectors and cons cells.\n\
3284 Does not copy symbols. Copies strings without text properties.")
3286 register Lisp_Object obj
;
3288 if (NILP (Vpurify_flag
))
3291 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3292 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3296 return pure_cons (XCAR (obj
), XCDR (obj
));
3297 else if (FLOATP (obj
))
3298 return make_pure_float (XFLOAT_DATA (obj
));
3299 else if (STRINGP (obj
))
3300 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3301 STRING_BYTES (XSTRING (obj
)),
3302 STRING_MULTIBYTE (obj
));
3303 else if (COMPILEDP (obj
) || VECTORP (obj
))
3305 register struct Lisp_Vector
*vec
;
3306 register int i
, size
;
3308 size
= XVECTOR (obj
)->size
;
3309 if (size
& PSEUDOVECTOR_FLAG
)
3310 size
&= PSEUDOVECTOR_SIZE_MASK
;
3311 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3312 for (i
= 0; i
< size
; i
++)
3313 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3314 if (COMPILEDP (obj
))
3315 XSETCOMPILED (obj
, vec
);
3317 XSETVECTOR (obj
, vec
);
3320 else if (MARKERP (obj
))
3321 error ("Attempt to copy a marker to pure storage");
3328 /***********************************************************************
3330 ***********************************************************************/
3332 /* Recording what needs to be marked for gc. */
3334 struct gcpro
*gcprolist
;
3336 /* Addresses of staticpro'd variables. */
3338 #define NSTATICS 1024
3339 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3341 /* Index of next unused slot in staticvec. */
3346 /* Put an entry in staticvec, pointing at the variable with address
3350 staticpro (varaddress
)
3351 Lisp_Object
*varaddress
;
3353 staticvec
[staticidx
++] = varaddress
;
3354 if (staticidx
>= NSTATICS
)
3362 struct catchtag
*next
;
3367 struct backtrace
*next
;
3368 Lisp_Object
*function
;
3369 Lisp_Object
*args
; /* Points to vector of args. */
3370 int nargs
; /* Length of vector. */
3371 /* If nargs is UNEVALLED, args points to slot holding list of
3378 /***********************************************************************
3380 ***********************************************************************/
3382 /* Temporarily prevent garbage collection. */
3385 inhibit_garbage_collection ()
3387 int count
= specpdl_ptr
- specpdl
;
3389 int nbits
= min (VALBITS
, BITS_PER_INT
);
3391 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3393 specbind (Qgc_cons_threshold
, number
);
3399 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3400 "Reclaim storage for Lisp objects no longer needed.\n\
3401 Returns info on amount of space in use:\n\
3402 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3403 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3404 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3405 (USED-STRINGS . FREE-STRINGS))\n\
3406 Garbage collection happens automatically if you cons more than\n\
3407 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3410 register struct gcpro
*tail
;
3411 register struct specbinding
*bind
;
3412 struct catchtag
*catch;
3413 struct handler
*handler
;
3414 register struct backtrace
*backlist
;
3415 char stack_top_variable
;
3418 Lisp_Object total
[7];
3420 /* In case user calls debug_print during GC,
3421 don't let that cause a recursive GC. */
3422 consing_since_gc
= 0;
3424 /* Save what's currently displayed in the echo area. */
3425 message_p
= push_message ();
3427 /* Save a copy of the contents of the stack, for debugging. */
3428 #if MAX_SAVE_STACK > 0
3429 if (NILP (Vpurify_flag
))
3431 i
= &stack_top_variable
- stack_bottom
;
3433 if (i
< MAX_SAVE_STACK
)
3435 if (stack_copy
== 0)
3436 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3437 else if (stack_copy_size
< i
)
3438 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3441 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3442 bcopy (stack_bottom
, stack_copy
, i
);
3444 bcopy (&stack_top_variable
, stack_copy
, i
);
3448 #endif /* MAX_SAVE_STACK > 0 */
3450 if (garbage_collection_messages
)
3451 message1_nolog ("Garbage collecting...");
3455 shrink_regexp_cache ();
3457 /* Don't keep undo information around forever. */
3459 register struct buffer
*nextb
= all_buffers
;
3463 /* If a buffer's undo list is Qt, that means that undo is
3464 turned off in that buffer. Calling truncate_undo_list on
3465 Qt tends to return NULL, which effectively turns undo back on.
3466 So don't call truncate_undo_list if undo_list is Qt. */
3467 if (! EQ (nextb
->undo_list
, Qt
))
3469 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3471 nextb
= nextb
->next
;
3477 /* clear_marks (); */
3479 /* Mark all the special slots that serve as the roots of accessibility.
3481 Usually the special slots to mark are contained in particular structures.
3482 Then we know no slot is marked twice because the structures don't overlap.
3483 In some cases, the structures point to the slots to be marked.
3484 For these, we use MARKBIT to avoid double marking of the slot. */
3486 for (i
= 0; i
< staticidx
; i
++)
3487 mark_object (staticvec
[i
]);
3489 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3490 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3493 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3494 for (i
= 0; i
< tail
->nvars
; i
++)
3495 if (!XMARKBIT (tail
->var
[i
]))
3497 mark_object (&tail
->var
[i
]);
3498 XMARK (tail
->var
[i
]);
3503 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3505 mark_object (&bind
->symbol
);
3506 mark_object (&bind
->old_value
);
3508 for (catch = catchlist
; catch; catch = catch->next
)
3510 mark_object (&catch->tag
);
3511 mark_object (&catch->val
);
3513 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3515 mark_object (&handler
->handler
);
3516 mark_object (&handler
->var
);
3518 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3520 if (!XMARKBIT (*backlist
->function
))
3522 mark_object (backlist
->function
);
3523 XMARK (*backlist
->function
);
3525 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3528 i
= backlist
->nargs
- 1;
3530 if (!XMARKBIT (backlist
->args
[i
]))
3532 mark_object (&backlist
->args
[i
]);
3533 XMARK (backlist
->args
[i
]);
3538 /* Look thru every buffer's undo list
3539 for elements that update markers that were not marked,
3542 register struct buffer
*nextb
= all_buffers
;
3546 /* If a buffer's undo list is Qt, that means that undo is
3547 turned off in that buffer. Calling truncate_undo_list on
3548 Qt tends to return NULL, which effectively turns undo back on.
3549 So don't call truncate_undo_list if undo_list is Qt. */
3550 if (! EQ (nextb
->undo_list
, Qt
))
3552 Lisp_Object tail
, prev
;
3553 tail
= nextb
->undo_list
;
3555 while (CONSP (tail
))
3557 if (GC_CONSP (XCAR (tail
))
3558 && GC_MARKERP (XCAR (XCAR (tail
)))
3559 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3562 nextb
->undo_list
= tail
= XCDR (tail
);
3564 tail
= XCDR (prev
) = XCDR (tail
);
3574 nextb
= nextb
->next
;
3578 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3584 /* Clear the mark bits that we set in certain root slots. */
3586 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3587 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3588 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3589 for (i
= 0; i
< tail
->nvars
; i
++)
3590 XUNMARK (tail
->var
[i
]);
3593 unmark_byte_stack ();
3594 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3596 XUNMARK (*backlist
->function
);
3597 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3600 i
= backlist
->nargs
- 1;
3602 XUNMARK (backlist
->args
[i
]);
3604 XUNMARK (buffer_defaults
.name
);
3605 XUNMARK (buffer_local_symbols
.name
);
3607 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3613 /* clear_marks (); */
3616 consing_since_gc
= 0;
3617 if (gc_cons_threshold
< 10000)
3618 gc_cons_threshold
= 10000;
3620 if (garbage_collection_messages
)
3622 if (message_p
|| minibuf_level
> 0)
3625 message1_nolog ("Garbage collecting...done");
3630 total
[0] = Fcons (make_number (total_conses
),
3631 make_number (total_free_conses
));
3632 total
[1] = Fcons (make_number (total_symbols
),
3633 make_number (total_free_symbols
));
3634 total
[2] = Fcons (make_number (total_markers
),
3635 make_number (total_free_markers
));
3636 total
[3] = Fcons (make_number (total_string_size
),
3637 make_number (total_vector_size
));
3638 total
[4] = Fcons (make_number (total_floats
),
3639 make_number (total_free_floats
));
3640 total
[5] = Fcons (make_number (total_intervals
),
3641 make_number (total_free_intervals
));
3642 total
[6] = Fcons (make_number (total_strings
),
3643 make_number (total_free_strings
));
3645 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3647 /* Compute average percentage of zombies. */
3650 for (i
= 0; i
< 7; ++i
)
3651 nlive
+= XFASTINT (XCAR (total
[i
]));
3653 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3654 max_live
= max (nlive
, max_live
);
3655 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3656 max_zombies
= max (nzombies
, max_zombies
);
3661 return Flist (7, total
);
3665 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3666 only interesting objects referenced from glyphs are strings. */
3669 mark_glyph_matrix (matrix
)
3670 struct glyph_matrix
*matrix
;
3672 struct glyph_row
*row
= matrix
->rows
;
3673 struct glyph_row
*end
= row
+ matrix
->nrows
;
3675 for (; row
< end
; ++row
)
3679 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3681 struct glyph
*glyph
= row
->glyphs
[area
];
3682 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3684 for (; glyph
< end_glyph
; ++glyph
)
3685 if (GC_STRINGP (glyph
->object
)
3686 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3687 mark_object (&glyph
->object
);
3693 /* Mark Lisp faces in the face cache C. */
3697 struct face_cache
*c
;
3702 for (i
= 0; i
< c
->used
; ++i
)
3704 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3708 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3709 mark_object (&face
->lface
[j
]);
3716 #ifdef HAVE_WINDOW_SYSTEM
3718 /* Mark Lisp objects in image IMG. */
3724 mark_object (&img
->spec
);
3726 if (!NILP (img
->data
.lisp_val
))
3727 mark_object (&img
->data
.lisp_val
);
3731 /* Mark Lisp objects in image cache of frame F. It's done this way so
3732 that we don't have to include xterm.h here. */
3735 mark_image_cache (f
)
3738 forall_images_in_image_cache (f
, mark_image
);
3741 #endif /* HAVE_X_WINDOWS */
3745 /* Mark reference to a Lisp_Object.
3746 If the object referred to has not been seen yet, recursively mark
3747 all the references contained in it. */
3749 #define LAST_MARKED_SIZE 500
3750 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3751 int last_marked_index
;
3754 mark_object (argptr
)
3755 Lisp_Object
*argptr
;
3757 Lisp_Object
*objptr
= argptr
;
3758 register Lisp_Object obj
;
3765 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3768 last_marked
[last_marked_index
++] = objptr
;
3769 if (last_marked_index
== LAST_MARKED_SIZE
)
3770 last_marked_index
= 0;
3772 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3776 register struct Lisp_String
*ptr
= XSTRING (obj
);
3777 MARK_INTERVAL_TREE (ptr
->intervals
);
3782 case Lisp_Vectorlike
:
3783 if (GC_BUFFERP (obj
))
3785 if (!XMARKBIT (XBUFFER (obj
)->name
))
3788 else if (GC_SUBRP (obj
))
3790 else if (GC_COMPILEDP (obj
))
3791 /* We could treat this just like a vector, but it is better to
3792 save the COMPILED_CONSTANTS element for last and avoid
3795 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3796 register EMACS_INT size
= ptr
->size
;
3797 /* See comment above under Lisp_Vector. */
3798 struct Lisp_Vector
*volatile ptr1
= ptr
;
3801 if (size
& ARRAY_MARK_FLAG
)
3802 break; /* Already marked */
3803 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3804 size
&= PSEUDOVECTOR_SIZE_MASK
;
3805 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3807 if (i
!= COMPILED_CONSTANTS
)
3808 mark_object (&ptr1
->contents
[i
]);
3810 /* This cast should be unnecessary, but some Mips compiler complains
3811 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3812 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
3815 else if (GC_FRAMEP (obj
))
3817 /* See comment above under Lisp_Vector for why this is volatile. */
3818 register struct frame
*volatile ptr
= XFRAME (obj
);
3819 register EMACS_INT size
= ptr
->size
;
3821 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3822 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3824 mark_object (&ptr
->name
);
3825 mark_object (&ptr
->icon_name
);
3826 mark_object (&ptr
->title
);
3827 mark_object (&ptr
->focus_frame
);
3828 mark_object (&ptr
->selected_window
);
3829 mark_object (&ptr
->minibuffer_window
);
3830 mark_object (&ptr
->param_alist
);
3831 mark_object (&ptr
->scroll_bars
);
3832 mark_object (&ptr
->condemned_scroll_bars
);
3833 mark_object (&ptr
->menu_bar_items
);
3834 mark_object (&ptr
->face_alist
);
3835 mark_object (&ptr
->menu_bar_vector
);
3836 mark_object (&ptr
->buffer_predicate
);
3837 mark_object (&ptr
->buffer_list
);
3838 mark_object (&ptr
->menu_bar_window
);
3839 mark_object (&ptr
->tool_bar_window
);
3840 mark_face_cache (ptr
->face_cache
);
3841 #ifdef HAVE_WINDOW_SYSTEM
3842 mark_image_cache (ptr
);
3843 mark_object (&ptr
->desired_tool_bar_items
);
3844 mark_object (&ptr
->current_tool_bar_items
);
3845 mark_object (&ptr
->desired_tool_bar_string
);
3846 mark_object (&ptr
->current_tool_bar_string
);
3847 #endif /* HAVE_WINDOW_SYSTEM */
3849 else if (GC_BOOL_VECTOR_P (obj
))
3851 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3853 if (ptr
->size
& ARRAY_MARK_FLAG
)
3854 break; /* Already marked */
3855 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3857 else if (GC_WINDOWP (obj
))
3859 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3860 struct window
*w
= XWINDOW (obj
);
3861 register EMACS_INT size
= ptr
->size
;
3862 /* The reason we use ptr1 is to avoid an apparent hardware bug
3863 that happens occasionally on the FSF's HP 300s.
3864 The bug is that a2 gets clobbered by recursive calls to mark_object.
3865 The clobberage seems to happen during function entry,
3866 perhaps in the moveml instruction.
3867 Yes, this is a crock, but we have to do it. */
3868 struct Lisp_Vector
*volatile ptr1
= ptr
;
3871 /* Stop if already marked. */
3872 if (size
& ARRAY_MARK_FLAG
)
3876 ptr
->size
|= ARRAY_MARK_FLAG
;
3878 /* There is no Lisp data above The member CURRENT_MATRIX in
3879 struct WINDOW. Stop marking when that slot is reached. */
3881 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
3883 mark_object (&ptr1
->contents
[i
]);
3885 /* Mark glyphs for leaf windows. Marking window matrices is
3886 sufficient because frame matrices use the same glyph
3888 if (NILP (w
->hchild
)
3890 && w
->current_matrix
)
3892 mark_glyph_matrix (w
->current_matrix
);
3893 mark_glyph_matrix (w
->desired_matrix
);
3896 else if (GC_HASH_TABLE_P (obj
))
3898 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
3899 EMACS_INT size
= h
->size
;
3901 /* Stop if already marked. */
3902 if (size
& ARRAY_MARK_FLAG
)
3906 h
->size
|= ARRAY_MARK_FLAG
;
3908 /* Mark contents. */
3909 mark_object (&h
->test
);
3910 mark_object (&h
->weak
);
3911 mark_object (&h
->rehash_size
);
3912 mark_object (&h
->rehash_threshold
);
3913 mark_object (&h
->hash
);
3914 mark_object (&h
->next
);
3915 mark_object (&h
->index
);
3916 mark_object (&h
->user_hash_function
);
3917 mark_object (&h
->user_cmp_function
);
3919 /* If hash table is not weak, mark all keys and values.
3920 For weak tables, mark only the vector. */
3921 if (GC_NILP (h
->weak
))
3922 mark_object (&h
->key_and_value
);
3924 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
3929 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3930 register EMACS_INT size
= ptr
->size
;
3931 /* The reason we use ptr1 is to avoid an apparent hardware bug
3932 that happens occasionally on the FSF's HP 300s.
3933 The bug is that a2 gets clobbered by recursive calls to mark_object.
3934 The clobberage seems to happen during function entry,
3935 perhaps in the moveml instruction.
3936 Yes, this is a crock, but we have to do it. */
3937 struct Lisp_Vector
*volatile ptr1
= ptr
;
3940 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3941 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3942 if (size
& PSEUDOVECTOR_FLAG
)
3943 size
&= PSEUDOVECTOR_SIZE_MASK
;
3945 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3946 mark_object (&ptr1
->contents
[i
]);
3952 /* See comment above under Lisp_Vector for why this is volatile. */
3953 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
3954 struct Lisp_Symbol
*ptrx
;
3956 if (XMARKBIT (ptr
->plist
)) break;
3958 mark_object ((Lisp_Object
*) &ptr
->value
);
3959 mark_object (&ptr
->function
);
3960 mark_object (&ptr
->plist
);
3962 if (!PURE_POINTER_P (ptr
->name
))
3963 MARK_STRING (ptr
->name
);
3964 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
3966 /* Note that we do not mark the obarray of the symbol.
3967 It is safe not to do so because nothing accesses that
3968 slot except to check whether it is nil. */
3972 /* For the benefit of the last_marked log. */
3973 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
3974 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
3975 XSETSYMBOL (obj
, ptrx
);
3976 /* We can't goto loop here because *objptr doesn't contain an
3977 actual Lisp_Object with valid datatype field. */
3984 switch (XMISCTYPE (obj
))
3986 case Lisp_Misc_Marker
:
3987 XMARK (XMARKER (obj
)->chain
);
3988 /* DO NOT mark thru the marker's chain.
3989 The buffer's markers chain does not preserve markers from gc;
3990 instead, markers are removed from the chain when freed by gc. */
3993 case Lisp_Misc_Buffer_Local_Value
:
3994 case Lisp_Misc_Some_Buffer_Local_Value
:
3996 register struct Lisp_Buffer_Local_Value
*ptr
3997 = XBUFFER_LOCAL_VALUE (obj
);
3998 if (XMARKBIT (ptr
->realvalue
)) break;
3999 XMARK (ptr
->realvalue
);
4000 /* If the cdr is nil, avoid recursion for the car. */
4001 if (EQ (ptr
->cdr
, Qnil
))
4003 objptr
= &ptr
->realvalue
;
4006 mark_object (&ptr
->realvalue
);
4007 mark_object (&ptr
->buffer
);
4008 mark_object (&ptr
->frame
);
4009 /* See comment above under Lisp_Vector for why not use ptr here. */
4010 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
4014 case Lisp_Misc_Intfwd
:
4015 case Lisp_Misc_Boolfwd
:
4016 case Lisp_Misc_Objfwd
:
4017 case Lisp_Misc_Buffer_Objfwd
:
4018 case Lisp_Misc_Kboard_Objfwd
:
4019 /* Don't bother with Lisp_Buffer_Objfwd,
4020 since all markable slots in current buffer marked anyway. */
4021 /* Don't need to do Lisp_Objfwd, since the places they point
4022 are protected with staticpro. */
4025 case Lisp_Misc_Overlay
:
4027 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4028 if (!XMARKBIT (ptr
->plist
))
4031 mark_object (&ptr
->start
);
4032 mark_object (&ptr
->end
);
4033 objptr
= &ptr
->plist
;
4046 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4047 if (XMARKBIT (ptr
->car
)) break;
4049 /* If the cdr is nil, avoid recursion for the car. */
4050 if (EQ (ptr
->cdr
, Qnil
))
4055 mark_object (&ptr
->car
);
4056 /* See comment above under Lisp_Vector for why not use ptr here. */
4057 objptr
= &XCDR (obj
);
4062 XMARK (XFLOAT (obj
)->type
);
4073 /* Mark the pointers in a buffer structure. */
4079 register struct buffer
*buffer
= XBUFFER (buf
);
4080 register Lisp_Object
*ptr
;
4081 Lisp_Object base_buffer
;
4083 /* This is the buffer's markbit */
4084 mark_object (&buffer
->name
);
4085 XMARK (buffer
->name
);
4087 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4089 if (CONSP (buffer
->undo_list
))
4092 tail
= buffer
->undo_list
;
4094 while (CONSP (tail
))
4096 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4098 if (XMARKBIT (ptr
->car
))
4101 if (GC_CONSP (ptr
->car
)
4102 && ! XMARKBIT (XCAR (ptr
->car
))
4103 && GC_MARKERP (XCAR (ptr
->car
)))
4105 XMARK (XCAR (ptr
->car
));
4106 mark_object (&XCDR (ptr
->car
));
4109 mark_object (&ptr
->car
);
4111 if (CONSP (ptr
->cdr
))
4117 mark_object (&XCDR (tail
));
4120 mark_object (&buffer
->undo_list
);
4122 for (ptr
= &buffer
->name
+ 1;
4123 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4127 /* If this is an indirect buffer, mark its base buffer. */
4128 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4130 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4131 mark_buffer (base_buffer
);
4136 /* Mark the pointers in the kboard objects. */
4143 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4145 if (kb
->kbd_macro_buffer
)
4146 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4148 mark_object (&kb
->Voverriding_terminal_local_map
);
4149 mark_object (&kb
->Vlast_command
);
4150 mark_object (&kb
->Vreal_last_command
);
4151 mark_object (&kb
->Vprefix_arg
);
4152 mark_object (&kb
->Vlast_prefix_arg
);
4153 mark_object (&kb
->kbd_queue
);
4154 mark_object (&kb
->defining_kbd_macro
);
4155 mark_object (&kb
->Vlast_kbd_macro
);
4156 mark_object (&kb
->Vsystem_key_alist
);
4157 mark_object (&kb
->system_key_syms
);
4158 mark_object (&kb
->Vdefault_minibuffer_frame
);
4163 /* Value is non-zero if OBJ will survive the current GC because it's
4164 either marked or does not need to be marked to survive. */
4172 switch (XGCTYPE (obj
))
4179 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4183 switch (XMISCTYPE (obj
))
4185 case Lisp_Misc_Marker
:
4186 survives_p
= XMARKBIT (obj
);
4189 case Lisp_Misc_Buffer_Local_Value
:
4190 case Lisp_Misc_Some_Buffer_Local_Value
:
4191 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4194 case Lisp_Misc_Intfwd
:
4195 case Lisp_Misc_Boolfwd
:
4196 case Lisp_Misc_Objfwd
:
4197 case Lisp_Misc_Buffer_Objfwd
:
4198 case Lisp_Misc_Kboard_Objfwd
:
4202 case Lisp_Misc_Overlay
:
4203 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4213 struct Lisp_String
*s
= XSTRING (obj
);
4214 survives_p
= STRING_MARKED_P (s
);
4218 case Lisp_Vectorlike
:
4219 if (GC_BUFFERP (obj
))
4220 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4221 else if (GC_SUBRP (obj
))
4224 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4228 survives_p
= XMARKBIT (XCAR (obj
));
4232 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4239 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4244 /* Sweep: find all structures not marked, and free them. */
4249 /* Remove or mark entries in weak hash tables.
4250 This must be done before any object is unmarked. */
4251 sweep_weak_hash_tables ();
4255 /* Put all unmarked conses on free list */
4257 register struct cons_block
*cblk
;
4258 struct cons_block
**cprev
= &cons_block
;
4259 register int lim
= cons_block_index
;
4260 register int num_free
= 0, num_used
= 0;
4264 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4268 for (i
= 0; i
< lim
; i
++)
4269 if (!XMARKBIT (cblk
->conses
[i
].car
))
4272 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4273 cons_free_list
= &cblk
->conses
[i
];
4275 cons_free_list
->car
= Vdead
;
4281 XUNMARK (cblk
->conses
[i
].car
);
4283 lim
= CONS_BLOCK_SIZE
;
4284 /* If this block contains only free conses and we have already
4285 seen more than two blocks worth of free conses then deallocate
4287 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4289 *cprev
= cblk
->next
;
4290 /* Unhook from the free list. */
4291 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4297 num_free
+= this_free
;
4298 cprev
= &cblk
->next
;
4301 total_conses
= num_used
;
4302 total_free_conses
= num_free
;
4305 /* Put all unmarked floats on free list */
4307 register struct float_block
*fblk
;
4308 struct float_block
**fprev
= &float_block
;
4309 register int lim
= float_block_index
;
4310 register int num_free
= 0, num_used
= 0;
4312 float_free_list
= 0;
4314 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4318 for (i
= 0; i
< lim
; i
++)
4319 if (!XMARKBIT (fblk
->floats
[i
].type
))
4322 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4323 float_free_list
= &fblk
->floats
[i
];
4325 float_free_list
->type
= Vdead
;
4331 XUNMARK (fblk
->floats
[i
].type
);
4333 lim
= FLOAT_BLOCK_SIZE
;
4334 /* If this block contains only free floats and we have already
4335 seen more than two blocks worth of free floats then deallocate
4337 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4339 *fprev
= fblk
->next
;
4340 /* Unhook from the free list. */
4341 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4347 num_free
+= this_free
;
4348 fprev
= &fblk
->next
;
4351 total_floats
= num_used
;
4352 total_free_floats
= num_free
;
4355 /* Put all unmarked intervals on free list */
4357 register struct interval_block
*iblk
;
4358 struct interval_block
**iprev
= &interval_block
;
4359 register int lim
= interval_block_index
;
4360 register int num_free
= 0, num_used
= 0;
4362 interval_free_list
= 0;
4364 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4369 for (i
= 0; i
< lim
; i
++)
4371 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4373 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4374 interval_free_list
= &iblk
->intervals
[i
];
4380 XUNMARK (iblk
->intervals
[i
].plist
);
4383 lim
= INTERVAL_BLOCK_SIZE
;
4384 /* If this block contains only free intervals and we have already
4385 seen more than two blocks worth of free intervals then
4386 deallocate this block. */
4387 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4389 *iprev
= iblk
->next
;
4390 /* Unhook from the free list. */
4391 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4393 n_interval_blocks
--;
4397 num_free
+= this_free
;
4398 iprev
= &iblk
->next
;
4401 total_intervals
= num_used
;
4402 total_free_intervals
= num_free
;
4405 /* Put all unmarked symbols on free list */
4407 register struct symbol_block
*sblk
;
4408 struct symbol_block
**sprev
= &symbol_block
;
4409 register int lim
= symbol_block_index
;
4410 register int num_free
= 0, num_used
= 0;
4412 symbol_free_list
= 0;
4414 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4418 for (i
= 0; i
< lim
; i
++)
4419 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4421 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4422 symbol_free_list
= &sblk
->symbols
[i
];
4424 symbol_free_list
->function
= Vdead
;
4431 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4432 UNMARK_STRING (sblk
->symbols
[i
].name
);
4433 XUNMARK (sblk
->symbols
[i
].plist
);
4435 lim
= SYMBOL_BLOCK_SIZE
;
4436 /* If this block contains only free symbols and we have already
4437 seen more than two blocks worth of free symbols then deallocate
4439 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4441 *sprev
= sblk
->next
;
4442 /* Unhook from the free list. */
4443 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4449 num_free
+= this_free
;
4450 sprev
= &sblk
->next
;
4453 total_symbols
= num_used
;
4454 total_free_symbols
= num_free
;
4457 /* Put all unmarked misc's on free list.
4458 For a marker, first unchain it from the buffer it points into. */
4460 register struct marker_block
*mblk
;
4461 struct marker_block
**mprev
= &marker_block
;
4462 register int lim
= marker_block_index
;
4463 register int num_free
= 0, num_used
= 0;
4465 marker_free_list
= 0;
4467 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4471 EMACS_INT already_free
= -1;
4473 for (i
= 0; i
< lim
; i
++)
4475 Lisp_Object
*markword
;
4476 switch (mblk
->markers
[i
].u_marker
.type
)
4478 case Lisp_Misc_Marker
:
4479 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4481 case Lisp_Misc_Buffer_Local_Value
:
4482 case Lisp_Misc_Some_Buffer_Local_Value
:
4483 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4485 case Lisp_Misc_Overlay
:
4486 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4488 case Lisp_Misc_Free
:
4489 /* If the object was already free, keep it
4490 on the free list. */
4491 markword
= (Lisp_Object
*) &already_free
;
4497 if (markword
&& !XMARKBIT (*markword
))
4500 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4502 /* tem1 avoids Sun compiler bug */
4503 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4504 XSETMARKER (tem
, tem1
);
4505 unchain_marker (tem
);
4507 /* Set the type of the freed object to Lisp_Misc_Free.
4508 We could leave the type alone, since nobody checks it,
4509 but this might catch bugs faster. */
4510 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4511 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4512 marker_free_list
= &mblk
->markers
[i
];
4519 XUNMARK (*markword
);
4522 lim
= MARKER_BLOCK_SIZE
;
4523 /* If this block contains only free markers and we have already
4524 seen more than two blocks worth of free markers then deallocate
4526 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4528 *mprev
= mblk
->next
;
4529 /* Unhook from the free list. */
4530 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4536 num_free
+= this_free
;
4537 mprev
= &mblk
->next
;
4541 total_markers
= num_used
;
4542 total_free_markers
= num_free
;
4545 /* Free all unmarked buffers */
4547 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4550 if (!XMARKBIT (buffer
->name
))
4553 prev
->next
= buffer
->next
;
4555 all_buffers
= buffer
->next
;
4556 next
= buffer
->next
;
4562 XUNMARK (buffer
->name
);
4563 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4564 prev
= buffer
, buffer
= buffer
->next
;
4568 /* Free all unmarked vectors */
4570 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4571 total_vector_size
= 0;
4574 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4577 prev
->next
= vector
->next
;
4579 all_vectors
= vector
->next
;
4580 next
= vector
->next
;
4588 vector
->size
&= ~ARRAY_MARK_FLAG
;
4589 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4590 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4592 total_vector_size
+= vector
->size
;
4593 prev
= vector
, vector
= vector
->next
;
4601 /* Debugging aids. */
4603 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4604 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4605 This may be helpful in debugging Emacs's memory usage.\n\
4606 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4611 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4616 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4617 "Return a list of counters that measure how much consing there has been.\n\
4618 Each of these counters increments for a certain kind of object.\n\
4619 The counters wrap around from the largest positive integer to zero.\n\
4620 Garbage collection does not decrease them.\n\
4621 The elements of the value are as follows:\n\
4622 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4623 All are in units of 1 = one object consed\n\
4624 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4626 MISCS include overlays, markers, and some internal types.\n\
4627 Frames, windows, buffers, and subprocesses count as vectors\n\
4628 (but the contents of a buffer's text do not count here).")
4631 Lisp_Object consed
[8];
4634 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4636 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4638 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4640 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4642 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4644 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4646 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4648 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4650 return Flist (8, consed
);
4653 int suppress_checking
;
4655 die (msg
, file
, line
)
4660 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4665 /* Initialization */
4670 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4674 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4677 pure_size
= PURESIZE
;
4680 ignore_warnings
= 1;
4681 #ifdef DOUG_LEA_MALLOC
4682 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4683 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4684 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4694 malloc_hysteresis
= 32;
4696 malloc_hysteresis
= 0;
4699 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4701 ignore_warnings
= 0;
4703 byte_stack_list
= 0;
4705 consing_since_gc
= 0;
4706 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4707 #ifdef VIRT_ADDR_VARIES
4708 malloc_sbrk_unused
= 1<<22; /* A large number */
4709 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4710 #endif /* VIRT_ADDR_VARIES */
4717 byte_stack_list
= 0;
4719 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4720 setjmp_tested_p
= longjmps_done
= 0;
4728 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4729 "*Number of bytes of consing between garbage collections.\n\
4730 Garbage collection can happen automatically once this many bytes have been\n\
4731 allocated since the last garbage collection. All data types count.\n\n\
4732 Garbage collection happens automatically only when `eval' is called.\n\n\
4733 By binding this temporarily to a large number, you can effectively\n\
4734 prevent garbage collection during a part of the program.");
4736 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4737 "Number of bytes of sharable Lisp data allocated so far.");
4739 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4740 "Number of cons cells that have been consed so far.");
4742 DEFVAR_INT ("floats-consed", &floats_consed
,
4743 "Number of floats that have been consed so far.");
4745 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4746 "Number of vector cells that have been consed so far.");
4748 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4749 "Number of symbols that have been consed so far.");
4751 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4752 "Number of string characters that have been consed so far.");
4754 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4755 "Number of miscellaneous objects that have been consed so far.");
4757 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4758 "Number of intervals that have been consed so far.");
4760 DEFVAR_INT ("strings-consed", &strings_consed
,
4761 "Number of strings that have been consed so far.");
4763 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4764 "Non-nil means loading Lisp code in order to dump an executable.\n\
4765 This means that certain objects should be allocated in shared (pure) space.");
4767 DEFVAR_INT ("undo-limit", &undo_limit
,
4768 "Keep no more undo information once it exceeds this size.\n\
4769 This limit is applied when garbage collection happens.\n\
4770 The size is counted as the number of bytes occupied,\n\
4771 which includes both saved text and other data.");
4774 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
4775 "Don't keep more than this much size of undo information.\n\
4776 A command which pushes past this size is itself forgotten.\n\
4777 This limit is applied when garbage collection happens.\n\
4778 The size is counted as the number of bytes occupied,\n\
4779 which includes both saved text and other data.");
4780 undo_strong_limit
= 30000;
4782 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
4783 "Non-nil means display messages at start and end of garbage collection.");
4784 garbage_collection_messages
= 0;
4786 /* We build this in advance because if we wait until we need it, we might
4787 not be able to allocate the memory to hold it. */
4789 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
4790 staticpro (&memory_signal_data
);
4792 staticpro (&Qgc_cons_threshold
);
4793 Qgc_cons_threshold
= intern ("gc-cons-threshold");
4795 staticpro (&Qchar_table_extra_slots
);
4796 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
4801 defsubr (&Smake_byte_code
);
4802 defsubr (&Smake_list
);
4803 defsubr (&Smake_vector
);
4804 defsubr (&Smake_char_table
);
4805 defsubr (&Smake_string
);
4806 defsubr (&Smake_bool_vector
);
4807 defsubr (&Smake_symbol
);
4808 defsubr (&Smake_marker
);
4809 defsubr (&Spurecopy
);
4810 defsubr (&Sgarbage_collect
);
4811 defsubr (&Smemory_limit
);
4812 defsubr (&Smemory_use_counts
);
4814 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4815 defsubr (&Sgc_status
);