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. */
24 /* Note that this declares bzero on OSF/1. How dumb. */
28 /* This file is part of the core Lisp implementation, and thus must
29 deal with the real data structures. If the Lisp implementation is
30 replaced, this file likely will not be used. */
32 #undef HIDE_LISP_IMPLEMENTATION
34 #include "intervals.h"
39 #include "blockinput.h"
42 #include "syssignal.h"
47 #ifdef DOUG_LEA_MALLOC
50 #define __malloc_size_t int
52 /* Specify maximum number of areas to mmap. It would be nice to use a
53 value that explicitly means "no limit". */
55 #define MMAP_MAX_AREAS 100000000
57 #else /* not DOUG_LEA_MALLOC */
59 /* The following come from gmalloc.c. */
61 #if defined (__STDC__) && __STDC__
63 #define __malloc_size_t size_t
65 #define __malloc_size_t unsigned int
67 extern __malloc_size_t _bytes_used
;
68 extern int __malloc_extra_blocks
;
70 #endif /* not DOUG_LEA_MALLOC */
72 #define max(A,B) ((A) > (B) ? (A) : (B))
73 #define min(A,B) ((A) < (B) ? (A) : (B))
75 /* Macro to verify that storage intended for Lisp objects is not
76 out of range to fit in the space for a pointer.
77 ADDRESS is the start of the block, and SIZE
78 is the amount of space within which objects can start. */
80 #define VALIDATE_LISP_STORAGE(address, size) \
84 XSETCONS (val, (char *) address + size); \
85 if ((char *) XCONS (val) != (char *) address + size) \
92 /* Value of _bytes_used, when spare_memory was freed. */
94 static __malloc_size_t bytes_used_when_full
;
96 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
97 to a struct Lisp_String. */
99 #define MARK_STRING(S) XMARK ((S)->size)
100 #define UNMARK_STRING(S) XUNMARK ((S)->size)
101 #define STRING_MARKED_P(S) XMARKBIT ((S)->size)
103 /* Value is the number of bytes/chars of S, a pointer to a struct
104 Lisp_String. This must be used instead of STRING_BYTES (S) or
105 S->size during GC, because S->size contains the mark bit for
108 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
109 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
111 /* Number of bytes of consing done since the last gc. */
113 int consing_since_gc
;
115 /* Count the amount of consing of various sorts of space. */
117 int cons_cells_consed
;
119 int vector_cells_consed
;
121 int string_chars_consed
;
122 int misc_objects_consed
;
123 int intervals_consed
;
126 /* Number of bytes of consing since GC before another GC should be done. */
128 int gc_cons_threshold
;
130 /* Nonzero during GC. */
134 /* Nonzero means display messages at beginning and end of GC. */
136 int garbage_collection_messages
;
138 #ifndef VIRT_ADDR_VARIES
140 #endif /* VIRT_ADDR_VARIES */
141 int malloc_sbrk_used
;
143 #ifndef VIRT_ADDR_VARIES
145 #endif /* VIRT_ADDR_VARIES */
146 int malloc_sbrk_unused
;
148 /* Two limits controlling how much undo information to keep. */
151 int undo_strong_limit
;
153 /* Number of live and free conses etc. */
155 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
156 static int total_free_conses
, total_free_markers
, total_free_symbols
;
157 static int total_free_floats
, total_floats
;
159 /* Points to memory space allocated as "spare", to be freed if we run
162 static char *spare_memory
;
164 /* Amount of spare memory to keep in reserve. */
166 #define SPARE_MEMORY (1 << 14)
168 /* Number of extra blocks malloc should get when it needs more core. */
170 static int malloc_hysteresis
;
172 /* Nonzero when malloc is called for allocating Lisp object space.
173 Currently set but not used. */
175 int allocating_for_lisp
;
177 /* Non-nil means defun should do purecopy on the function definition. */
179 Lisp_Object Vpurify_flag
;
183 /* Force it into data space! */
185 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,};
186 #define PUREBEG (char *) pure
188 #else /* not HAVE_SHM */
190 #define pure PURE_SEG_BITS /* Use shared memory segment */
191 #define PUREBEG (char *)PURE_SEG_BITS
193 /* This variable is used only by the XPNTR macro when HAVE_SHM is
194 defined. If we used the PURESIZE macro directly there, that would
195 make most of Emacs dependent on puresize.h, which we don't want -
196 you should be able to change that without too much recompilation.
197 So map_in_data initializes pure_size, and the dependencies work
202 #endif /* not HAVE_SHM */
204 /* Value is non-zero if P points into pure space. */
206 #define PURE_POINTER_P(P) \
207 (((PNTR_COMPARISON_TYPE) (P) \
208 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
209 && ((PNTR_COMPARISON_TYPE) (P) \
210 >= (PNTR_COMPARISON_TYPE) pure))
212 /* Index in pure at which next pure object will be allocated.. */
216 /* If nonzero, this is a warning delivered by malloc and not yet
219 char *pending_malloc_warning
;
221 /* Pre-computed signal argument for use when memory is exhausted. */
223 Lisp_Object memory_signal_data
;
225 /* Maximum amount of C stack to save when a GC happens. */
227 #ifndef MAX_SAVE_STACK
228 #define MAX_SAVE_STACK 16000
231 /* Buffer in which we save a copy of the C stack at each GC. */
236 /* Non-zero means ignore malloc warnings. Set during initialization.
237 Currently not used. */
241 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
243 static void mark_buffer
P_ ((Lisp_Object
));
244 static void mark_kboards
P_ ((void));
245 static void gc_sweep
P_ ((void));
246 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
247 static void mark_face_cache
P_ ((struct face_cache
*));
249 #ifdef HAVE_WINDOW_SYSTEM
250 static void mark_image
P_ ((struct image
*));
251 static void mark_image_cache
P_ ((struct frame
*));
252 #endif /* HAVE_WINDOW_SYSTEM */
254 static struct Lisp_String
*allocate_string
P_ ((void));
255 static void compact_small_strings
P_ ((void));
256 static void free_large_strings
P_ ((void));
257 static void sweep_strings
P_ ((void));
259 extern int message_enable_multibyte
;
261 /* When scanning the C stack for live Lisp objects, Emacs keeps track
262 of what memory allocated via lisp_malloc is intended for what
263 purpose. This enumeration specifies the type of memory. */
279 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
280 #include <stdio.h> /* For fprintf. */
283 /* A unique object in pure space used to make some Lisp objects
284 on free lists recognizable in O(1). */
289 static void *lisp_malloc
P_ ((int, enum mem_type
));
290 static void mark_stack
P_ ((void));
291 static void init_stack
P_ ((Lisp_Object
*));
292 static int live_vector_p
P_ ((struct mem_node
*, void *));
293 static int live_buffer_p
P_ ((struct mem_node
*, void *));
294 static int live_string_p
P_ ((struct mem_node
*, void *));
295 static int live_cons_p
P_ ((struct mem_node
*, void *));
296 static int live_symbol_p
P_ ((struct mem_node
*, void *));
297 static int live_float_p
P_ ((struct mem_node
*, void *));
298 static int live_misc_p
P_ ((struct mem_node
*, void *));
299 static void mark_maybe_object
P_ ((Lisp_Object
));
300 static void mark_memory
P_ ((void *, void *));
301 static void mem_init
P_ ((void));
302 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
303 static void mem_insert_fixup
P_ ((struct mem_node
*));
304 static void mem_rotate_left
P_ ((struct mem_node
*));
305 static void mem_rotate_right
P_ ((struct mem_node
*));
306 static void mem_delete
P_ ((struct mem_node
*));
307 static void mem_delete_fixup
P_ ((struct mem_node
*));
308 static INLINE
struct mem_node
*mem_find
P_ ((void *));
310 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
311 static void check_gcpros
P_ ((void));
314 #endif /* GC_MARK_STACK != 0 */
317 /************************************************************************
319 ************************************************************************/
321 /* Write STR to Vstandard_output plus some advice on how to free some
322 memory. Called when memory gets low. */
325 malloc_warning_1 (str
)
328 Fprinc (str
, Vstandard_output
);
329 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
330 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
331 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
336 /* Function malloc calls this if it finds we are near exhausting
343 pending_malloc_warning
= str
;
347 /* Display a malloc warning in buffer *Danger*. */
350 display_malloc_warning ()
352 register Lisp_Object val
;
354 val
= build_string (pending_malloc_warning
);
355 pending_malloc_warning
= 0;
356 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
360 #ifdef DOUG_LEA_MALLOC
361 # define BYTES_USED (mallinfo ().arena)
363 # define BYTES_USED _bytes_used
367 /* Called if malloc returns zero. */
372 #ifndef SYSTEM_MALLOC
373 bytes_used_when_full
= BYTES_USED
;
376 /* The first time we get here, free the spare memory. */
383 /* This used to call error, but if we've run out of memory, we could
384 get infinite recursion trying to build the string. */
386 Fsignal (Qnil
, memory_signal_data
);
390 /* Called if we can't allocate relocatable space for a buffer. */
393 buffer_memory_full ()
395 /* If buffers use the relocating allocator, no need to free
396 spare_memory, because we may have plenty of malloc space left
397 that we could get, and if we don't, the malloc that fails will
398 itself cause spare_memory to be freed. If buffers don't use the
399 relocating allocator, treat this like any other failing
406 /* This used to call error, but if we've run out of memory, we could
407 get infinite recursion trying to build the string. */
409 Fsignal (Qerror
, memory_signal_data
);
413 /* Like malloc but check for no memory and block interrupt input.. */
422 val
= (long *) malloc (size
);
431 /* Like realloc but check for no memory and block interrupt input.. */
434 xrealloc (block
, size
)
441 /* We must call malloc explicitly when BLOCK is 0, since some
442 reallocs don't do this. */
444 val
= (long *) malloc (size
);
446 val
= (long *) realloc (block
, size
);
449 if (!val
&& size
) memory_full ();
454 /* Like free but block interrupt input.. */
466 /* Like malloc but used for allocating Lisp data. NBYTES is the
467 number of bytes to allocate, TYPE describes the intended use of the
468 allcated memory block (for strings, for conses, ...). */
471 lisp_malloc (nbytes
, type
)
478 allocating_for_lisp
++;
479 val
= (void *) malloc (nbytes
);
480 allocating_for_lisp
--;
487 if (type
!= MEM_TYPE_NON_LISP
)
488 mem_insert (val
, (char *) val
+ nbytes
, type
);
495 /* Return a new buffer structure allocated from the heap with
496 a call to lisp_malloc. */
501 return (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
506 /* Free BLOCK. This must be called to free memory allocated with a
507 call to lisp_malloc. */
514 allocating_for_lisp
++;
517 mem_delete (mem_find (block
));
519 allocating_for_lisp
--;
524 /* Arranging to disable input signals while we're in malloc.
526 This only works with GNU malloc. To help out systems which can't
527 use GNU malloc, all the calls to malloc, realloc, and free
528 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
529 pairs; unfortunately, we have no idea what C library functions
530 might call malloc, so we can't really protect them unless you're
531 using GNU malloc. Fortunately, most of the major operating can use
534 #ifndef SYSTEM_MALLOC
536 extern void * (*__malloc_hook
) ();
537 static void * (*old_malloc_hook
) ();
538 extern void * (*__realloc_hook
) ();
539 static void * (*old_realloc_hook
) ();
540 extern void (*__free_hook
) ();
541 static void (*old_free_hook
) ();
543 /* This function is used as the hook for free to call. */
546 emacs_blocked_free (ptr
)
550 __free_hook
= old_free_hook
;
552 /* If we released our reserve (due to running out of memory),
553 and we have a fair amount free once again,
554 try to set aside another reserve in case we run out once more. */
555 if (spare_memory
== 0
556 /* Verify there is enough space that even with the malloc
557 hysteresis this call won't run out again.
558 The code here is correct as long as SPARE_MEMORY
559 is substantially larger than the block size malloc uses. */
560 && (bytes_used_when_full
561 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
562 spare_memory
= (char *) malloc (SPARE_MEMORY
);
564 __free_hook
= emacs_blocked_free
;
569 /* If we released our reserve (due to running out of memory),
570 and we have a fair amount free once again,
571 try to set aside another reserve in case we run out once more.
573 This is called when a relocatable block is freed in ralloc.c. */
576 refill_memory_reserve ()
578 if (spare_memory
== 0)
579 spare_memory
= (char *) malloc (SPARE_MEMORY
);
583 /* This function is the malloc hook that Emacs uses. */
586 emacs_blocked_malloc (size
)
592 __malloc_hook
= old_malloc_hook
;
593 #ifdef DOUG_LEA_MALLOC
594 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
596 __malloc_extra_blocks
= malloc_hysteresis
;
598 value
= (void *) malloc (size
);
599 __malloc_hook
= emacs_blocked_malloc
;
606 /* This function is the realloc hook that Emacs uses. */
609 emacs_blocked_realloc (ptr
, size
)
616 __realloc_hook
= old_realloc_hook
;
617 value
= (void *) realloc (ptr
, size
);
618 __realloc_hook
= emacs_blocked_realloc
;
625 /* Called from main to set up malloc to use our hooks. */
628 uninterrupt_malloc ()
630 if (__free_hook
!= emacs_blocked_free
)
631 old_free_hook
= __free_hook
;
632 __free_hook
= emacs_blocked_free
;
634 if (__malloc_hook
!= emacs_blocked_malloc
)
635 old_malloc_hook
= __malloc_hook
;
636 __malloc_hook
= emacs_blocked_malloc
;
638 if (__realloc_hook
!= emacs_blocked_realloc
)
639 old_realloc_hook
= __realloc_hook
;
640 __realloc_hook
= emacs_blocked_realloc
;
643 #endif /* not SYSTEM_MALLOC */
647 /***********************************************************************
649 ***********************************************************************/
651 /* Number of intervals allocated in an interval_block structure.
652 The 1020 is 1024 minus malloc overhead. */
654 #define INTERVAL_BLOCK_SIZE \
655 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
657 /* Intervals are allocated in chunks in form of an interval_block
660 struct interval_block
662 struct interval_block
*next
;
663 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
666 /* Current interval block. Its `next' pointer points to older
669 struct interval_block
*interval_block
;
671 /* Index in interval_block above of the next unused interval
674 static int interval_block_index
;
676 /* Number of free and live intervals. */
678 static int total_free_intervals
, total_intervals
;
680 /* List of free intervals. */
682 INTERVAL interval_free_list
;
684 /* Total number of interval blocks now in use. */
686 int n_interval_blocks
;
689 /* Initialize interval allocation. */
695 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
697 interval_block
->next
= 0;
698 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
699 interval_block_index
= 0;
700 interval_free_list
= 0;
701 n_interval_blocks
= 1;
705 /* Return a new interval. */
712 if (interval_free_list
)
714 val
= interval_free_list
;
715 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
719 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
721 register struct interval_block
*newi
;
723 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
726 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
727 newi
->next
= interval_block
;
728 interval_block
= newi
;
729 interval_block_index
= 0;
732 val
= &interval_block
->intervals
[interval_block_index
++];
734 consing_since_gc
+= sizeof (struct interval
);
736 RESET_INTERVAL (val
);
741 /* Mark Lisp objects in interval I. */
744 mark_interval (i
, dummy
)
748 if (XMARKBIT (i
->plist
))
750 mark_object (&i
->plist
);
755 /* Mark the interval tree rooted in TREE. Don't call this directly;
756 use the macro MARK_INTERVAL_TREE instead. */
759 mark_interval_tree (tree
)
760 register INTERVAL tree
;
762 /* No need to test if this tree has been marked already; this
763 function is always called through the MARK_INTERVAL_TREE macro,
764 which takes care of that. */
766 /* XMARK expands to an assignment; the LHS of an assignment can't be
768 XMARK (* (Lisp_Object
*) &tree
->parent
);
770 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
774 /* Mark the interval tree rooted in I. */
776 #define MARK_INTERVAL_TREE(i) \
778 if (!NULL_INTERVAL_P (i) \
779 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
780 mark_interval_tree (i); \
784 /* The oddity in the call to XUNMARK is necessary because XUNMARK
785 expands to an assignment to its argument, and most C compilers
786 don't support casts on the left operand of `='. */
788 #define UNMARK_BALANCE_INTERVALS(i) \
790 if (! NULL_INTERVAL_P (i)) \
792 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
793 (i) = balance_intervals (i); \
799 /***********************************************************************
801 ***********************************************************************/
803 /* Lisp_Strings are allocated in string_block structures. When a new
804 string_block is allocated, all the Lisp_Strings it contains are
805 added to a free-list stiing_free_list. When a new Lisp_String is
806 needed, it is taken from that list. During the sweep phase of GC,
807 string_blocks that are entirely free are freed, except two which
810 String data is allocated from sblock structures. Strings larger
811 than LARGE_STRING_BYTES, get their own sblock, data for smaller
812 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
814 Sblocks consist internally of sdata structures, one for each
815 Lisp_String. The sdata structure points to the Lisp_String it
816 belongs to. The Lisp_String points back to the `u.data' member of
819 When a Lisp_String is freed during GC, it is put back on
820 string_free_list, and its `data' member and its sdata's `string'
821 pointer is set to null. The size of the string is recorded in the
822 `u.nbytes' member of the sdata. So, sdata structures that are no
823 longer used, can be easily recognized, and it's easy to compact the
824 sblocks of small strings which we do in compact_small_strings. */
826 /* Size in bytes of an sblock structure used for small strings. This
827 is 8192 minus malloc overhead. */
829 #define SBLOCK_SIZE 8188
831 /* Strings larger than this are considered large strings. String data
832 for large strings is allocated from individual sblocks. */
834 #define LARGE_STRING_BYTES 1024
836 /* Structure describing string memory sub-allocated from an sblock.
837 This is where the contents of Lisp strings are stored. */
841 /* Back-pointer to the string this sdata belongs to. If null, this
842 structure is free, and the NBYTES member of the union below
843 contains the string's byte size (the same value that STRING_BYTES
844 would return if STRING were non-null). If non-null, STRING_BYTES
845 (STRING) is the size of the data, and DATA contains the string's
847 struct Lisp_String
*string
;
851 /* When STRING in non-null. */
852 unsigned char data
[1];
854 /* When STRING is null. */
859 /* Structure describing a block of memory which is sub-allocated to
860 obtain string data memory for strings. Blocks for small strings
861 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
862 as large as needed. */
869 /* Pointer to the next free sdata block. This points past the end
870 of the sblock if there isn't any space left in this block. */
871 struct sdata
*next_free
;
874 struct sdata first_data
;
877 /* Number of Lisp strings in a string_block structure. The 1020 is
878 1024 minus malloc overhead. */
880 #define STRINGS_IN_STRING_BLOCK \
881 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
883 /* Structure describing a block from which Lisp_String structures
888 struct string_block
*next
;
889 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
892 /* Head and tail of the list of sblock structures holding Lisp string
893 data. We always allocate from current_sblock. The NEXT pointers
894 in the sblock structures go from oldest_sblock to current_sblock. */
896 static struct sblock
*oldest_sblock
, *current_sblock
;
898 /* List of sblocks for large strings. */
900 static struct sblock
*large_sblocks
;
902 /* List of string_block structures, and how many there are. */
904 static struct string_block
*string_blocks
;
905 static int n_string_blocks
;
907 /* Free-list of Lisp_Strings. */
909 static struct Lisp_String
*string_free_list
;
911 /* Number of live and free Lisp_Strings. */
913 static int total_strings
, total_free_strings
;
915 /* Number of bytes used by live strings. */
917 static int total_string_size
;
919 /* Given a pointer to a Lisp_String S which is on the free-list
920 string_free_list, return a pointer to its successor in the
923 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
925 /* Return a pointer to the sdata structure belonging to Lisp string S.
926 S must be live, i.e. S->data must not be null. S->data is actually
927 a pointer to the `u.data' member of its sdata structure; the
928 structure starts at a constant offset in front of that. */
930 #define SDATA_OF_STRING(S) \
931 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
933 /* Value is the size of an sdata structure large enough to hold NBYTES
934 bytes of string data. The value returned includes a terminating
935 NUL byte, the size of the sdata structure, and padding. */
937 #define SDATA_SIZE(NBYTES) \
938 ((sizeof (struct Lisp_String *) \
940 + sizeof (EMACS_INT) - 1) \
941 & ~(sizeof (EMACS_INT) - 1))
944 /* Initialize string allocation. Called from init_alloc_once. */
949 total_strings
= total_free_strings
= total_string_size
= 0;
950 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
951 string_blocks
= NULL
;
953 string_free_list
= NULL
;
957 /* Return a new Lisp_String. */
959 static struct Lisp_String
*
962 struct Lisp_String
*s
;
964 /* If the free-list is empty, allocate a new string_block, and
965 add all the Lisp_Strings in it to the free-list. */
966 if (string_free_list
== NULL
)
968 struct string_block
*b
;
971 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
972 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
973 bzero (b
, sizeof *b
);
974 b
->next
= string_blocks
;
978 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
981 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
982 string_free_list
= s
;
985 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
988 /* Pop a Lisp_String off the free-list. */
989 s
= string_free_list
;
990 string_free_list
= NEXT_FREE_LISP_STRING (s
);
992 /* Probably not strictly necessary, but play it safe. */
993 bzero (s
, sizeof *s
);
995 --total_free_strings
;
998 consing_since_gc
+= sizeof *s
;
1004 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1005 plus a NUL byte at the end. Allocate an sdata structure for S, and
1006 set S->data to its `u.data' member. Store a NUL byte at the end of
1007 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1008 S->data if it was initially non-null. */
1011 allocate_string_data (s
, nchars
, nbytes
)
1012 struct Lisp_String
*s
;
1019 /* Determine the number of bytes needed to store NBYTES bytes
1021 needed
= SDATA_SIZE (nbytes
);
1023 if (nbytes
> LARGE_STRING_BYTES
)
1025 int size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1027 #ifdef DOUG_LEA_MALLOC
1028 /* Prevent mmap'ing the chunk (which is potentially very large). */
1029 mallopt (M_MMAP_MAX
, 0);
1032 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1034 #ifdef DOUG_LEA_MALLOC
1035 /* Back to a reasonable maximum of mmap'ed areas. */
1036 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1039 b
->next_free
= &b
->first_data
;
1040 b
->first_data
.string
= NULL
;
1041 b
->next
= large_sblocks
;
1044 else if (current_sblock
== NULL
1045 || (((char *) current_sblock
+ SBLOCK_SIZE
1046 - (char *) current_sblock
->next_free
)
1049 /* Not enough room in the current sblock. */
1050 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1051 b
->next_free
= &b
->first_data
;
1052 b
->first_data
.string
= NULL
;
1056 current_sblock
->next
= b
;
1064 /* If S had already data assigned, mark that as free by setting
1065 its string back-pointer to null, and recording the size of
1069 data
= SDATA_OF_STRING (s
);
1070 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1071 data
->string
= NULL
;
1074 data
= b
->next_free
;
1076 s
->data
= data
->u
.data
;
1078 s
->size_byte
= nbytes
;
1079 s
->data
[nbytes
] = '\0';
1080 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1082 consing_since_gc
+= needed
;
1086 /* Sweep and compact strings. */
1091 struct string_block
*b
, *next
;
1092 struct string_block
*live_blocks
= NULL
;
1094 string_free_list
= NULL
;
1095 total_strings
= total_free_strings
= 0;
1096 total_string_size
= 0;
1098 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1099 for (b
= string_blocks
; b
; b
= next
)
1102 struct Lisp_String
*free_list_before
= string_free_list
;
1106 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1108 struct Lisp_String
*s
= b
->strings
+ i
;
1112 /* String was not on free-list before. */
1113 if (STRING_MARKED_P (s
))
1115 /* String is live; unmark it and its intervals. */
1118 if (!NULL_INTERVAL_P (s
->intervals
))
1119 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1122 total_string_size
+= STRING_BYTES (s
);
1126 /* String is dead. Put it on the free-list. */
1127 struct sdata
*data
= SDATA_OF_STRING (s
);
1129 /* Save the size of S in its sdata so that we know
1130 how large that is. Reset the sdata's string
1131 back-pointer so that we know it's free. */
1132 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1133 data
->string
= NULL
;
1135 /* Reset the strings's `data' member so that we
1139 /* Put the string on the free-list. */
1140 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1141 string_free_list
= s
;
1147 /* S was on the free-list before. Put it there again. */
1148 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1149 string_free_list
= s
;
1154 /* Free blocks that contain free Lisp_Strings only, except
1155 the first two of them. */
1156 if (nfree
== STRINGS_IN_STRING_BLOCK
1157 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1161 string_free_list
= free_list_before
;
1165 total_free_strings
+= nfree
;
1166 b
->next
= live_blocks
;
1171 string_blocks
= live_blocks
;
1172 free_large_strings ();
1173 compact_small_strings ();
1177 /* Free dead large strings. */
1180 free_large_strings ()
1182 struct sblock
*b
, *next
;
1183 struct sblock
*live_blocks
= NULL
;
1185 for (b
= large_sblocks
; b
; b
= next
)
1189 if (b
->first_data
.string
== NULL
)
1193 b
->next
= live_blocks
;
1198 large_sblocks
= live_blocks
;
1202 /* Compact data of small strings. Free sblocks that don't contain
1203 data of live strings after compaction. */
1206 compact_small_strings ()
1208 struct sblock
*b
, *tb
, *next
;
1209 struct sdata
*from
, *to
, *end
, *tb_end
;
1210 struct sdata
*to_end
, *from_end
;
1212 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1213 to, and TB_END is the end of TB. */
1215 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1216 to
= &tb
->first_data
;
1218 /* Step through the blocks from the oldest to the youngest. We
1219 expect that old blocks will stabilize over time, so that less
1220 copying will happen this way. */
1221 for (b
= oldest_sblock
; b
; b
= b
->next
)
1224 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1226 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1228 /* Compute the next FROM here because copying below may
1229 overwrite data we need to compute it. */
1233 nbytes
= GC_STRING_BYTES (from
->string
);
1235 nbytes
= from
->u
.nbytes
;
1237 nbytes
= SDATA_SIZE (nbytes
);
1238 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1240 /* FROM->string non-null means it's alive. Copy its data. */
1243 /* If TB is full, proceed with the next sblock. */
1244 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1245 if (to_end
> tb_end
)
1249 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1250 to
= &tb
->first_data
;
1251 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1254 /* Copy, and update the string's `data' pointer. */
1257 bcopy (from
, to
, nbytes
);
1258 to
->string
->data
= to
->u
.data
;
1261 /* Advance past the sdata we copied to. */
1267 /* The rest of the sblocks following TB don't contain live data, so
1268 we can free them. */
1269 for (b
= tb
->next
; b
; b
= next
)
1277 current_sblock
= tb
;
1281 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1282 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1283 Both LENGTH and INIT must be numbers.")
1285 Lisp_Object length
, init
;
1287 register Lisp_Object val
;
1288 register unsigned char *p
, *end
;
1291 CHECK_NATNUM (length
, 0);
1292 CHECK_NUMBER (init
, 1);
1295 if (SINGLE_BYTE_CHAR_P (c
))
1297 nbytes
= XINT (length
);
1298 val
= make_uninit_string (nbytes
);
1299 p
= XSTRING (val
)->data
;
1300 end
= p
+ XSTRING (val
)->size
;
1306 unsigned char str
[4];
1307 int len
= CHAR_STRING (c
, str
);
1309 nbytes
= len
* XINT (length
);
1310 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1311 p
= XSTRING (val
)->data
;
1315 bcopy (str
, p
, len
);
1325 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1326 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1327 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1329 Lisp_Object length
, init
;
1331 register Lisp_Object val
;
1332 struct Lisp_Bool_Vector
*p
;
1334 int length_in_chars
, length_in_elts
, bits_per_value
;
1336 CHECK_NATNUM (length
, 0);
1338 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1340 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1341 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1343 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1344 slot `size' of the struct Lisp_Bool_Vector. */
1345 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1346 p
= XBOOL_VECTOR (val
);
1348 /* Get rid of any bits that would cause confusion. */
1350 XSETBOOL_VECTOR (val
, p
);
1351 p
->size
= XFASTINT (length
);
1353 real_init
= (NILP (init
) ? 0 : -1);
1354 for (i
= 0; i
< length_in_chars
; i
++)
1355 p
->data
[i
] = real_init
;
1357 /* Clear the extraneous bits in the last byte. */
1358 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1359 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1360 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1366 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1367 of characters from the contents. This string may be unibyte or
1368 multibyte, depending on the contents. */
1371 make_string (contents
, nbytes
)
1375 register Lisp_Object val
;
1376 int nchars
= chars_in_text (contents
, nbytes
);
1377 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1378 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1379 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1380 SET_STRING_BYTES (XSTRING (val
), -1);
1385 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1388 make_unibyte_string (contents
, length
)
1392 register Lisp_Object val
;
1393 val
= make_uninit_string (length
);
1394 bcopy (contents
, XSTRING (val
)->data
, length
);
1395 SET_STRING_BYTES (XSTRING (val
), -1);
1400 /* Make a multibyte string from NCHARS characters occupying NBYTES
1401 bytes at CONTENTS. */
1404 make_multibyte_string (contents
, nchars
, nbytes
)
1408 register Lisp_Object val
;
1409 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1410 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1415 /* Make a string from NCHARS characters occupying NBYTES bytes at
1416 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1419 make_string_from_bytes (contents
, nchars
, nbytes
)
1423 register Lisp_Object val
;
1424 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1425 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1426 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1427 SET_STRING_BYTES (XSTRING (val
), -1);
1432 /* Make a string from NCHARS characters occupying NBYTES bytes at
1433 CONTENTS. The argument MULTIBYTE controls whether to label the
1434 string as multibyte. */
1437 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1442 register Lisp_Object val
;
1443 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1444 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1446 SET_STRING_BYTES (XSTRING (val
), -1);
1451 /* Make a string from the data at STR, treating it as multibyte if the
1458 return make_string (str
, strlen (str
));
1462 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1463 occupying LENGTH bytes. */
1466 make_uninit_string (length
)
1470 val
= make_uninit_multibyte_string (length
, length
);
1471 SET_STRING_BYTES (XSTRING (val
), -1);
1476 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1477 which occupy NBYTES bytes. */
1480 make_uninit_multibyte_string (nchars
, nbytes
)
1484 struct Lisp_String
*s
;
1489 s
= allocate_string ();
1490 allocate_string_data (s
, nchars
, nbytes
);
1491 XSETSTRING (string
, s
);
1492 string_chars_consed
+= nbytes
;
1498 /***********************************************************************
1500 ***********************************************************************/
1502 /* We store float cells inside of float_blocks, allocating a new
1503 float_block with malloc whenever necessary. Float cells reclaimed
1504 by GC are put on a free list to be reallocated before allocating
1505 any new float cells from the latest float_block.
1507 Each float_block is just under 1020 bytes long, since malloc really
1508 allocates in units of powers of two and uses 4 bytes for its own
1511 #define FLOAT_BLOCK_SIZE \
1512 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1516 struct float_block
*next
;
1517 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1520 /* Current float_block. */
1522 struct float_block
*float_block
;
1524 /* Index of first unused Lisp_Float in the current float_block. */
1526 int float_block_index
;
1528 /* Total number of float blocks now in use. */
1532 /* Free-list of Lisp_Floats. */
1534 struct Lisp_Float
*float_free_list
;
1537 /* Initialze float allocation. */
1542 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1544 float_block
->next
= 0;
1545 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1546 float_block_index
= 0;
1547 float_free_list
= 0;
1552 /* Explicitly free a float cell by putting it on the free-list. */
1556 struct Lisp_Float
*ptr
;
1558 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1562 float_free_list
= ptr
;
1566 /* Return a new float object with value FLOAT_VALUE. */
1569 make_float (float_value
)
1572 register Lisp_Object val
;
1574 if (float_free_list
)
1576 /* We use the data field for chaining the free list
1577 so that we won't use the same field that has the mark bit. */
1578 XSETFLOAT (val
, float_free_list
);
1579 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1583 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1585 register struct float_block
*new;
1587 new = (struct float_block
*) lisp_malloc (sizeof *new,
1589 VALIDATE_LISP_STORAGE (new, sizeof *new);
1590 new->next
= float_block
;
1592 float_block_index
= 0;
1595 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1598 XFLOAT_DATA (val
) = float_value
;
1599 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1600 consing_since_gc
+= sizeof (struct Lisp_Float
);
1607 /***********************************************************************
1609 ***********************************************************************/
1611 /* We store cons cells inside of cons_blocks, allocating a new
1612 cons_block with malloc whenever necessary. Cons cells reclaimed by
1613 GC are put on a free list to be reallocated before allocating
1614 any new cons cells from the latest cons_block.
1616 Each cons_block is just under 1020 bytes long,
1617 since malloc really allocates in units of powers of two
1618 and uses 4 bytes for its own overhead. */
1620 #define CONS_BLOCK_SIZE \
1621 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1625 struct cons_block
*next
;
1626 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1629 /* Current cons_block. */
1631 struct cons_block
*cons_block
;
1633 /* Index of first unused Lisp_Cons in the current block. */
1635 int cons_block_index
;
1637 /* Free-list of Lisp_Cons structures. */
1639 struct Lisp_Cons
*cons_free_list
;
1641 /* Total number of cons blocks now in use. */
1646 /* Initialize cons allocation. */
1651 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1653 cons_block
->next
= 0;
1654 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1655 cons_block_index
= 0;
1661 /* Explicitly free a cons cell by putting it on the free-list. */
1665 struct Lisp_Cons
*ptr
;
1667 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1671 cons_free_list
= ptr
;
1675 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
1676 "Create a new cons, give it CAR and CDR as components, and return it.")
1678 Lisp_Object car
, cdr
;
1680 register Lisp_Object val
;
1684 /* We use the cdr for chaining the free list
1685 so that we won't use the same field that has the mark bit. */
1686 XSETCONS (val
, cons_free_list
);
1687 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
1691 if (cons_block_index
== CONS_BLOCK_SIZE
)
1693 register struct cons_block
*new;
1694 new = (struct cons_block
*) lisp_malloc (sizeof *new,
1696 VALIDATE_LISP_STORAGE (new, sizeof *new);
1697 new->next
= cons_block
;
1699 cons_block_index
= 0;
1702 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
1707 consing_since_gc
+= sizeof (struct Lisp_Cons
);
1708 cons_cells_consed
++;
1713 /* Make a list of 2, 3, 4 or 5 specified objects. */
1717 Lisp_Object arg1
, arg2
;
1719 return Fcons (arg1
, Fcons (arg2
, Qnil
));
1724 list3 (arg1
, arg2
, arg3
)
1725 Lisp_Object arg1
, arg2
, arg3
;
1727 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
1732 list4 (arg1
, arg2
, arg3
, arg4
)
1733 Lisp_Object arg1
, arg2
, arg3
, arg4
;
1735 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
1740 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
1741 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
1743 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
1744 Fcons (arg5
, Qnil
)))));
1748 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
1749 "Return a newly created list with specified arguments as elements.\n\
1750 Any number of arguments, even zero arguments, are allowed.")
1753 register Lisp_Object
*args
;
1755 register Lisp_Object val
;
1761 val
= Fcons (args
[nargs
], val
);
1767 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
1768 "Return a newly created list of length LENGTH, with each element being INIT.")
1770 register Lisp_Object length
, init
;
1772 register Lisp_Object val
;
1775 CHECK_NATNUM (length
, 0);
1776 size
= XFASTINT (length
);
1780 val
= Fcons (init
, val
);
1786 /***********************************************************************
1788 ***********************************************************************/
1790 /* Singly-linked list of all vectors. */
1792 struct Lisp_Vector
*all_vectors
;
1794 /* Total number of vector-like objects now in use. */
1799 /* Value is a pointer to a newly allocated Lisp_Vector structure
1800 with room for LEN Lisp_Objects. */
1802 struct Lisp_Vector
*
1803 allocate_vectorlike (len
)
1806 struct Lisp_Vector
*p
;
1809 #ifdef DOUG_LEA_MALLOC
1810 /* Prevent mmap'ing the chunk (which is potentially very large).. */
1811 mallopt (M_MMAP_MAX
, 0);
1814 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
1815 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
1817 #ifdef DOUG_LEA_MALLOC
1818 /* Back to a reasonable maximum of mmap'ed areas. */
1819 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1822 VALIDATE_LISP_STORAGE (p
, 0);
1823 consing_since_gc
+= nbytes
;
1824 vector_cells_consed
+= len
;
1826 p
->next
= all_vectors
;
1833 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
1834 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1835 See also the function `vector'.")
1837 register Lisp_Object length
, init
;
1840 register EMACS_INT sizei
;
1842 register struct Lisp_Vector
*p
;
1844 CHECK_NATNUM (length
, 0);
1845 sizei
= XFASTINT (length
);
1847 p
= allocate_vectorlike (sizei
);
1849 for (index
= 0; index
< sizei
; index
++)
1850 p
->contents
[index
] = init
;
1852 XSETVECTOR (vector
, p
);
1857 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
1858 "Return a newly created char-table, with purpose PURPOSE.\n\
1859 Each element is initialized to INIT, which defaults to nil.\n\
1860 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
1861 The property's value should be an integer between 0 and 10.")
1863 register Lisp_Object purpose
, init
;
1867 CHECK_SYMBOL (purpose
, 1);
1868 n
= Fget (purpose
, Qchar_table_extra_slots
);
1869 CHECK_NUMBER (n
, 0);
1870 if (XINT (n
) < 0 || XINT (n
) > 10)
1871 args_out_of_range (n
, Qnil
);
1872 /* Add 2 to the size for the defalt and parent slots. */
1873 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
1875 XCHAR_TABLE (vector
)->top
= Qt
;
1876 XCHAR_TABLE (vector
)->parent
= Qnil
;
1877 XCHAR_TABLE (vector
)->purpose
= purpose
;
1878 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1883 /* Return a newly created sub char table with default value DEFALT.
1884 Since a sub char table does not appear as a top level Emacs Lisp
1885 object, we don't need a Lisp interface to make it. */
1888 make_sub_char_table (defalt
)
1892 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
1893 XCHAR_TABLE (vector
)->top
= Qnil
;
1894 XCHAR_TABLE (vector
)->defalt
= defalt
;
1895 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1900 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
1901 "Return a newly created vector with specified arguments as elements.\n\
1902 Any number of arguments, even zero arguments, are allowed.")
1907 register Lisp_Object len
, val
;
1909 register struct Lisp_Vector
*p
;
1911 XSETFASTINT (len
, nargs
);
1912 val
= Fmake_vector (len
, Qnil
);
1914 for (index
= 0; index
< nargs
; index
++)
1915 p
->contents
[index
] = args
[index
];
1920 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
1921 "Create a byte-code object with specified arguments as elements.\n\
1922 The arguments should be the arglist, bytecode-string, constant vector,\n\
1923 stack size, (optional) doc string, and (optional) interactive spec.\n\
1924 The first four arguments are required; at most six have any\n\
1930 register Lisp_Object len
, val
;
1932 register struct Lisp_Vector
*p
;
1934 XSETFASTINT (len
, nargs
);
1935 if (!NILP (Vpurify_flag
))
1936 val
= make_pure_vector ((EMACS_INT
) nargs
);
1938 val
= Fmake_vector (len
, Qnil
);
1940 for (index
= 0; index
< nargs
; index
++)
1942 if (!NILP (Vpurify_flag
))
1943 args
[index
] = Fpurecopy (args
[index
]);
1944 p
->contents
[index
] = args
[index
];
1946 XSETCOMPILED (val
, p
);
1952 /***********************************************************************
1954 ***********************************************************************/
1956 /* Each symbol_block is just under 1020 bytes long, since malloc
1957 really allocates in units of powers of two and uses 4 bytes for its
1960 #define SYMBOL_BLOCK_SIZE \
1961 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
1965 struct symbol_block
*next
;
1966 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
1969 /* Current symbol block and index of first unused Lisp_Symbol
1972 struct symbol_block
*symbol_block
;
1973 int symbol_block_index
;
1975 /* List of free symbols. */
1977 struct Lisp_Symbol
*symbol_free_list
;
1979 /* Total number of symbol blocks now in use. */
1981 int n_symbol_blocks
;
1984 /* Initialize symbol allocation. */
1989 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
1991 symbol_block
->next
= 0;
1992 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
1993 symbol_block_index
= 0;
1994 symbol_free_list
= 0;
1995 n_symbol_blocks
= 1;
1999 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2000 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2001 Its value and function definition are void, and its property list is nil.")
2005 register Lisp_Object val
;
2006 register struct Lisp_Symbol
*p
;
2008 CHECK_STRING (name
, 0);
2010 if (symbol_free_list
)
2012 XSETSYMBOL (val
, symbol_free_list
);
2013 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2017 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2019 struct symbol_block
*new;
2020 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2022 VALIDATE_LISP_STORAGE (new, sizeof *new);
2023 new->next
= symbol_block
;
2025 symbol_block_index
= 0;
2028 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2032 p
->name
= XSTRING (name
);
2035 p
->value
= Qunbound
;
2036 p
->function
= Qunbound
;
2038 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2045 /***********************************************************************
2046 Marker (Misc) Allocation
2047 ***********************************************************************/
2049 /* Allocation of markers and other objects that share that structure.
2050 Works like allocation of conses. */
2052 #define MARKER_BLOCK_SIZE \
2053 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2057 struct marker_block
*next
;
2058 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2061 struct marker_block
*marker_block
;
2062 int marker_block_index
;
2064 union Lisp_Misc
*marker_free_list
;
2066 /* Total number of marker blocks now in use. */
2068 int n_marker_blocks
;
2073 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2075 marker_block
->next
= 0;
2076 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2077 marker_block_index
= 0;
2078 marker_free_list
= 0;
2079 n_marker_blocks
= 1;
2082 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2089 if (marker_free_list
)
2091 XSETMISC (val
, marker_free_list
);
2092 marker_free_list
= marker_free_list
->u_free
.chain
;
2096 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2098 struct marker_block
*new;
2099 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2101 VALIDATE_LISP_STORAGE (new, sizeof *new);
2102 new->next
= marker_block
;
2104 marker_block_index
= 0;
2107 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2110 consing_since_gc
+= sizeof (union Lisp_Misc
);
2111 misc_objects_consed
++;
2115 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2116 "Return a newly allocated marker which does not point at any place.")
2119 register Lisp_Object val
;
2120 register struct Lisp_Marker
*p
;
2122 val
= allocate_misc ();
2123 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2129 p
->insertion_type
= 0;
2133 /* Put MARKER back on the free list after using it temporarily. */
2136 free_marker (marker
)
2139 unchain_marker (marker
);
2141 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2142 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2143 marker_free_list
= XMISC (marker
);
2145 total_free_markers
++;
2149 /* Return a newly created vector or string with specified arguments as
2150 elements. If all the arguments are characters that can fit
2151 in a string of events, make a string; otherwise, make a vector.
2153 Any number of arguments, even zero arguments, are allowed. */
2156 make_event_array (nargs
, args
)
2162 for (i
= 0; i
< nargs
; i
++)
2163 /* The things that fit in a string
2164 are characters that are in 0...127,
2165 after discarding the meta bit and all the bits above it. */
2166 if (!INTEGERP (args
[i
])
2167 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2168 return Fvector (nargs
, args
);
2170 /* Since the loop exited, we know that all the things in it are
2171 characters, so we can make a string. */
2175 result
= Fmake_string (make_number (nargs
), make_number (0));
2176 for (i
= 0; i
< nargs
; i
++)
2178 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2179 /* Move the meta bit to the right place for a string char. */
2180 if (XINT (args
[i
]) & CHAR_META
)
2181 XSTRING (result
)->data
[i
] |= 0x80;
2190 /************************************************************************
2192 ************************************************************************/
2197 /* Base address of stack. Set in main. */
2199 Lisp_Object
*stack_base
;
2201 /* A node in the red-black tree describing allocated memory containing
2202 Lisp data. Each such block is recorded with its start and end
2203 address when it is allocated, and removed from the tree when it
2206 A red-black tree is a balanced binary tree with the following
2209 1. Every node is either red or black.
2210 2. Every leaf is black.
2211 3. If a node is red, then both of its children are black.
2212 4. Every simple path from a node to a descendant leaf contains
2213 the same number of black nodes.
2214 5. The root is always black.
2216 When nodes are inserted into the tree, or deleted from the tree,
2217 the tree is "fixed" so that these properties are always true.
2219 A red-black tree with N internal nodes has height at most 2
2220 log(N+1). Searches, insertions and deletions are done in O(log N).
2221 Please see a text book about data structures for a detailed
2222 description of red-black trees. Any book worth its salt should
2227 struct mem_node
*left
, *right
, *parent
;
2229 /* Start and end of allocated region. */
2233 enum {MEM_BLACK
, MEM_RED
} color
;
2239 /* Root of the tree describing allocated Lisp memory. */
2241 static struct mem_node
*mem_root
;
2243 /* Sentinel node of the tree. */
2245 static struct mem_node mem_z
;
2246 #define MEM_NIL &mem_z
2249 /* Initialize this part of alloc.c. */
2254 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2255 mem_z
.parent
= NULL
;
2256 mem_z
.color
= MEM_BLACK
;
2257 mem_z
.start
= mem_z
.end
= NULL
;
2262 /* Value is a pointer to the mem_node containing START. Value is
2263 MEM_NIL if there is no node in the tree containing START. */
2265 static INLINE
struct mem_node
*
2271 /* Make the search always successful to speed up the loop below. */
2272 mem_z
.start
= start
;
2273 mem_z
.end
= (char *) start
+ 1;
2276 while (start
< p
->start
|| start
>= p
->end
)
2277 p
= start
< p
->start
? p
->left
: p
->right
;
2282 /* Insert a new node into the tree for a block of memory with start
2283 address START, end address END, and type TYPE. Value is a
2284 pointer to the node that was inserted. */
2286 static struct mem_node
*
2287 mem_insert (start
, end
, type
)
2291 struct mem_node
*c
, *parent
, *x
;
2293 /* See where in the tree a node for START belongs. In this
2294 particular application, it shouldn't happen that a node is already
2295 present. For debugging purposes, let's check that. */
2299 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2301 while (c
!= MEM_NIL
)
2303 if (start
>= c
->start
&& start
< c
->end
)
2306 c
= start
< c
->start
? c
->left
: c
->right
;
2309 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2311 while (c
!= MEM_NIL
)
2314 c
= start
< c
->start
? c
->left
: c
->right
;
2317 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2319 /* Create a new node. */
2320 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2325 x
->left
= x
->right
= MEM_NIL
;
2328 /* Insert it as child of PARENT or install it as root. */
2331 if (start
< parent
->start
)
2339 /* Re-establish red-black tree properties. */
2340 mem_insert_fixup (x
);
2345 /* Re-establish the red-black properties of the tree, and thereby
2346 balance the tree, after node X has been inserted; X is always red. */
2349 mem_insert_fixup (x
)
2352 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2354 /* X is red and its parent is red. This is a violation of
2355 red-black tree property #3. */
2357 if (x
->parent
== x
->parent
->parent
->left
)
2359 /* We're on the left side of our grandparent, and Y is our
2361 struct mem_node
*y
= x
->parent
->parent
->right
;
2363 if (y
->color
== MEM_RED
)
2365 /* Uncle and parent are red but should be black because
2366 X is red. Change the colors accordingly and proceed
2367 with the grandparent. */
2368 x
->parent
->color
= MEM_BLACK
;
2369 y
->color
= MEM_BLACK
;
2370 x
->parent
->parent
->color
= MEM_RED
;
2371 x
= x
->parent
->parent
;
2375 /* Parent and uncle have different colors; parent is
2376 red, uncle is black. */
2377 if (x
== x
->parent
->right
)
2380 mem_rotate_left (x
);
2383 x
->parent
->color
= MEM_BLACK
;
2384 x
->parent
->parent
->color
= MEM_RED
;
2385 mem_rotate_right (x
->parent
->parent
);
2390 /* This is the symmetrical case of above. */
2391 struct mem_node
*y
= x
->parent
->parent
->left
;
2393 if (y
->color
== MEM_RED
)
2395 x
->parent
->color
= MEM_BLACK
;
2396 y
->color
= MEM_BLACK
;
2397 x
->parent
->parent
->color
= MEM_RED
;
2398 x
= x
->parent
->parent
;
2402 if (x
== x
->parent
->left
)
2405 mem_rotate_right (x
);
2408 x
->parent
->color
= MEM_BLACK
;
2409 x
->parent
->parent
->color
= MEM_RED
;
2410 mem_rotate_left (x
->parent
->parent
);
2415 /* The root may have been changed to red due to the algorithm. Set
2416 it to black so that property #5 is satisfied. */
2417 mem_root
->color
= MEM_BLACK
;
2433 /* Turn y's left sub-tree into x's right sub-tree. */
2436 if (y
->left
!= MEM_NIL
)
2437 y
->left
->parent
= x
;
2439 /* Y's parent was x's parent. */
2441 y
->parent
= x
->parent
;
2443 /* Get the parent to point to y instead of x. */
2446 if (x
== x
->parent
->left
)
2447 x
->parent
->left
= y
;
2449 x
->parent
->right
= y
;
2454 /* Put x on y's left. */
2468 mem_rotate_right (x
)
2471 struct mem_node
*y
= x
->left
;
2474 if (y
->right
!= MEM_NIL
)
2475 y
->right
->parent
= x
;
2478 y
->parent
= x
->parent
;
2481 if (x
== x
->parent
->right
)
2482 x
->parent
->right
= y
;
2484 x
->parent
->left
= y
;
2495 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2501 struct mem_node
*x
, *y
;
2503 if (!z
|| z
== MEM_NIL
)
2506 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2511 while (y
->left
!= MEM_NIL
)
2515 if (y
->left
!= MEM_NIL
)
2520 x
->parent
= y
->parent
;
2523 if (y
== y
->parent
->left
)
2524 y
->parent
->left
= x
;
2526 y
->parent
->right
= x
;
2533 z
->start
= y
->start
;
2538 if (y
->color
== MEM_BLACK
)
2539 mem_delete_fixup (x
);
2544 /* Re-establish the red-black properties of the tree, after a
2548 mem_delete_fixup (x
)
2551 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2553 if (x
== x
->parent
->left
)
2555 struct mem_node
*w
= x
->parent
->right
;
2557 if (w
->color
== MEM_RED
)
2559 w
->color
= MEM_BLACK
;
2560 x
->parent
->color
= MEM_RED
;
2561 mem_rotate_left (x
->parent
);
2562 w
= x
->parent
->right
;
2565 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2572 if (w
->right
->color
== MEM_BLACK
)
2574 w
->left
->color
= MEM_BLACK
;
2576 mem_rotate_right (w
);
2577 w
= x
->parent
->right
;
2579 w
->color
= x
->parent
->color
;
2580 x
->parent
->color
= MEM_BLACK
;
2581 w
->right
->color
= MEM_BLACK
;
2582 mem_rotate_left (x
->parent
);
2588 struct mem_node
*w
= x
->parent
->left
;
2590 if (w
->color
== MEM_RED
)
2592 w
->color
= MEM_BLACK
;
2593 x
->parent
->color
= MEM_RED
;
2594 mem_rotate_right (x
->parent
);
2595 w
= x
->parent
->left
;
2598 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2605 if (w
->left
->color
== MEM_BLACK
)
2607 w
->right
->color
= MEM_BLACK
;
2609 mem_rotate_left (w
);
2610 w
= x
->parent
->left
;
2613 w
->color
= x
->parent
->color
;
2614 x
->parent
->color
= MEM_BLACK
;
2615 w
->left
->color
= MEM_BLACK
;
2616 mem_rotate_right (x
->parent
);
2622 x
->color
= MEM_BLACK
;
2626 /* Value is non-zero if P is a pointer to a live Lisp string on
2627 the heap. M is a pointer to the mem_block for P. */
2630 live_string_p (m
, p
)
2634 if (m
->type
== MEM_TYPE_STRING
)
2636 struct string_block
*b
= (struct string_block
*) m
->start
;
2637 int offset
= (char *) p
- (char *) &b
->strings
[0];
2639 /* P must point to the start of a Lisp_String structure, and it
2640 must not be on the free-list. */
2641 return (offset
% sizeof b
->strings
[0] == 0
2642 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2649 /* Value is non-zero if P is a pointer to a live Lisp cons on
2650 the heap. M is a pointer to the mem_block for P. */
2657 if (m
->type
== MEM_TYPE_CONS
)
2659 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2660 int offset
= (char *) p
- (char *) &b
->conses
[0];
2662 /* P must point to the start of a Lisp_Cons, not be
2663 one of the unused cells in the current cons block,
2664 and not be on the free-list. */
2665 return (offset
% sizeof b
->conses
[0] == 0
2667 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2668 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2675 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2676 the heap. M is a pointer to the mem_block for P. */
2679 live_symbol_p (m
, p
)
2683 if (m
->type
== MEM_TYPE_SYMBOL
)
2685 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2686 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2688 /* P must point to the start of a Lisp_Symbol, not be
2689 one of the unused cells in the current symbol block,
2690 and not be on the free-list. */
2691 return (offset
% sizeof b
->symbols
[0] == 0
2692 && (b
!= symbol_block
2693 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2694 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2701 /* Value is non-zero if P is a pointer to a live Lisp float on
2702 the heap. M is a pointer to the mem_block for P. */
2709 if (m
->type
== MEM_TYPE_FLOAT
)
2711 struct float_block
*b
= (struct float_block
*) m
->start
;
2712 int offset
= (char *) p
- (char *) &b
->floats
[0];
2714 /* P must point to the start of a Lisp_Float, not be
2715 one of the unused cells in the current float block,
2716 and not be on the free-list. */
2717 return (offset
% sizeof b
->floats
[0] == 0
2718 && (b
!= float_block
2719 || offset
/ sizeof b
->floats
[0] < float_block_index
)
2720 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
2727 /* Value is non-zero if P is a pointer to a live Lisp Misc on
2728 the heap. M is a pointer to the mem_block for P. */
2735 if (m
->type
== MEM_TYPE_MISC
)
2737 struct marker_block
*b
= (struct marker_block
*) m
->start
;
2738 int offset
= (char *) p
- (char *) &b
->markers
[0];
2740 /* P must point to the start of a Lisp_Misc, not be
2741 one of the unused cells in the current misc block,
2742 and not be on the free-list. */
2743 return (offset
% sizeof b
->markers
[0] == 0
2744 && (b
!= marker_block
2745 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
2746 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
2753 /* Value is non-zero if P is a pointer to a live vector-like object.
2754 M is a pointer to the mem_block for P. */
2757 live_vector_p (m
, p
)
2761 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
2765 /* Value is non-zero of P is a pointer to a live buffer. M is a
2766 pointer to the mem_block for P. */
2769 live_buffer_p (m
, p
)
2773 /* P must point to the start of the block, and the buffer
2774 must not have been killed. */
2775 return (m
->type
== MEM_TYPE_BUFFER
2777 && !NILP (((struct buffer
*) p
)->name
));
2781 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2783 /* Array of objects that are kept alive because the C stack contains
2784 a pattern that looks like a reference to them . */
2786 #define MAX_ZOMBIES 10
2787 static Lisp_Object zombies
[MAX_ZOMBIES
];
2789 /* Number of zombie objects. */
2791 static int nzombies
;
2793 /* Number of garbage collections. */
2797 /* Average percentage of zombies per collection. */
2799 static double avg_zombies
;
2801 /* Max. number of live and zombie objects. */
2803 static int max_live
, max_zombies
;
2805 /* Average number of live objects per GC. */
2807 static double avg_live
;
2809 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
2810 "Show information about live and zombie objects.")
2813 Lisp_Object args
[7];
2814 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2815 args
[1] = make_number (ngcs
);
2816 args
[2] = make_float (avg_live
);
2817 args
[3] = make_float (avg_zombies
);
2818 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
2819 args
[5] = make_number (max_live
);
2820 args
[6] = make_number (max_zombies
);
2821 return Fmessage (7, args
);
2824 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2827 /* Mark OBJ if we can prove it's a Lisp_Object. */
2830 mark_maybe_object (obj
)
2833 void *po
= (void *) XPNTR (obj
);
2834 struct mem_node
*m
= mem_find (po
);
2840 switch (XGCTYPE (obj
))
2843 mark_p
= (live_string_p (m
, po
)
2844 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
2848 mark_p
= (live_cons_p (m
, po
)
2849 && !XMARKBIT (XCONS (obj
)->car
));
2853 mark_p
= (live_symbol_p (m
, po
)
2854 && !XMARKBIT (XSYMBOL (obj
)->plist
));
2858 mark_p
= (live_float_p (m
, po
)
2859 && !XMARKBIT (XFLOAT (obj
)->type
));
2862 case Lisp_Vectorlike
:
2863 /* Note: can't check GC_BUFFERP before we know it's a
2864 buffer because checking that dereferences the pointer
2865 PO which might point anywhere. */
2866 if (live_vector_p (m
, po
))
2867 mark_p
= (!GC_SUBRP (obj
)
2868 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
2869 else if (live_buffer_p (m
, po
))
2870 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
2874 if (live_misc_p (m
, po
))
2876 switch (XMISCTYPE (obj
))
2878 case Lisp_Misc_Marker
:
2879 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
2882 case Lisp_Misc_Buffer_Local_Value
:
2883 case Lisp_Misc_Some_Buffer_Local_Value
:
2884 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2887 case Lisp_Misc_Overlay
:
2888 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
2897 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2898 if (nzombies
< MAX_ZOMBIES
)
2899 zombies
[nzombies
] = *p
;
2907 /* Mark Lisp objects in the address range START..END. */
2910 mark_memory (start
, end
)
2915 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2919 /* Make START the pointer to the start of the memory region,
2920 if it isn't already. */
2928 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
2929 mark_maybe_object (*p
);
2933 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2935 static int setjmp_tested_p
, longjmps_done
;
2937 #define SETJMP_WILL_LIKELY_WORK "\
2939 Emacs garbage collector has been changed to use conservative stack\n\
2940 marking. Emacs has determined that the method it uses to do the\n\
2941 marking will likely work on your system, but this isn't sure.\n\
2943 If you are a system-programmer, or can get the help of a local wizard\n\
2944 who is, please take a look at the function mark_stack in alloc.c, and\n\
2945 verify that the methods used are appropriate for your system.\n\
2947 Please mail the result to <gerd@gnu.org>.\n\
2950 #define SETJMP_WILL_NOT_WORK "\
2952 Emacs garbage collector has been changed to use conservative stack\n\
2953 marking. Emacs has determined that the default method it uses to do the\n\
2954 marking will not work on your system. We will need a system-dependent\n\
2955 solution for your system.\n\
2957 Please take a look at the function mark_stack in alloc.c, and\n\
2958 try to find a way to make it work on your system.\n\
2959 Please mail the result to <gerd@gnu.org>.\n\
2963 /* Perform a quick check if it looks like setjmp saves registers in a
2964 jmp_buf. Print a message to stderr saying so. When this test
2965 succeeds, this is _not_ a proof that setjmp is sufficient for
2966 conservative stack marking. Only the sources or a disassembly
2977 /* Arrange for X to be put in a register. */
2983 if (longjmps_done
== 1)
2985 /* Came here after the longjmp at the end of the function.
2987 If x == 1, the longjmp has restored the register to its
2988 value before the setjmp, and we can hope that setjmp
2989 saves all such registers in the jmp_buf, although that
2992 For other values of X, either something really strange is
2993 taking place, or the setjmp just didn't save the register. */
2996 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
2999 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3006 if (longjmps_done
== 1)
3010 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3013 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3015 /* Abort if anything GCPRO'd doesn't survive the GC. */
3023 for (p
= gcprolist
; p
; p
= p
->next
)
3024 for (i
= 0; i
< p
->nvars
; ++i
)
3025 if (!survives_gc_p (p
->var
[i
]))
3029 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3036 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3037 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3039 fprintf (stderr
, " %d = ", i
);
3040 debug_print (zombies
[i
]);
3044 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3047 /* Mark live Lisp objects on the C stack.
3049 There are several system-dependent problems to consider when
3050 porting this to new architectures:
3054 We have to mark Lisp objects in CPU registers that can hold local
3055 variables or are used to pass parameters.
3057 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3058 something that either saves relevant registers on the stack, or
3059 calls mark_maybe_object passing it each register's contents.
3061 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3062 implementation assumes that calling setjmp saves registers we need
3063 to see in a jmp_buf which itself lies on the stack. This doesn't
3064 have to be true! It must be verified for each system, possibly
3065 by taking a look at the source code of setjmp.
3069 Architectures differ in the way their processor stack is organized.
3070 For example, the stack might look like this
3073 | Lisp_Object | size = 4
3075 | something else | size = 2
3077 | Lisp_Object | size = 4
3081 In such a case, not every Lisp_Object will be aligned equally. To
3082 find all Lisp_Object on the stack it won't be sufficient to walk
3083 the stack in steps of 4 bytes. Instead, two passes will be
3084 necessary, one starting at the start of the stack, and a second
3085 pass starting at the start of the stack + 2. Likewise, if the
3086 minimal alignment of Lisp_Objects on the stack is 1, four passes
3087 would be necessary, each one starting with one byte more offset
3088 from the stack start.
3090 The current code assumes by default that Lisp_Objects are aligned
3091 equally on the stack. */
3097 int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3100 /* This trick flushes the register windows so that all the state of
3101 the process is contained in the stack. */
3106 /* Save registers that we need to see on the stack. We need to see
3107 registers used to hold register variables and registers used to
3109 #ifdef GC_SAVE_REGISTERS_ON_STACK
3110 GC_SAVE_REGISTERS_ON_STACK (end
);
3111 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3113 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3114 setjmp will definitely work, test it
3115 and print a message with the result
3117 if (!setjmp_tested_p
)
3119 setjmp_tested_p
= 1;
3122 #endif /* GC_SETJMP_WORKS */
3125 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3126 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3128 /* This assumes that the stack is a contiguous region in memory. If
3129 that's not the case, something has to be done here to iterate
3130 over the stack segments. */
3131 #if GC_LISP_OBJECT_ALIGNMENT == 1
3132 mark_memory (stack_base
, end
);
3133 mark_memory ((char *) stack_base
+ 1, end
);
3134 mark_memory ((char *) stack_base
+ 2, end
);
3135 mark_memory ((char *) stack_base
+ 3, end
);
3136 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3137 mark_memory (stack_base
, end
);
3138 mark_memory ((char *) stack_base
+ 2, end
);
3140 mark_memory (stack_base
, end
);
3143 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3149 #endif /* GC_MARK_STACK != 0 */
3153 /***********************************************************************
3154 Pure Storage Management
3155 ***********************************************************************/
3157 /* Return a string allocated in pure space. DATA is a buffer holding
3158 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3159 non-zero means make the result string multibyte.
3161 Must get an error if pure storage is full, since if it cannot hold
3162 a large string it may be able to hold conses that point to that
3163 string; then the string is not protected from gc. */
3166 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3172 struct Lisp_String
*s
;
3173 int string_size
, data_size
;
3175 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3177 string_size
= PAD (sizeof (struct Lisp_String
));
3178 data_size
= PAD (nbytes
+ 1);
3182 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3183 error ("Pure Lisp storage exhausted");
3185 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3186 pureptr
+= string_size
;
3187 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3188 pureptr
+= data_size
;
3191 s
->size_byte
= multibyte
? nbytes
: -1;
3192 bcopy (data
, s
->data
, nbytes
);
3193 s
->data
[nbytes
] = '\0';
3194 s
->intervals
= NULL_INTERVAL
;
3196 XSETSTRING (string
, s
);
3201 /* Return a cons allocated from pure space. Give it pure copies
3202 of CAR as car and CDR as cdr. */
3205 pure_cons (car
, cdr
)
3206 Lisp_Object car
, cdr
;
3208 register Lisp_Object
new;
3210 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3211 error ("Pure Lisp storage exhausted");
3212 XSETCONS (new, PUREBEG
+ pureptr
);
3213 pureptr
+= sizeof (struct Lisp_Cons
);
3214 XCAR (new) = Fpurecopy (car
);
3215 XCDR (new) = Fpurecopy (cdr
);
3220 /* Value is a float object with value NUM allocated from pure space. */
3223 make_pure_float (num
)
3226 register Lisp_Object
new;
3228 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3229 (double) boundary. Some architectures (like the sparc) require
3230 this, and I suspect that floats are rare enough that it's no
3231 tragedy for those that do. */
3234 char *p
= PUREBEG
+ pureptr
;
3238 alignment
= __alignof (struct Lisp_Float
);
3240 alignment
= sizeof (struct Lisp_Float
);
3243 alignment
= sizeof (struct Lisp_Float
);
3245 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3246 pureptr
= p
- PUREBEG
;
3249 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3250 error ("Pure Lisp storage exhausted");
3251 XSETFLOAT (new, PUREBEG
+ pureptr
);
3252 pureptr
+= sizeof (struct Lisp_Float
);
3253 XFLOAT_DATA (new) = num
;
3254 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3259 /* Return a vector with room for LEN Lisp_Objects allocated from
3263 make_pure_vector (len
)
3266 register Lisp_Object
new;
3267 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3268 + (len
- 1) * sizeof (Lisp_Object
));
3270 if (pureptr
+ size
> PURESIZE
)
3271 error ("Pure Lisp storage exhausted");
3273 XSETVECTOR (new, PUREBEG
+ pureptr
);
3275 XVECTOR (new)->size
= len
;
3280 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3281 "Make a copy of OBJECT in pure storage.\n\
3282 Recursively copies contents of vectors and cons cells.\n\
3283 Does not copy symbols. Copies strings without text properties.")
3285 register Lisp_Object obj
;
3287 if (NILP (Vpurify_flag
))
3290 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3291 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3295 return pure_cons (XCAR (obj
), XCDR (obj
));
3296 else if (FLOATP (obj
))
3297 return make_pure_float (XFLOAT_DATA (obj
));
3298 else if (STRINGP (obj
))
3299 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3300 STRING_BYTES (XSTRING (obj
)),
3301 STRING_MULTIBYTE (obj
));
3302 else if (COMPILEDP (obj
) || VECTORP (obj
))
3304 register struct Lisp_Vector
*vec
;
3305 register int i
, size
;
3307 size
= XVECTOR (obj
)->size
;
3308 if (size
& PSEUDOVECTOR_FLAG
)
3309 size
&= PSEUDOVECTOR_SIZE_MASK
;
3310 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3311 for (i
= 0; i
< size
; i
++)
3312 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3313 if (COMPILEDP (obj
))
3314 XSETCOMPILED (obj
, vec
);
3316 XSETVECTOR (obj
, vec
);
3319 else if (MARKERP (obj
))
3320 error ("Attempt to copy a marker to pure storage");
3327 /***********************************************************************
3329 ***********************************************************************/
3331 /* Recording what needs to be marked for gc. */
3333 struct gcpro
*gcprolist
;
3335 /* Addresses of staticpro'd variables. */
3337 #define NSTATICS 1024
3338 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3340 /* Index of next unused slot in staticvec. */
3345 /* Put an entry in staticvec, pointing at the variable with address
3349 staticpro (varaddress
)
3350 Lisp_Object
*varaddress
;
3352 staticvec
[staticidx
++] = varaddress
;
3353 if (staticidx
>= NSTATICS
)
3361 struct catchtag
*next
;
3366 struct backtrace
*next
;
3367 Lisp_Object
*function
;
3368 Lisp_Object
*args
; /* Points to vector of args. */
3369 int nargs
; /* Length of vector. */
3370 /* If nargs is UNEVALLED, args points to slot holding list of
3377 /***********************************************************************
3379 ***********************************************************************/
3381 /* Temporarily prevent garbage collection. */
3384 inhibit_garbage_collection ()
3386 int count
= specpdl_ptr
- specpdl
;
3388 int nbits
= min (VALBITS
, BITS_PER_INT
);
3390 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3392 specbind (Qgc_cons_threshold
, number
);
3398 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3399 "Reclaim storage for Lisp objects no longer needed.\n\
3400 Returns info on amount of space in use:\n\
3401 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3402 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3403 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3404 (USED-STRINGS . FREE-STRINGS))\n\
3405 Garbage collection happens automatically if you cons more than\n\
3406 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3409 register struct gcpro
*tail
;
3410 register struct specbinding
*bind
;
3411 struct catchtag
*catch;
3412 struct handler
*handler
;
3413 register struct backtrace
*backlist
;
3414 char stack_top_variable
;
3417 Lisp_Object total
[7];
3419 /* In case user calls debug_print during GC,
3420 don't let that cause a recursive GC. */
3421 consing_since_gc
= 0;
3423 /* Save what's currently displayed in the echo area. */
3424 message_p
= push_message ();
3426 /* Save a copy of the contents of the stack, for debugging. */
3427 #if MAX_SAVE_STACK > 0
3428 if (NILP (Vpurify_flag
))
3430 i
= &stack_top_variable
- stack_bottom
;
3432 if (i
< MAX_SAVE_STACK
)
3434 if (stack_copy
== 0)
3435 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3436 else if (stack_copy_size
< i
)
3437 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3440 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3441 bcopy (stack_bottom
, stack_copy
, i
);
3443 bcopy (&stack_top_variable
, stack_copy
, i
);
3447 #endif /* MAX_SAVE_STACK > 0 */
3449 if (garbage_collection_messages
)
3450 message1_nolog ("Garbage collecting...");
3454 shrink_regexp_cache ();
3456 /* Don't keep undo information around forever. */
3458 register struct buffer
*nextb
= all_buffers
;
3462 /* If a buffer's undo list is Qt, that means that undo is
3463 turned off in that buffer. Calling truncate_undo_list on
3464 Qt tends to return NULL, which effectively turns undo back on.
3465 So don't call truncate_undo_list if undo_list is Qt. */
3466 if (! EQ (nextb
->undo_list
, Qt
))
3468 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3470 nextb
= nextb
->next
;
3476 /* clear_marks (); */
3478 /* Mark all the special slots that serve as the roots of accessibility.
3480 Usually the special slots to mark are contained in particular structures.
3481 Then we know no slot is marked twice because the structures don't overlap.
3482 In some cases, the structures point to the slots to be marked.
3483 For these, we use MARKBIT to avoid double marking of the slot. */
3485 for (i
= 0; i
< staticidx
; i
++)
3486 mark_object (staticvec
[i
]);
3488 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3489 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3492 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3493 for (i
= 0; i
< tail
->nvars
; i
++)
3494 if (!XMARKBIT (tail
->var
[i
]))
3496 mark_object (&tail
->var
[i
]);
3497 XMARK (tail
->var
[i
]);
3502 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3504 mark_object (&bind
->symbol
);
3505 mark_object (&bind
->old_value
);
3507 for (catch = catchlist
; catch; catch = catch->next
)
3509 mark_object (&catch->tag
);
3510 mark_object (&catch->val
);
3512 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3514 mark_object (&handler
->handler
);
3515 mark_object (&handler
->var
);
3517 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3519 if (!XMARKBIT (*backlist
->function
))
3521 mark_object (backlist
->function
);
3522 XMARK (*backlist
->function
);
3524 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3527 i
= backlist
->nargs
- 1;
3529 if (!XMARKBIT (backlist
->args
[i
]))
3531 mark_object (&backlist
->args
[i
]);
3532 XMARK (backlist
->args
[i
]);
3537 /* Look thru every buffer's undo list
3538 for elements that update markers that were not marked,
3541 register struct buffer
*nextb
= all_buffers
;
3545 /* If a buffer's undo list is Qt, that means that undo is
3546 turned off in that buffer. Calling truncate_undo_list on
3547 Qt tends to return NULL, which effectively turns undo back on.
3548 So don't call truncate_undo_list if undo_list is Qt. */
3549 if (! EQ (nextb
->undo_list
, Qt
))
3551 Lisp_Object tail
, prev
;
3552 tail
= nextb
->undo_list
;
3554 while (CONSP (tail
))
3556 if (GC_CONSP (XCAR (tail
))
3557 && GC_MARKERP (XCAR (XCAR (tail
)))
3558 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3561 nextb
->undo_list
= tail
= XCDR (tail
);
3563 tail
= XCDR (prev
) = XCDR (tail
);
3573 nextb
= nextb
->next
;
3577 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3583 /* Clear the mark bits that we set in certain root slots. */
3585 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3586 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3587 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3588 for (i
= 0; i
< tail
->nvars
; i
++)
3589 XUNMARK (tail
->var
[i
]);
3592 unmark_byte_stack ();
3593 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3595 XUNMARK (*backlist
->function
);
3596 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3599 i
= backlist
->nargs
- 1;
3601 XUNMARK (backlist
->args
[i
]);
3603 XUNMARK (buffer_defaults
.name
);
3604 XUNMARK (buffer_local_symbols
.name
);
3606 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3612 /* clear_marks (); */
3615 consing_since_gc
= 0;
3616 if (gc_cons_threshold
< 10000)
3617 gc_cons_threshold
= 10000;
3619 if (garbage_collection_messages
)
3621 if (message_p
|| minibuf_level
> 0)
3624 message1_nolog ("Garbage collecting...done");
3629 total
[0] = Fcons (make_number (total_conses
),
3630 make_number (total_free_conses
));
3631 total
[1] = Fcons (make_number (total_symbols
),
3632 make_number (total_free_symbols
));
3633 total
[2] = Fcons (make_number (total_markers
),
3634 make_number (total_free_markers
));
3635 total
[3] = Fcons (make_number (total_string_size
),
3636 make_number (total_vector_size
));
3637 total
[4] = Fcons (make_number (total_floats
),
3638 make_number (total_free_floats
));
3639 total
[5] = Fcons (make_number (total_intervals
),
3640 make_number (total_free_intervals
));
3641 total
[6] = Fcons (make_number (total_strings
),
3642 make_number (total_free_strings
));
3644 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3646 /* Compute average percentage of zombies. */
3649 for (i
= 0; i
< 7; ++i
)
3650 nlive
+= XFASTINT (XCAR (total
[i
]));
3652 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3653 max_live
= max (nlive
, max_live
);
3654 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3655 max_zombies
= max (nzombies
, max_zombies
);
3660 return Flist (7, total
);
3664 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3665 only interesting objects referenced from glyphs are strings. */
3668 mark_glyph_matrix (matrix
)
3669 struct glyph_matrix
*matrix
;
3671 struct glyph_row
*row
= matrix
->rows
;
3672 struct glyph_row
*end
= row
+ matrix
->nrows
;
3674 for (; row
< end
; ++row
)
3678 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3680 struct glyph
*glyph
= row
->glyphs
[area
];
3681 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3683 for (; glyph
< end_glyph
; ++glyph
)
3684 if (GC_STRINGP (glyph
->object
)
3685 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3686 mark_object (&glyph
->object
);
3692 /* Mark Lisp faces in the face cache C. */
3696 struct face_cache
*c
;
3701 for (i
= 0; i
< c
->used
; ++i
)
3703 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3707 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3708 mark_object (&face
->lface
[j
]);
3715 #ifdef HAVE_WINDOW_SYSTEM
3717 /* Mark Lisp objects in image IMG. */
3723 mark_object (&img
->spec
);
3725 if (!NILP (img
->data
.lisp_val
))
3726 mark_object (&img
->data
.lisp_val
);
3730 /* Mark Lisp objects in image cache of frame F. It's done this way so
3731 that we don't have to include xterm.h here. */
3734 mark_image_cache (f
)
3737 forall_images_in_image_cache (f
, mark_image
);
3740 #endif /* HAVE_X_WINDOWS */
3744 /* Mark reference to a Lisp_Object.
3745 If the object referred to has not been seen yet, recursively mark
3746 all the references contained in it. */
3748 #define LAST_MARKED_SIZE 500
3749 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3750 int last_marked_index
;
3753 mark_object (argptr
)
3754 Lisp_Object
*argptr
;
3756 Lisp_Object
*objptr
= argptr
;
3757 register Lisp_Object obj
;
3764 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3767 last_marked
[last_marked_index
++] = objptr
;
3768 if (last_marked_index
== LAST_MARKED_SIZE
)
3769 last_marked_index
= 0;
3771 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3775 register struct Lisp_String
*ptr
= XSTRING (obj
);
3776 MARK_INTERVAL_TREE (ptr
->intervals
);
3781 case Lisp_Vectorlike
:
3782 if (GC_BUFFERP (obj
))
3784 if (!XMARKBIT (XBUFFER (obj
)->name
))
3787 else if (GC_SUBRP (obj
))
3789 else if (GC_COMPILEDP (obj
))
3790 /* We could treat this just like a vector, but it is better to
3791 save the COMPILED_CONSTANTS element for last and avoid
3794 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3795 register EMACS_INT size
= ptr
->size
;
3796 /* See comment above under Lisp_Vector. */
3797 struct Lisp_Vector
*volatile ptr1
= ptr
;
3800 if (size
& ARRAY_MARK_FLAG
)
3801 break; /* Already marked */
3802 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3803 size
&= PSEUDOVECTOR_SIZE_MASK
;
3804 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3806 if (i
!= COMPILED_CONSTANTS
)
3807 mark_object (&ptr1
->contents
[i
]);
3809 /* This cast should be unnecessary, but some Mips compiler complains
3810 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3811 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
3814 else if (GC_FRAMEP (obj
))
3816 /* See comment above under Lisp_Vector for why this is volatile. */
3817 register struct frame
*volatile ptr
= XFRAME (obj
);
3818 register EMACS_INT size
= ptr
->size
;
3820 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3821 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3823 mark_object (&ptr
->name
);
3824 mark_object (&ptr
->icon_name
);
3825 mark_object (&ptr
->title
);
3826 mark_object (&ptr
->focus_frame
);
3827 mark_object (&ptr
->selected_window
);
3828 mark_object (&ptr
->minibuffer_window
);
3829 mark_object (&ptr
->param_alist
);
3830 mark_object (&ptr
->scroll_bars
);
3831 mark_object (&ptr
->condemned_scroll_bars
);
3832 mark_object (&ptr
->menu_bar_items
);
3833 mark_object (&ptr
->face_alist
);
3834 mark_object (&ptr
->menu_bar_vector
);
3835 mark_object (&ptr
->buffer_predicate
);
3836 mark_object (&ptr
->buffer_list
);
3837 mark_object (&ptr
->menu_bar_window
);
3838 mark_object (&ptr
->tool_bar_window
);
3839 mark_face_cache (ptr
->face_cache
);
3840 #ifdef HAVE_WINDOW_SYSTEM
3841 mark_image_cache (ptr
);
3842 mark_object (&ptr
->desired_tool_bar_items
);
3843 mark_object (&ptr
->current_tool_bar_items
);
3844 mark_object (&ptr
->desired_tool_bar_string
);
3845 mark_object (&ptr
->current_tool_bar_string
);
3846 #endif /* HAVE_WINDOW_SYSTEM */
3848 else if (GC_BOOL_VECTOR_P (obj
))
3850 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3852 if (ptr
->size
& ARRAY_MARK_FLAG
)
3853 break; /* Already marked */
3854 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3856 else if (GC_WINDOWP (obj
))
3858 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3859 struct window
*w
= XWINDOW (obj
);
3860 register EMACS_INT size
= ptr
->size
;
3861 /* The reason we use ptr1 is to avoid an apparent hardware bug
3862 that happens occasionally on the FSF's HP 300s.
3863 The bug is that a2 gets clobbered by recursive calls to mark_object.
3864 The clobberage seems to happen during function entry,
3865 perhaps in the moveml instruction.
3866 Yes, this is a crock, but we have to do it. */
3867 struct Lisp_Vector
*volatile ptr1
= ptr
;
3870 /* Stop if already marked. */
3871 if (size
& ARRAY_MARK_FLAG
)
3875 ptr
->size
|= ARRAY_MARK_FLAG
;
3877 /* There is no Lisp data above The member CURRENT_MATRIX in
3878 struct WINDOW. Stop marking when that slot is reached. */
3880 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
3882 mark_object (&ptr1
->contents
[i
]);
3884 /* Mark glyphs for leaf windows. Marking window matrices is
3885 sufficient because frame matrices use the same glyph
3887 if (NILP (w
->hchild
)
3889 && w
->current_matrix
)
3891 mark_glyph_matrix (w
->current_matrix
);
3892 mark_glyph_matrix (w
->desired_matrix
);
3895 else if (GC_HASH_TABLE_P (obj
))
3897 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
3898 EMACS_INT size
= h
->size
;
3900 /* Stop if already marked. */
3901 if (size
& ARRAY_MARK_FLAG
)
3905 h
->size
|= ARRAY_MARK_FLAG
;
3907 /* Mark contents. */
3908 mark_object (&h
->test
);
3909 mark_object (&h
->weak
);
3910 mark_object (&h
->rehash_size
);
3911 mark_object (&h
->rehash_threshold
);
3912 mark_object (&h
->hash
);
3913 mark_object (&h
->next
);
3914 mark_object (&h
->index
);
3915 mark_object (&h
->user_hash_function
);
3916 mark_object (&h
->user_cmp_function
);
3918 /* If hash table is not weak, mark all keys and values.
3919 For weak tables, mark only the vector. */
3920 if (GC_NILP (h
->weak
))
3921 mark_object (&h
->key_and_value
);
3923 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
3928 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3929 register EMACS_INT size
= ptr
->size
;
3930 /* The reason we use ptr1 is to avoid an apparent hardware bug
3931 that happens occasionally on the FSF's HP 300s.
3932 The bug is that a2 gets clobbered by recursive calls to mark_object.
3933 The clobberage seems to happen during function entry,
3934 perhaps in the moveml instruction.
3935 Yes, this is a crock, but we have to do it. */
3936 struct Lisp_Vector
*volatile ptr1
= ptr
;
3939 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3940 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3941 if (size
& PSEUDOVECTOR_FLAG
)
3942 size
&= PSEUDOVECTOR_SIZE_MASK
;
3944 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3945 mark_object (&ptr1
->contents
[i
]);
3951 /* See comment above under Lisp_Vector for why this is volatile. */
3952 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
3953 struct Lisp_Symbol
*ptrx
;
3955 if (XMARKBIT (ptr
->plist
)) break;
3957 mark_object ((Lisp_Object
*) &ptr
->value
);
3958 mark_object (&ptr
->function
);
3959 mark_object (&ptr
->plist
);
3961 if (!PURE_POINTER_P (ptr
->name
))
3962 MARK_STRING (ptr
->name
);
3963 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
3965 /* Note that we do not mark the obarray of the symbol.
3966 It is safe not to do so because nothing accesses that
3967 slot except to check whether it is nil. */
3971 /* For the benefit of the last_marked log. */
3972 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
3973 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
3974 XSETSYMBOL (obj
, ptrx
);
3975 /* We can't goto loop here because *objptr doesn't contain an
3976 actual Lisp_Object with valid datatype field. */
3983 switch (XMISCTYPE (obj
))
3985 case Lisp_Misc_Marker
:
3986 XMARK (XMARKER (obj
)->chain
);
3987 /* DO NOT mark thru the marker's chain.
3988 The buffer's markers chain does not preserve markers from gc;
3989 instead, markers are removed from the chain when freed by gc. */
3992 case Lisp_Misc_Buffer_Local_Value
:
3993 case Lisp_Misc_Some_Buffer_Local_Value
:
3995 register struct Lisp_Buffer_Local_Value
*ptr
3996 = XBUFFER_LOCAL_VALUE (obj
);
3997 if (XMARKBIT (ptr
->realvalue
)) break;
3998 XMARK (ptr
->realvalue
);
3999 /* If the cdr is nil, avoid recursion for the car. */
4000 if (EQ (ptr
->cdr
, Qnil
))
4002 objptr
= &ptr
->realvalue
;
4005 mark_object (&ptr
->realvalue
);
4006 mark_object (&ptr
->buffer
);
4007 mark_object (&ptr
->frame
);
4008 /* See comment above under Lisp_Vector for why not use ptr here. */
4009 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
4013 case Lisp_Misc_Intfwd
:
4014 case Lisp_Misc_Boolfwd
:
4015 case Lisp_Misc_Objfwd
:
4016 case Lisp_Misc_Buffer_Objfwd
:
4017 case Lisp_Misc_Kboard_Objfwd
:
4018 /* Don't bother with Lisp_Buffer_Objfwd,
4019 since all markable slots in current buffer marked anyway. */
4020 /* Don't need to do Lisp_Objfwd, since the places they point
4021 are protected with staticpro. */
4024 case Lisp_Misc_Overlay
:
4026 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4027 if (!XMARKBIT (ptr
->plist
))
4030 mark_object (&ptr
->start
);
4031 mark_object (&ptr
->end
);
4032 objptr
= &ptr
->plist
;
4045 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4046 if (XMARKBIT (ptr
->car
)) break;
4048 /* If the cdr is nil, avoid recursion for the car. */
4049 if (EQ (ptr
->cdr
, Qnil
))
4054 mark_object (&ptr
->car
);
4055 /* See comment above under Lisp_Vector for why not use ptr here. */
4056 objptr
= &XCDR (obj
);
4061 XMARK (XFLOAT (obj
)->type
);
4072 /* Mark the pointers in a buffer structure. */
4078 register struct buffer
*buffer
= XBUFFER (buf
);
4079 register Lisp_Object
*ptr
;
4080 Lisp_Object base_buffer
;
4082 /* This is the buffer's markbit */
4083 mark_object (&buffer
->name
);
4084 XMARK (buffer
->name
);
4086 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4088 if (CONSP (buffer
->undo_list
))
4091 tail
= buffer
->undo_list
;
4093 while (CONSP (tail
))
4095 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4097 if (XMARKBIT (ptr
->car
))
4100 if (GC_CONSP (ptr
->car
)
4101 && ! XMARKBIT (XCAR (ptr
->car
))
4102 && GC_MARKERP (XCAR (ptr
->car
)))
4104 XMARK (XCAR (ptr
->car
));
4105 mark_object (&XCDR (ptr
->car
));
4108 mark_object (&ptr
->car
);
4110 if (CONSP (ptr
->cdr
))
4116 mark_object (&XCDR (tail
));
4119 mark_object (&buffer
->undo_list
);
4121 for (ptr
= &buffer
->name
+ 1;
4122 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4126 /* If this is an indirect buffer, mark its base buffer. */
4127 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4129 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4130 mark_buffer (base_buffer
);
4135 /* Mark the pointers in the kboard objects. */
4142 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4144 if (kb
->kbd_macro_buffer
)
4145 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4147 mark_object (&kb
->Voverriding_terminal_local_map
);
4148 mark_object (&kb
->Vlast_command
);
4149 mark_object (&kb
->Vreal_last_command
);
4150 mark_object (&kb
->Vprefix_arg
);
4151 mark_object (&kb
->Vlast_prefix_arg
);
4152 mark_object (&kb
->kbd_queue
);
4153 mark_object (&kb
->defining_kbd_macro
);
4154 mark_object (&kb
->Vlast_kbd_macro
);
4155 mark_object (&kb
->Vsystem_key_alist
);
4156 mark_object (&kb
->system_key_syms
);
4157 mark_object (&kb
->Vdefault_minibuffer_frame
);
4162 /* Value is non-zero if OBJ will survive the current GC because it's
4163 either marked or does not need to be marked to survive. */
4171 switch (XGCTYPE (obj
))
4178 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4182 switch (XMISCTYPE (obj
))
4184 case Lisp_Misc_Marker
:
4185 survives_p
= XMARKBIT (obj
);
4188 case Lisp_Misc_Buffer_Local_Value
:
4189 case Lisp_Misc_Some_Buffer_Local_Value
:
4190 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4193 case Lisp_Misc_Intfwd
:
4194 case Lisp_Misc_Boolfwd
:
4195 case Lisp_Misc_Objfwd
:
4196 case Lisp_Misc_Buffer_Objfwd
:
4197 case Lisp_Misc_Kboard_Objfwd
:
4201 case Lisp_Misc_Overlay
:
4202 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4212 struct Lisp_String
*s
= XSTRING (obj
);
4213 survives_p
= STRING_MARKED_P (s
);
4217 case Lisp_Vectorlike
:
4218 if (GC_BUFFERP (obj
))
4219 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4220 else if (GC_SUBRP (obj
))
4223 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4227 survives_p
= XMARKBIT (XCAR (obj
));
4231 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4238 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4243 /* Sweep: find all structures not marked, and free them. */
4248 /* Remove or mark entries in weak hash tables.
4249 This must be done before any object is unmarked. */
4250 sweep_weak_hash_tables ();
4254 /* Put all unmarked conses on free list */
4256 register struct cons_block
*cblk
;
4257 struct cons_block
**cprev
= &cons_block
;
4258 register int lim
= cons_block_index
;
4259 register int num_free
= 0, num_used
= 0;
4263 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4267 for (i
= 0; i
< lim
; i
++)
4268 if (!XMARKBIT (cblk
->conses
[i
].car
))
4271 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4272 cons_free_list
= &cblk
->conses
[i
];
4274 cons_free_list
->car
= Vdead
;
4280 XUNMARK (cblk
->conses
[i
].car
);
4282 lim
= CONS_BLOCK_SIZE
;
4283 /* If this block contains only free conses and we have already
4284 seen more than two blocks worth of free conses then deallocate
4286 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4288 *cprev
= cblk
->next
;
4289 /* Unhook from the free list. */
4290 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4296 num_free
+= this_free
;
4297 cprev
= &cblk
->next
;
4300 total_conses
= num_used
;
4301 total_free_conses
= num_free
;
4304 /* Put all unmarked floats on free list */
4306 register struct float_block
*fblk
;
4307 struct float_block
**fprev
= &float_block
;
4308 register int lim
= float_block_index
;
4309 register int num_free
= 0, num_used
= 0;
4311 float_free_list
= 0;
4313 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4317 for (i
= 0; i
< lim
; i
++)
4318 if (!XMARKBIT (fblk
->floats
[i
].type
))
4321 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4322 float_free_list
= &fblk
->floats
[i
];
4324 float_free_list
->type
= Vdead
;
4330 XUNMARK (fblk
->floats
[i
].type
);
4332 lim
= FLOAT_BLOCK_SIZE
;
4333 /* If this block contains only free floats and we have already
4334 seen more than two blocks worth of free floats then deallocate
4336 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4338 *fprev
= fblk
->next
;
4339 /* Unhook from the free list. */
4340 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4346 num_free
+= this_free
;
4347 fprev
= &fblk
->next
;
4350 total_floats
= num_used
;
4351 total_free_floats
= num_free
;
4354 /* Put all unmarked intervals on free list */
4356 register struct interval_block
*iblk
;
4357 struct interval_block
**iprev
= &interval_block
;
4358 register int lim
= interval_block_index
;
4359 register int num_free
= 0, num_used
= 0;
4361 interval_free_list
= 0;
4363 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4368 for (i
= 0; i
< lim
; i
++)
4370 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4372 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4373 interval_free_list
= &iblk
->intervals
[i
];
4379 XUNMARK (iblk
->intervals
[i
].plist
);
4382 lim
= INTERVAL_BLOCK_SIZE
;
4383 /* If this block contains only free intervals and we have already
4384 seen more than two blocks worth of free intervals then
4385 deallocate this block. */
4386 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4388 *iprev
= iblk
->next
;
4389 /* Unhook from the free list. */
4390 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4392 n_interval_blocks
--;
4396 num_free
+= this_free
;
4397 iprev
= &iblk
->next
;
4400 total_intervals
= num_used
;
4401 total_free_intervals
= num_free
;
4404 /* Put all unmarked symbols on free list */
4406 register struct symbol_block
*sblk
;
4407 struct symbol_block
**sprev
= &symbol_block
;
4408 register int lim
= symbol_block_index
;
4409 register int num_free
= 0, num_used
= 0;
4411 symbol_free_list
= 0;
4413 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4417 for (i
= 0; i
< lim
; i
++)
4418 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4420 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4421 symbol_free_list
= &sblk
->symbols
[i
];
4423 symbol_free_list
->function
= Vdead
;
4430 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4431 UNMARK_STRING (sblk
->symbols
[i
].name
);
4432 XUNMARK (sblk
->symbols
[i
].plist
);
4434 lim
= SYMBOL_BLOCK_SIZE
;
4435 /* If this block contains only free symbols and we have already
4436 seen more than two blocks worth of free symbols then deallocate
4438 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4440 *sprev
= sblk
->next
;
4441 /* Unhook from the free list. */
4442 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4448 num_free
+= this_free
;
4449 sprev
= &sblk
->next
;
4452 total_symbols
= num_used
;
4453 total_free_symbols
= num_free
;
4456 /* Put all unmarked misc's on free list.
4457 For a marker, first unchain it from the buffer it points into. */
4459 register struct marker_block
*mblk
;
4460 struct marker_block
**mprev
= &marker_block
;
4461 register int lim
= marker_block_index
;
4462 register int num_free
= 0, num_used
= 0;
4464 marker_free_list
= 0;
4466 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4470 EMACS_INT already_free
= -1;
4472 for (i
= 0; i
< lim
; i
++)
4474 Lisp_Object
*markword
;
4475 switch (mblk
->markers
[i
].u_marker
.type
)
4477 case Lisp_Misc_Marker
:
4478 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4480 case Lisp_Misc_Buffer_Local_Value
:
4481 case Lisp_Misc_Some_Buffer_Local_Value
:
4482 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4484 case Lisp_Misc_Overlay
:
4485 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4487 case Lisp_Misc_Free
:
4488 /* If the object was already free, keep it
4489 on the free list. */
4490 markword
= (Lisp_Object
*) &already_free
;
4496 if (markword
&& !XMARKBIT (*markword
))
4499 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4501 /* tem1 avoids Sun compiler bug */
4502 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4503 XSETMARKER (tem
, tem1
);
4504 unchain_marker (tem
);
4506 /* Set the type of the freed object to Lisp_Misc_Free.
4507 We could leave the type alone, since nobody checks it,
4508 but this might catch bugs faster. */
4509 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4510 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4511 marker_free_list
= &mblk
->markers
[i
];
4518 XUNMARK (*markword
);
4521 lim
= MARKER_BLOCK_SIZE
;
4522 /* If this block contains only free markers and we have already
4523 seen more than two blocks worth of free markers then deallocate
4525 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4527 *mprev
= mblk
->next
;
4528 /* Unhook from the free list. */
4529 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4535 num_free
+= this_free
;
4536 mprev
= &mblk
->next
;
4540 total_markers
= num_used
;
4541 total_free_markers
= num_free
;
4544 /* Free all unmarked buffers */
4546 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4549 if (!XMARKBIT (buffer
->name
))
4552 prev
->next
= buffer
->next
;
4554 all_buffers
= buffer
->next
;
4555 next
= buffer
->next
;
4561 XUNMARK (buffer
->name
);
4562 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4563 prev
= buffer
, buffer
= buffer
->next
;
4567 /* Free all unmarked vectors */
4569 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4570 total_vector_size
= 0;
4573 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4576 prev
->next
= vector
->next
;
4578 all_vectors
= vector
->next
;
4579 next
= vector
->next
;
4587 vector
->size
&= ~ARRAY_MARK_FLAG
;
4588 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4589 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4591 total_vector_size
+= vector
->size
;
4592 prev
= vector
, vector
= vector
->next
;
4600 /* Debugging aids. */
4602 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4603 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4604 This may be helpful in debugging Emacs's memory usage.\n\
4605 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4610 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4615 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4616 "Return a list of counters that measure how much consing there has been.\n\
4617 Each of these counters increments for a certain kind of object.\n\
4618 The counters wrap around from the largest positive integer to zero.\n\
4619 Garbage collection does not decrease them.\n\
4620 The elements of the value are as follows:\n\
4621 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4622 All are in units of 1 = one object consed\n\
4623 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4625 MISCS include overlays, markers, and some internal types.\n\
4626 Frames, windows, buffers, and subprocesses count as vectors\n\
4627 (but the contents of a buffer's text do not count here).")
4630 Lisp_Object consed
[8];
4633 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4635 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4637 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4639 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4641 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4643 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4645 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4647 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4649 return Flist (8, consed
);
4652 /* Initialization */
4657 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4661 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4664 pure_size
= PURESIZE
;
4667 ignore_warnings
= 1;
4668 #ifdef DOUG_LEA_MALLOC
4669 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4670 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4671 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4681 malloc_hysteresis
= 32;
4683 malloc_hysteresis
= 0;
4686 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4688 ignore_warnings
= 0;
4690 byte_stack_list
= 0;
4692 consing_since_gc
= 0;
4693 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4694 #ifdef VIRT_ADDR_VARIES
4695 malloc_sbrk_unused
= 1<<22; /* A large number */
4696 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4697 #endif /* VIRT_ADDR_VARIES */
4704 byte_stack_list
= 0;
4706 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4707 setjmp_tested_p
= longjmps_done
= 0;
4715 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4716 "*Number of bytes of consing between garbage collections.\n\
4717 Garbage collection can happen automatically once this many bytes have been\n\
4718 allocated since the last garbage collection. All data types count.\n\n\
4719 Garbage collection happens automatically only when `eval' is called.\n\n\
4720 By binding this temporarily to a large number, you can effectively\n\
4721 prevent garbage collection during a part of the program.");
4723 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4724 "Number of bytes of sharable Lisp data allocated so far.");
4726 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4727 "Number of cons cells that have been consed so far.");
4729 DEFVAR_INT ("floats-consed", &floats_consed
,
4730 "Number of floats that have been consed so far.");
4732 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4733 "Number of vector cells that have been consed so far.");
4735 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4736 "Number of symbols that have been consed so far.");
4738 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4739 "Number of string characters that have been consed so far.");
4741 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4742 "Number of miscellaneous objects that have been consed so far.");
4744 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4745 "Number of intervals that have been consed so far.");
4747 DEFVAR_INT ("strings-consed", &strings_consed
,
4748 "Number of strings that have been consed so far.");
4750 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4751 "Non-nil means loading Lisp code in order to dump an executable.\n\
4752 This means that certain objects should be allocated in shared (pure) space.");
4754 DEFVAR_INT ("undo-limit", &undo_limit
,
4755 "Keep no more undo information once it exceeds this size.\n\
4756 This limit is applied when garbage collection happens.\n\
4757 The size is counted as the number of bytes occupied,\n\
4758 which includes both saved text and other data.");
4761 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
4762 "Don't keep more than this much size of undo information.\n\
4763 A command which pushes past this size is itself forgotten.\n\
4764 This limit is applied when garbage collection happens.\n\
4765 The size is counted as the number of bytes occupied,\n\
4766 which includes both saved text and other data.");
4767 undo_strong_limit
= 30000;
4769 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
4770 "Non-nil means display messages at start and end of garbage collection.");
4771 garbage_collection_messages
= 0;
4773 /* We build this in advance because if we wait until we need it, we might
4774 not be able to allocate the memory to hold it. */
4776 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
4777 staticpro (&memory_signal_data
);
4779 staticpro (&Qgc_cons_threshold
);
4780 Qgc_cons_threshold
= intern ("gc-cons-threshold");
4782 staticpro (&Qchar_table_extra_slots
);
4783 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
4788 defsubr (&Smake_byte_code
);
4789 defsubr (&Smake_list
);
4790 defsubr (&Smake_vector
);
4791 defsubr (&Smake_char_table
);
4792 defsubr (&Smake_string
);
4793 defsubr (&Smake_bool_vector
);
4794 defsubr (&Smake_symbol
);
4795 defsubr (&Smake_marker
);
4796 defsubr (&Spurecopy
);
4797 defsubr (&Sgarbage_collect
);
4798 defsubr (&Smemory_limit
);
4799 defsubr (&Smemory_use_counts
);
4801 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4802 defsubr (&Sgc_status
);