1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
25 /* Note that this declares bzero on OSF/1. How dumb. */
29 /* This file is part of the core Lisp implementation, and thus must
30 deal with the real data structures. If the Lisp implementation is
31 replaced, this file likely will not be used. */
33 #undef HIDE_LISP_IMPLEMENTATION
35 #include "intervals.h"
41 #include "blockinput.h"
43 #include "syssignal.h"
49 extern POINTER_TYPE
*sbrk ();
52 #ifdef DOUG_LEA_MALLOC
55 #define __malloc_size_t int
57 /* Specify maximum number of areas to mmap. It would be nice to use a
58 value that explicitly means "no limit". */
60 #define MMAP_MAX_AREAS 100000000
62 #else /* not DOUG_LEA_MALLOC */
64 /* The following come from gmalloc.c. */
66 #if defined (STDC_HEADERS)
68 #define __malloc_size_t size_t
70 #define __malloc_size_t unsigned int
72 extern __malloc_size_t _bytes_used
;
73 extern int __malloc_extra_blocks
;
75 #endif /* not DOUG_LEA_MALLOC */
77 #define max(A,B) ((A) > (B) ? (A) : (B))
78 #define min(A,B) ((A) < (B) ? (A) : (B))
80 /* Macro to verify that storage intended for Lisp objects is not
81 out of range to fit in the space for a pointer.
82 ADDRESS is the start of the block, and SIZE
83 is the amount of space within which objects can start. */
85 #define VALIDATE_LISP_STORAGE(address, size) \
89 XSETCONS (val, (char *) address + size); \
90 if ((char *) XCONS (val) != (char *) address + size) \
97 /* Value of _bytes_used, when spare_memory was freed. */
99 static __malloc_size_t bytes_used_when_full
;
101 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
102 to a struct Lisp_String. */
104 #define MARK_STRING(S) ((S)->size |= MARKBIT)
105 #define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
106 #define STRING_MARKED_P(S) ((S)->size & MARKBIT)
108 /* Value is the number of bytes/chars of S, a pointer to a struct
109 Lisp_String. This must be used instead of STRING_BYTES (S) or
110 S->size during GC, because S->size contains the mark bit for
113 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
114 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
116 /* Number of bytes of consing done since the last gc. */
118 int consing_since_gc
;
120 /* Count the amount of consing of various sorts of space. */
122 int cons_cells_consed
;
124 int vector_cells_consed
;
126 int string_chars_consed
;
127 int misc_objects_consed
;
128 int intervals_consed
;
131 /* Number of bytes of consing since GC before another GC should be done. */
133 int gc_cons_threshold
;
135 /* Nonzero during GC. */
139 /* Nonzero means display messages at beginning and end of GC. */
141 int garbage_collection_messages
;
143 #ifndef VIRT_ADDR_VARIES
145 #endif /* VIRT_ADDR_VARIES */
146 int malloc_sbrk_used
;
148 #ifndef VIRT_ADDR_VARIES
150 #endif /* VIRT_ADDR_VARIES */
151 int malloc_sbrk_unused
;
153 /* Two limits controlling how much undo information to keep. */
156 int undo_strong_limit
;
158 /* Number of live and free conses etc. */
160 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
161 static int total_free_conses
, total_free_markers
, total_free_symbols
;
162 static int total_free_floats
, total_floats
;
164 /* Points to memory space allocated as "spare", to be freed if we run
167 static char *spare_memory
;
169 /* Amount of spare memory to keep in reserve. */
171 #define SPARE_MEMORY (1 << 14)
173 /* Number of extra blocks malloc should get when it needs more core. */
175 static int malloc_hysteresis
;
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 POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
290 static void lisp_free
P_ ((POINTER_TYPE
*));
291 static void mark_stack
P_ ((void));
292 static void init_stack
P_ ((Lisp_Object
*));
293 static int live_vector_p
P_ ((struct mem_node
*, void *));
294 static int live_buffer_p
P_ ((struct mem_node
*, void *));
295 static int live_string_p
P_ ((struct mem_node
*, void *));
296 static int live_cons_p
P_ ((struct mem_node
*, void *));
297 static int live_symbol_p
P_ ((struct mem_node
*, void *));
298 static int live_float_p
P_ ((struct mem_node
*, void *));
299 static int live_misc_p
P_ ((struct mem_node
*, void *));
300 static void mark_maybe_object
P_ ((Lisp_Object
));
301 static void mark_memory
P_ ((void *, void *));
302 static void mem_init
P_ ((void));
303 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
304 static void mem_insert_fixup
P_ ((struct mem_node
*));
305 static void mem_rotate_left
P_ ((struct mem_node
*));
306 static void mem_rotate_right
P_ ((struct mem_node
*));
307 static void mem_delete
P_ ((struct mem_node
*));
308 static void mem_delete_fixup
P_ ((struct mem_node
*));
309 static INLINE
struct mem_node
*mem_find
P_ ((void *));
311 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
312 static void check_gcpros
P_ ((void));
315 #endif /* GC_MARK_STACK != 0 */
318 /************************************************************************
320 ************************************************************************/
322 /* Write STR to Vstandard_output plus some advice on how to free some
323 memory. Called when memory gets low. */
326 malloc_warning_1 (str
)
329 Fprinc (str
, Vstandard_output
);
330 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
331 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
332 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
337 /* Function malloc calls this if it finds we are near exhausting
344 pending_malloc_warning
= str
;
348 /* Display a malloc warning in buffer *Danger*. */
351 display_malloc_warning ()
353 register Lisp_Object val
;
355 val
= build_string (pending_malloc_warning
);
356 pending_malloc_warning
= 0;
357 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
361 #ifdef DOUG_LEA_MALLOC
362 # define BYTES_USED (mallinfo ().arena)
364 # define BYTES_USED _bytes_used
368 /* Called if malloc returns zero. */
373 #ifndef SYSTEM_MALLOC
374 bytes_used_when_full
= BYTES_USED
;
377 /* The first time we get here, free the spare memory. */
384 /* This used to call error, but if we've run out of memory, we could
385 get infinite recursion trying to build the string. */
387 Fsignal (Qnil
, memory_signal_data
);
391 /* Called if we can't allocate relocatable space for a buffer. */
394 buffer_memory_full ()
396 /* If buffers use the relocating allocator, no need to free
397 spare_memory, because we may have plenty of malloc space left
398 that we could get, and if we don't, the malloc that fails will
399 itself cause spare_memory to be freed. If buffers don't use the
400 relocating allocator, treat this like any other failing
407 /* This used to call error, but if we've run out of memory, we could
408 get infinite recursion trying to build the string. */
410 Fsignal (Qerror
, memory_signal_data
);
414 /* Like malloc but check for no memory and block interrupt input.. */
420 register POINTER_TYPE
*val
;
423 val
= (POINTER_TYPE
*) malloc (size
);
432 /* Like realloc but check for no memory and block interrupt input.. */
435 xrealloc (block
, size
)
439 register POINTER_TYPE
*val
;
442 /* We must call malloc explicitly when BLOCK is 0, since some
443 reallocs don't do this. */
445 val
= (POINTER_TYPE
*) malloc (size
);
447 val
= (POINTER_TYPE
*) realloc (block
, size
);
450 if (!val
&& size
) memory_full ();
455 /* Like free but block interrupt input.. */
467 /* Like strdup, but uses xmalloc. */
473 size_t len
= strlen (s
) + 1;
474 char *p
= (char *) xmalloc (len
);
480 /* Like malloc but used for allocating Lisp data. NBYTES is the
481 number of bytes to allocate, TYPE describes the intended use of the
482 allcated memory block (for strings, for conses, ...). */
484 static POINTER_TYPE
*
485 lisp_malloc (nbytes
, type
)
492 val
= (void *) malloc (nbytes
);
495 if (val
&& type
!= MEM_TYPE_NON_LISP
)
496 mem_insert (val
, (char *) val
+ nbytes
, type
);
506 /* Return a new buffer structure allocated from the heap with
507 a call to lisp_malloc. */
512 return (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
517 /* Free BLOCK. This must be called to free memory allocated with a
518 call to lisp_malloc. */
527 mem_delete (mem_find (block
));
533 /* Arranging to disable input signals while we're in malloc.
535 This only works with GNU malloc. To help out systems which can't
536 use GNU malloc, all the calls to malloc, realloc, and free
537 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
538 pairs; unfortunately, we have no idea what C library functions
539 might call malloc, so we can't really protect them unless you're
540 using GNU malloc. Fortunately, most of the major operating can use
543 #ifndef SYSTEM_MALLOC
544 #ifndef DOUG_LEA_MALLOC
545 extern void * (*__malloc_hook
) P_ ((size_t));
546 extern void * (*__realloc_hook
) P_ ((void *, size_t));
547 extern void (*__free_hook
) P_ ((void *));
548 /* Else declared in malloc.h, perhaps with an extra arg. */
549 #endif /* DOUG_LEA_MALLOC */
550 static void * (*old_malloc_hook
) ();
551 static void * (*old_realloc_hook
) ();
552 static void (*old_free_hook
) ();
554 /* This function is used as the hook for free to call. */
557 emacs_blocked_free (ptr
)
561 __free_hook
= old_free_hook
;
563 /* If we released our reserve (due to running out of memory),
564 and we have a fair amount free once again,
565 try to set aside another reserve in case we run out once more. */
566 if (spare_memory
== 0
567 /* Verify there is enough space that even with the malloc
568 hysteresis this call won't run out again.
569 The code here is correct as long as SPARE_MEMORY
570 is substantially larger than the block size malloc uses. */
571 && (bytes_used_when_full
572 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
573 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
575 __free_hook
= emacs_blocked_free
;
580 /* If we released our reserve (due to running out of memory),
581 and we have a fair amount free once again,
582 try to set aside another reserve in case we run out once more.
584 This is called when a relocatable block is freed in ralloc.c. */
587 refill_memory_reserve ()
589 if (spare_memory
== 0)
590 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
594 /* This function is the malloc hook that Emacs uses. */
597 emacs_blocked_malloc (size
)
603 __malloc_hook
= old_malloc_hook
;
604 #ifdef DOUG_LEA_MALLOC
605 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
607 __malloc_extra_blocks
= malloc_hysteresis
;
609 value
= (void *) malloc (size
);
610 __malloc_hook
= emacs_blocked_malloc
;
617 /* This function is the realloc hook that Emacs uses. */
620 emacs_blocked_realloc (ptr
, size
)
627 __realloc_hook
= old_realloc_hook
;
628 value
= (void *) realloc (ptr
, size
);
629 __realloc_hook
= emacs_blocked_realloc
;
636 /* Called from main to set up malloc to use our hooks. */
639 uninterrupt_malloc ()
641 if (__free_hook
!= emacs_blocked_free
)
642 old_free_hook
= __free_hook
;
643 __free_hook
= emacs_blocked_free
;
645 if (__malloc_hook
!= emacs_blocked_malloc
)
646 old_malloc_hook
= __malloc_hook
;
647 __malloc_hook
= emacs_blocked_malloc
;
649 if (__realloc_hook
!= emacs_blocked_realloc
)
650 old_realloc_hook
= __realloc_hook
;
651 __realloc_hook
= emacs_blocked_realloc
;
654 #endif /* not SYSTEM_MALLOC */
658 /***********************************************************************
660 ***********************************************************************/
662 /* Number of intervals allocated in an interval_block structure.
663 The 1020 is 1024 minus malloc overhead. */
665 #define INTERVAL_BLOCK_SIZE \
666 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
668 /* Intervals are allocated in chunks in form of an interval_block
671 struct interval_block
673 struct interval_block
*next
;
674 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
677 /* Current interval block. Its `next' pointer points to older
680 struct interval_block
*interval_block
;
682 /* Index in interval_block above of the next unused interval
685 static int interval_block_index
;
687 /* Number of free and live intervals. */
689 static int total_free_intervals
, total_intervals
;
691 /* List of free intervals. */
693 INTERVAL interval_free_list
;
695 /* Total number of interval blocks now in use. */
697 int n_interval_blocks
;
700 /* Initialize interval allocation. */
706 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
708 interval_block
->next
= 0;
709 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
710 interval_block_index
= 0;
711 interval_free_list
= 0;
712 n_interval_blocks
= 1;
716 /* Return a new interval. */
723 if (interval_free_list
)
725 val
= interval_free_list
;
726 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
730 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
732 register struct interval_block
*newi
;
734 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
737 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
738 newi
->next
= interval_block
;
739 interval_block
= newi
;
740 interval_block_index
= 0;
743 val
= &interval_block
->intervals
[interval_block_index
++];
745 consing_since_gc
+= sizeof (struct interval
);
747 RESET_INTERVAL (val
);
752 /* Mark Lisp objects in interval I. */
755 mark_interval (i
, dummy
)
759 if (XMARKBIT (i
->plist
))
761 mark_object (&i
->plist
);
766 /* Mark the interval tree rooted in TREE. Don't call this directly;
767 use the macro MARK_INTERVAL_TREE instead. */
770 mark_interval_tree (tree
)
771 register INTERVAL tree
;
773 /* No need to test if this tree has been marked already; this
774 function is always called through the MARK_INTERVAL_TREE macro,
775 which takes care of that. */
777 /* XMARK expands to an assignment; the LHS of an assignment can't be
779 XMARK (tree
->up
.obj
);
781 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
785 /* Mark the interval tree rooted in I. */
787 #define MARK_INTERVAL_TREE(i) \
789 if (!NULL_INTERVAL_P (i) \
790 && ! XMARKBIT (i->up.obj)) \
791 mark_interval_tree (i); \
795 /* The oddity in the call to XUNMARK is necessary because XUNMARK
796 expands to an assignment to its argument, and most C compilers
797 don't support casts on the left operand of `='. */
799 #define UNMARK_BALANCE_INTERVALS(i) \
801 if (! NULL_INTERVAL_P (i)) \
803 XUNMARK ((i)->up.obj); \
804 (i) = balance_intervals (i); \
809 /* Number support. If NO_UNION_TYPE isn't in effect, we
810 can't create number objects in macros. */
818 obj
.s
.type
= Lisp_Int
;
823 /***********************************************************************
825 ***********************************************************************/
827 /* Lisp_Strings are allocated in string_block structures. When a new
828 string_block is allocated, all the Lisp_Strings it contains are
829 added to a free-list stiing_free_list. When a new Lisp_String is
830 needed, it is taken from that list. During the sweep phase of GC,
831 string_blocks that are entirely free are freed, except two which
834 String data is allocated from sblock structures. Strings larger
835 than LARGE_STRING_BYTES, get their own sblock, data for smaller
836 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
838 Sblocks consist internally of sdata structures, one for each
839 Lisp_String. The sdata structure points to the Lisp_String it
840 belongs to. The Lisp_String points back to the `u.data' member of
843 When a Lisp_String is freed during GC, it is put back on
844 string_free_list, and its `data' member and its sdata's `string'
845 pointer is set to null. The size of the string is recorded in the
846 `u.nbytes' member of the sdata. So, sdata structures that are no
847 longer used, can be easily recognized, and it's easy to compact the
848 sblocks of small strings which we do in compact_small_strings. */
850 /* Size in bytes of an sblock structure used for small strings. This
851 is 8192 minus malloc overhead. */
853 #define SBLOCK_SIZE 8188
855 /* Strings larger than this are considered large strings. String data
856 for large strings is allocated from individual sblocks. */
858 #define LARGE_STRING_BYTES 1024
860 /* Structure describing string memory sub-allocated from an sblock.
861 This is where the contents of Lisp strings are stored. */
865 /* Back-pointer to the string this sdata belongs to. If null, this
866 structure is free, and the NBYTES member of the union below
867 contains the string's byte size (the same value that STRING_BYTES
868 would return if STRING were non-null). If non-null, STRING_BYTES
869 (STRING) is the size of the data, and DATA contains the string's
871 struct Lisp_String
*string
;
875 /* When STRING in non-null. */
876 unsigned char data
[1];
878 /* When STRING is null. */
883 /* Structure describing a block of memory which is sub-allocated to
884 obtain string data memory for strings. Blocks for small strings
885 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
886 as large as needed. */
893 /* Pointer to the next free sdata block. This points past the end
894 of the sblock if there isn't any space left in this block. */
895 struct sdata
*next_free
;
898 struct sdata first_data
;
901 /* Number of Lisp strings in a string_block structure. The 1020 is
902 1024 minus malloc overhead. */
904 #define STRINGS_IN_STRING_BLOCK \
905 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
907 /* Structure describing a block from which Lisp_String structures
912 struct string_block
*next
;
913 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
916 /* Head and tail of the list of sblock structures holding Lisp string
917 data. We always allocate from current_sblock. The NEXT pointers
918 in the sblock structures go from oldest_sblock to current_sblock. */
920 static struct sblock
*oldest_sblock
, *current_sblock
;
922 /* List of sblocks for large strings. */
924 static struct sblock
*large_sblocks
;
926 /* List of string_block structures, and how many there are. */
928 static struct string_block
*string_blocks
;
929 static int n_string_blocks
;
931 /* Free-list of Lisp_Strings. */
933 static struct Lisp_String
*string_free_list
;
935 /* Number of live and free Lisp_Strings. */
937 static int total_strings
, total_free_strings
;
939 /* Number of bytes used by live strings. */
941 static int total_string_size
;
943 /* Given a pointer to a Lisp_String S which is on the free-list
944 string_free_list, return a pointer to its successor in the
947 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
949 /* Return a pointer to the sdata structure belonging to Lisp string S.
950 S must be live, i.e. S->data must not be null. S->data is actually
951 a pointer to the `u.data' member of its sdata structure; the
952 structure starts at a constant offset in front of that. */
954 #define SDATA_OF_STRING(S) \
955 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
957 /* Value is the size of an sdata structure large enough to hold NBYTES
958 bytes of string data. The value returned includes a terminating
959 NUL byte, the size of the sdata structure, and padding. */
961 #define SDATA_SIZE(NBYTES) \
962 ((sizeof (struct Lisp_String *) \
964 + sizeof (EMACS_INT) - 1) \
965 & ~(sizeof (EMACS_INT) - 1))
968 /* Initialize string allocation. Called from init_alloc_once. */
973 total_strings
= total_free_strings
= total_string_size
= 0;
974 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
975 string_blocks
= NULL
;
977 string_free_list
= NULL
;
981 /* Return a new Lisp_String. */
983 static struct Lisp_String
*
986 struct Lisp_String
*s
;
988 /* If the free-list is empty, allocate a new string_block, and
989 add all the Lisp_Strings in it to the free-list. */
990 if (string_free_list
== NULL
)
992 struct string_block
*b
;
995 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
996 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
997 bzero (b
, sizeof *b
);
998 b
->next
= string_blocks
;
1002 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
1005 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1006 string_free_list
= s
;
1009 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
1012 /* Pop a Lisp_String off the free-list. */
1013 s
= string_free_list
;
1014 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1016 /* Probably not strictly necessary, but play it safe. */
1017 bzero (s
, sizeof *s
);
1019 --total_free_strings
;
1022 consing_since_gc
+= sizeof *s
;
1028 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1029 plus a NUL byte at the end. Allocate an sdata structure for S, and
1030 set S->data to its `u.data' member. Store a NUL byte at the end of
1031 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1032 S->data if it was initially non-null. */
1035 allocate_string_data (s
, nchars
, nbytes
)
1036 struct Lisp_String
*s
;
1039 struct sdata
*data
, *old_data
;
1041 int needed
, old_nbytes
;
1043 /* Determine the number of bytes needed to store NBYTES bytes
1045 needed
= SDATA_SIZE (nbytes
);
1047 if (nbytes
> LARGE_STRING_BYTES
)
1049 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1051 #ifdef DOUG_LEA_MALLOC
1052 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1053 because mapped region contents are not preserved in
1055 mallopt (M_MMAP_MAX
, 0);
1058 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1060 #ifdef DOUG_LEA_MALLOC
1061 /* Back to a reasonable maximum of mmap'ed areas. */
1062 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1065 b
->next_free
= &b
->first_data
;
1066 b
->first_data
.string
= NULL
;
1067 b
->next
= large_sblocks
;
1070 else if (current_sblock
== NULL
1071 || (((char *) current_sblock
+ SBLOCK_SIZE
1072 - (char *) current_sblock
->next_free
)
1075 /* Not enough room in the current sblock. */
1076 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1077 b
->next_free
= &b
->first_data
;
1078 b
->first_data
.string
= NULL
;
1082 current_sblock
->next
= b
;
1090 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1091 old_nbytes
= GC_STRING_BYTES (s
);
1093 data
= b
->next_free
;
1095 s
->data
= data
->u
.data
;
1097 s
->size_byte
= nbytes
;
1098 s
->data
[nbytes
] = '\0';
1099 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1101 /* If S had already data assigned, mark that as free by setting its
1102 string back-pointer to null, and recording the size of the data
1106 old_data
->u
.nbytes
= old_nbytes
;
1107 old_data
->string
= NULL
;
1110 consing_since_gc
+= needed
;
1114 /* Sweep and compact strings. */
1119 struct string_block
*b
, *next
;
1120 struct string_block
*live_blocks
= NULL
;
1122 string_free_list
= NULL
;
1123 total_strings
= total_free_strings
= 0;
1124 total_string_size
= 0;
1126 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1127 for (b
= string_blocks
; b
; b
= next
)
1130 struct Lisp_String
*free_list_before
= string_free_list
;
1134 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1136 struct Lisp_String
*s
= b
->strings
+ i
;
1140 /* String was not on free-list before. */
1141 if (STRING_MARKED_P (s
))
1143 /* String is live; unmark it and its intervals. */
1146 if (!NULL_INTERVAL_P (s
->intervals
))
1147 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1150 total_string_size
+= STRING_BYTES (s
);
1154 /* String is dead. Put it on the free-list. */
1155 struct sdata
*data
= SDATA_OF_STRING (s
);
1157 /* Save the size of S in its sdata so that we know
1158 how large that is. Reset the sdata's string
1159 back-pointer so that we know it's free. */
1160 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1161 data
->string
= NULL
;
1163 /* Reset the strings's `data' member so that we
1167 /* Put the string on the free-list. */
1168 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1169 string_free_list
= s
;
1175 /* S was on the free-list before. Put it there again. */
1176 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1177 string_free_list
= s
;
1182 /* Free blocks that contain free Lisp_Strings only, except
1183 the first two of them. */
1184 if (nfree
== STRINGS_IN_STRING_BLOCK
1185 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1189 string_free_list
= free_list_before
;
1193 total_free_strings
+= nfree
;
1194 b
->next
= live_blocks
;
1199 string_blocks
= live_blocks
;
1200 free_large_strings ();
1201 compact_small_strings ();
1205 /* Free dead large strings. */
1208 free_large_strings ()
1210 struct sblock
*b
, *next
;
1211 struct sblock
*live_blocks
= NULL
;
1213 for (b
= large_sblocks
; b
; b
= next
)
1217 if (b
->first_data
.string
== NULL
)
1221 b
->next
= live_blocks
;
1226 large_sblocks
= live_blocks
;
1230 /* Compact data of small strings. Free sblocks that don't contain
1231 data of live strings after compaction. */
1234 compact_small_strings ()
1236 struct sblock
*b
, *tb
, *next
;
1237 struct sdata
*from
, *to
, *end
, *tb_end
;
1238 struct sdata
*to_end
, *from_end
;
1240 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1241 to, and TB_END is the end of TB. */
1243 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1244 to
= &tb
->first_data
;
1246 /* Step through the blocks from the oldest to the youngest. We
1247 expect that old blocks will stabilize over time, so that less
1248 copying will happen this way. */
1249 for (b
= oldest_sblock
; b
; b
= b
->next
)
1252 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1254 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1256 /* Compute the next FROM here because copying below may
1257 overwrite data we need to compute it. */
1261 nbytes
= GC_STRING_BYTES (from
->string
);
1263 nbytes
= from
->u
.nbytes
;
1265 nbytes
= SDATA_SIZE (nbytes
);
1266 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1268 /* FROM->string non-null means it's alive. Copy its data. */
1271 /* If TB is full, proceed with the next sblock. */
1272 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1273 if (to_end
> tb_end
)
1277 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1278 to
= &tb
->first_data
;
1279 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1282 /* Copy, and update the string's `data' pointer. */
1285 xassert (tb
!= b
|| to
<= from
);
1286 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1287 to
->string
->data
= to
->u
.data
;
1290 /* Advance past the sdata we copied to. */
1296 /* The rest of the sblocks following TB don't contain live data, so
1297 we can free them. */
1298 for (b
= tb
->next
; b
; b
= next
)
1306 current_sblock
= tb
;
1310 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1311 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1312 Both LENGTH and INIT must be numbers.")
1314 Lisp_Object length
, init
;
1316 register Lisp_Object val
;
1317 register unsigned char *p
, *end
;
1320 CHECK_NATNUM (length
, 0);
1321 CHECK_NUMBER (init
, 1);
1324 if (SINGLE_BYTE_CHAR_P (c
))
1326 nbytes
= XINT (length
);
1327 val
= make_uninit_string (nbytes
);
1328 p
= XSTRING (val
)->data
;
1329 end
= p
+ XSTRING (val
)->size
;
1335 unsigned char str
[4];
1336 int len
= CHAR_STRING (c
, str
);
1338 nbytes
= len
* XINT (length
);
1339 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1340 p
= XSTRING (val
)->data
;
1344 bcopy (str
, p
, len
);
1354 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1355 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1356 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1358 Lisp_Object length
, init
;
1360 register Lisp_Object val
;
1361 struct Lisp_Bool_Vector
*p
;
1363 int length_in_chars
, length_in_elts
, bits_per_value
;
1365 CHECK_NATNUM (length
, 0);
1367 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1369 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1370 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1372 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1373 slot `size' of the struct Lisp_Bool_Vector. */
1374 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1375 p
= XBOOL_VECTOR (val
);
1377 /* Get rid of any bits that would cause confusion. */
1379 XSETBOOL_VECTOR (val
, p
);
1380 p
->size
= XFASTINT (length
);
1382 real_init
= (NILP (init
) ? 0 : -1);
1383 for (i
= 0; i
< length_in_chars
; i
++)
1384 p
->data
[i
] = real_init
;
1386 /* Clear the extraneous bits in the last byte. */
1387 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1388 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1389 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1395 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1396 of characters from the contents. This string may be unibyte or
1397 multibyte, depending on the contents. */
1400 make_string (contents
, nbytes
)
1404 register Lisp_Object val
;
1405 int nchars
, multibyte_nbytes
;
1407 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1408 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1409 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1410 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1411 /* CONTENTS contains no multibyte sequences or contains an invalid
1412 multibyte sequence. We must make unibyte string. */
1413 SET_STRING_BYTES (XSTRING (val
), -1);
1418 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1421 make_unibyte_string (contents
, length
)
1425 register Lisp_Object val
;
1426 val
= make_uninit_string (length
);
1427 bcopy (contents
, XSTRING (val
)->data
, length
);
1428 SET_STRING_BYTES (XSTRING (val
), -1);
1433 /* Make a multibyte string from NCHARS characters occupying NBYTES
1434 bytes at CONTENTS. */
1437 make_multibyte_string (contents
, nchars
, nbytes
)
1441 register Lisp_Object val
;
1442 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1443 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1448 /* Make a string from NCHARS characters occupying NBYTES bytes at
1449 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1452 make_string_from_bytes (contents
, nchars
, nbytes
)
1456 register Lisp_Object val
;
1457 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1458 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1459 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1460 SET_STRING_BYTES (XSTRING (val
), -1);
1465 /* Make a string from NCHARS characters occupying NBYTES bytes at
1466 CONTENTS. The argument MULTIBYTE controls whether to label the
1467 string as multibyte. */
1470 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1475 register Lisp_Object val
;
1476 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1477 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1479 SET_STRING_BYTES (XSTRING (val
), -1);
1484 /* Make a string from the data at STR, treating it as multibyte if the
1491 return make_string (str
, strlen (str
));
1495 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1496 occupying LENGTH bytes. */
1499 make_uninit_string (length
)
1503 val
= make_uninit_multibyte_string (length
, length
);
1504 SET_STRING_BYTES (XSTRING (val
), -1);
1509 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1510 which occupy NBYTES bytes. */
1513 make_uninit_multibyte_string (nchars
, nbytes
)
1517 struct Lisp_String
*s
;
1522 s
= allocate_string ();
1523 allocate_string_data (s
, nchars
, nbytes
);
1524 XSETSTRING (string
, s
);
1525 string_chars_consed
+= nbytes
;
1531 /***********************************************************************
1533 ***********************************************************************/
1535 /* We store float cells inside of float_blocks, allocating a new
1536 float_block with malloc whenever necessary. Float cells reclaimed
1537 by GC are put on a free list to be reallocated before allocating
1538 any new float cells from the latest float_block.
1540 Each float_block is just under 1020 bytes long, since malloc really
1541 allocates in units of powers of two and uses 4 bytes for its own
1544 #define FLOAT_BLOCK_SIZE \
1545 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1549 struct float_block
*next
;
1550 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1553 /* Current float_block. */
1555 struct float_block
*float_block
;
1557 /* Index of first unused Lisp_Float in the current float_block. */
1559 int float_block_index
;
1561 /* Total number of float blocks now in use. */
1565 /* Free-list of Lisp_Floats. */
1567 struct Lisp_Float
*float_free_list
;
1570 /* Initialze float allocation. */
1575 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1577 float_block
->next
= 0;
1578 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1579 float_block_index
= 0;
1580 float_free_list
= 0;
1585 /* Explicitly free a float cell by putting it on the free-list. */
1589 struct Lisp_Float
*ptr
;
1591 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1595 float_free_list
= ptr
;
1599 /* Return a new float object with value FLOAT_VALUE. */
1602 make_float (float_value
)
1605 register Lisp_Object val
;
1607 if (float_free_list
)
1609 /* We use the data field for chaining the free list
1610 so that we won't use the same field that has the mark bit. */
1611 XSETFLOAT (val
, float_free_list
);
1612 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1616 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1618 register struct float_block
*new;
1620 new = (struct float_block
*) lisp_malloc (sizeof *new,
1622 VALIDATE_LISP_STORAGE (new, sizeof *new);
1623 new->next
= float_block
;
1625 float_block_index
= 0;
1628 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1631 XFLOAT_DATA (val
) = float_value
;
1632 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1633 consing_since_gc
+= sizeof (struct Lisp_Float
);
1640 /***********************************************************************
1642 ***********************************************************************/
1644 /* We store cons cells inside of cons_blocks, allocating a new
1645 cons_block with malloc whenever necessary. Cons cells reclaimed by
1646 GC are put on a free list to be reallocated before allocating
1647 any new cons cells from the latest cons_block.
1649 Each cons_block is just under 1020 bytes long,
1650 since malloc really allocates in units of powers of two
1651 and uses 4 bytes for its own overhead. */
1653 #define CONS_BLOCK_SIZE \
1654 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1658 struct cons_block
*next
;
1659 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1662 /* Current cons_block. */
1664 struct cons_block
*cons_block
;
1666 /* Index of first unused Lisp_Cons in the current block. */
1668 int cons_block_index
;
1670 /* Free-list of Lisp_Cons structures. */
1672 struct Lisp_Cons
*cons_free_list
;
1674 /* Total number of cons blocks now in use. */
1679 /* Initialize cons allocation. */
1684 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1686 cons_block
->next
= 0;
1687 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1688 cons_block_index
= 0;
1694 /* Explicitly free a cons cell by putting it on the free-list. */
1698 struct Lisp_Cons
*ptr
;
1700 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1704 cons_free_list
= ptr
;
1708 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
1709 "Create a new cons, give it CAR and CDR as components, and return it.")
1711 Lisp_Object car
, cdr
;
1713 register Lisp_Object val
;
1717 /* We use the cdr for chaining the free list
1718 so that we won't use the same field that has the mark bit. */
1719 XSETCONS (val
, cons_free_list
);
1720 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
1724 if (cons_block_index
== CONS_BLOCK_SIZE
)
1726 register struct cons_block
*new;
1727 new = (struct cons_block
*) lisp_malloc (sizeof *new,
1729 VALIDATE_LISP_STORAGE (new, sizeof *new);
1730 new->next
= cons_block
;
1732 cons_block_index
= 0;
1735 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
1740 consing_since_gc
+= sizeof (struct Lisp_Cons
);
1741 cons_cells_consed
++;
1746 /* Make a list of 2, 3, 4 or 5 specified objects. */
1750 Lisp_Object arg1
, arg2
;
1752 return Fcons (arg1
, Fcons (arg2
, Qnil
));
1757 list3 (arg1
, arg2
, arg3
)
1758 Lisp_Object arg1
, arg2
, arg3
;
1760 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
1765 list4 (arg1
, arg2
, arg3
, arg4
)
1766 Lisp_Object arg1
, arg2
, arg3
, arg4
;
1768 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
1773 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
1774 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
1776 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
1777 Fcons (arg5
, Qnil
)))));
1781 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
1782 "Return a newly created list with specified arguments as elements.\n\
1783 Any number of arguments, even zero arguments, are allowed.")
1786 register Lisp_Object
*args
;
1788 register Lisp_Object val
;
1794 val
= Fcons (args
[nargs
], val
);
1800 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
1801 "Return a newly created list of length LENGTH, with each element being INIT.")
1803 register Lisp_Object length
, init
;
1805 register Lisp_Object val
;
1808 CHECK_NATNUM (length
, 0);
1809 size
= XFASTINT (length
);
1813 val
= Fcons (init
, val
);
1819 /***********************************************************************
1821 ***********************************************************************/
1823 /* Singly-linked list of all vectors. */
1825 struct Lisp_Vector
*all_vectors
;
1827 /* Total number of vector-like objects now in use. */
1832 /* Value is a pointer to a newly allocated Lisp_Vector structure
1833 with room for LEN Lisp_Objects. */
1835 struct Lisp_Vector
*
1836 allocate_vectorlike (len
)
1839 struct Lisp_Vector
*p
;
1842 #ifdef DOUG_LEA_MALLOC
1843 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1844 because mapped region contents are not preserved in
1846 mallopt (M_MMAP_MAX
, 0);
1849 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
1850 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
1852 #ifdef DOUG_LEA_MALLOC
1853 /* Back to a reasonable maximum of mmap'ed areas. */
1854 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1857 VALIDATE_LISP_STORAGE (p
, 0);
1858 consing_since_gc
+= nbytes
;
1859 vector_cells_consed
+= len
;
1861 p
->next
= all_vectors
;
1868 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
1869 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1870 See also the function `vector'.")
1872 register Lisp_Object length
, init
;
1875 register EMACS_INT sizei
;
1877 register struct Lisp_Vector
*p
;
1879 CHECK_NATNUM (length
, 0);
1880 sizei
= XFASTINT (length
);
1882 p
= allocate_vectorlike (sizei
);
1884 for (index
= 0; index
< sizei
; index
++)
1885 p
->contents
[index
] = init
;
1887 XSETVECTOR (vector
, p
);
1892 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
1893 "Return a newly created char-table, with purpose PURPOSE.\n\
1894 Each element is initialized to INIT, which defaults to nil.\n\
1895 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
1896 The property's value should be an integer between 0 and 10.")
1898 register Lisp_Object purpose
, init
;
1902 CHECK_SYMBOL (purpose
, 1);
1903 n
= Fget (purpose
, Qchar_table_extra_slots
);
1904 CHECK_NUMBER (n
, 0);
1905 if (XINT (n
) < 0 || XINT (n
) > 10)
1906 args_out_of_range (n
, Qnil
);
1907 /* Add 2 to the size for the defalt and parent slots. */
1908 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
1910 XCHAR_TABLE (vector
)->top
= Qt
;
1911 XCHAR_TABLE (vector
)->parent
= Qnil
;
1912 XCHAR_TABLE (vector
)->purpose
= purpose
;
1913 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1918 /* Return a newly created sub char table with default value DEFALT.
1919 Since a sub char table does not appear as a top level Emacs Lisp
1920 object, we don't need a Lisp interface to make it. */
1923 make_sub_char_table (defalt
)
1927 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
1928 XCHAR_TABLE (vector
)->top
= Qnil
;
1929 XCHAR_TABLE (vector
)->defalt
= defalt
;
1930 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
1935 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
1936 "Return a newly created vector with specified arguments as elements.\n\
1937 Any number of arguments, even zero arguments, are allowed.")
1942 register Lisp_Object len
, val
;
1944 register struct Lisp_Vector
*p
;
1946 XSETFASTINT (len
, nargs
);
1947 val
= Fmake_vector (len
, Qnil
);
1949 for (index
= 0; index
< nargs
; index
++)
1950 p
->contents
[index
] = args
[index
];
1955 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
1956 "Create a byte-code object with specified arguments as elements.\n\
1957 The arguments should be the arglist, bytecode-string, constant vector,\n\
1958 stack size, (optional) doc string, and (optional) interactive spec.\n\
1959 The first four arguments are required; at most six have any\n\
1965 register Lisp_Object len
, val
;
1967 register struct Lisp_Vector
*p
;
1969 XSETFASTINT (len
, nargs
);
1970 if (!NILP (Vpurify_flag
))
1971 val
= make_pure_vector ((EMACS_INT
) nargs
);
1973 val
= Fmake_vector (len
, Qnil
);
1975 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
1976 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
1977 earlier because they produced a raw 8-bit string for byte-code
1978 and now such a byte-code string is loaded as multibyte while
1979 raw 8-bit characters converted to multibyte form. Thus, now we
1980 must convert them back to the original unibyte form. */
1981 args
[1] = Fstring_as_unibyte (args
[1]);
1984 for (index
= 0; index
< nargs
; index
++)
1986 if (!NILP (Vpurify_flag
))
1987 args
[index
] = Fpurecopy (args
[index
]);
1988 p
->contents
[index
] = args
[index
];
1990 XSETCOMPILED (val
, p
);
1996 /***********************************************************************
1998 ***********************************************************************/
2000 /* Each symbol_block is just under 1020 bytes long, since malloc
2001 really allocates in units of powers of two and uses 4 bytes for its
2004 #define SYMBOL_BLOCK_SIZE \
2005 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2009 struct symbol_block
*next
;
2010 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2013 /* Current symbol block and index of first unused Lisp_Symbol
2016 struct symbol_block
*symbol_block
;
2017 int symbol_block_index
;
2019 /* List of free symbols. */
2021 struct Lisp_Symbol
*symbol_free_list
;
2023 /* Total number of symbol blocks now in use. */
2025 int n_symbol_blocks
;
2028 /* Initialize symbol allocation. */
2033 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
2035 symbol_block
->next
= 0;
2036 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
2037 symbol_block_index
= 0;
2038 symbol_free_list
= 0;
2039 n_symbol_blocks
= 1;
2043 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2044 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2045 Its value and function definition are void, and its property list is nil.")
2049 register Lisp_Object val
;
2050 register struct Lisp_Symbol
*p
;
2052 CHECK_STRING (name
, 0);
2054 if (symbol_free_list
)
2056 XSETSYMBOL (val
, symbol_free_list
);
2057 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2061 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2063 struct symbol_block
*new;
2064 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2066 VALIDATE_LISP_STORAGE (new, sizeof *new);
2067 new->next
= symbol_block
;
2069 symbol_block_index
= 0;
2072 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2076 p
->name
= XSTRING (name
);
2079 p
->value
= Qunbound
;
2080 p
->function
= Qunbound
;
2082 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2089 /***********************************************************************
2090 Marker (Misc) Allocation
2091 ***********************************************************************/
2093 /* Allocation of markers and other objects that share that structure.
2094 Works like allocation of conses. */
2096 #define MARKER_BLOCK_SIZE \
2097 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2101 struct marker_block
*next
;
2102 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2105 struct marker_block
*marker_block
;
2106 int marker_block_index
;
2108 union Lisp_Misc
*marker_free_list
;
2110 /* Total number of marker blocks now in use. */
2112 int n_marker_blocks
;
2117 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2119 marker_block
->next
= 0;
2120 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2121 marker_block_index
= 0;
2122 marker_free_list
= 0;
2123 n_marker_blocks
= 1;
2126 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2133 if (marker_free_list
)
2135 XSETMISC (val
, marker_free_list
);
2136 marker_free_list
= marker_free_list
->u_free
.chain
;
2140 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2142 struct marker_block
*new;
2143 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2145 VALIDATE_LISP_STORAGE (new, sizeof *new);
2146 new->next
= marker_block
;
2148 marker_block_index
= 0;
2151 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2154 consing_since_gc
+= sizeof (union Lisp_Misc
);
2155 misc_objects_consed
++;
2159 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2160 "Return a newly allocated marker which does not point at any place.")
2163 register Lisp_Object val
;
2164 register struct Lisp_Marker
*p
;
2166 val
= allocate_misc ();
2167 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2173 p
->insertion_type
= 0;
2177 /* Put MARKER back on the free list after using it temporarily. */
2180 free_marker (marker
)
2183 unchain_marker (marker
);
2185 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2186 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2187 marker_free_list
= XMISC (marker
);
2189 total_free_markers
++;
2193 /* Return a newly created vector or string with specified arguments as
2194 elements. If all the arguments are characters that can fit
2195 in a string of events, make a string; otherwise, make a vector.
2197 Any number of arguments, even zero arguments, are allowed. */
2200 make_event_array (nargs
, args
)
2206 for (i
= 0; i
< nargs
; i
++)
2207 /* The things that fit in a string
2208 are characters that are in 0...127,
2209 after discarding the meta bit and all the bits above it. */
2210 if (!INTEGERP (args
[i
])
2211 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2212 return Fvector (nargs
, args
);
2214 /* Since the loop exited, we know that all the things in it are
2215 characters, so we can make a string. */
2219 result
= Fmake_string (make_number (nargs
), make_number (0));
2220 for (i
= 0; i
< nargs
; i
++)
2222 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2223 /* Move the meta bit to the right place for a string char. */
2224 if (XINT (args
[i
]) & CHAR_META
)
2225 XSTRING (result
)->data
[i
] |= 0x80;
2234 /************************************************************************
2236 ************************************************************************/
2241 /* Base address of stack. Set in main. */
2243 Lisp_Object
*stack_base
;
2245 /* A node in the red-black tree describing allocated memory containing
2246 Lisp data. Each such block is recorded with its start and end
2247 address when it is allocated, and removed from the tree when it
2250 A red-black tree is a balanced binary tree with the following
2253 1. Every node is either red or black.
2254 2. Every leaf is black.
2255 3. If a node is red, then both of its children are black.
2256 4. Every simple path from a node to a descendant leaf contains
2257 the same number of black nodes.
2258 5. The root is always black.
2260 When nodes are inserted into the tree, or deleted from the tree,
2261 the tree is "fixed" so that these properties are always true.
2263 A red-black tree with N internal nodes has height at most 2
2264 log(N+1). Searches, insertions and deletions are done in O(log N).
2265 Please see a text book about data structures for a detailed
2266 description of red-black trees. Any book worth its salt should
2271 struct mem_node
*left
, *right
, *parent
;
2273 /* Start and end of allocated region. */
2277 enum {MEM_BLACK
, MEM_RED
} color
;
2283 /* Root of the tree describing allocated Lisp memory. */
2285 static struct mem_node
*mem_root
;
2287 /* Sentinel node of the tree. */
2289 static struct mem_node mem_z
;
2290 #define MEM_NIL &mem_z
2293 /* Initialize this part of alloc.c. */
2298 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2299 mem_z
.parent
= NULL
;
2300 mem_z
.color
= MEM_BLACK
;
2301 mem_z
.start
= mem_z
.end
= NULL
;
2306 /* Value is a pointer to the mem_node containing START. Value is
2307 MEM_NIL if there is no node in the tree containing START. */
2309 static INLINE
struct mem_node
*
2315 /* Make the search always successful to speed up the loop below. */
2316 mem_z
.start
= start
;
2317 mem_z
.end
= (char *) start
+ 1;
2320 while (start
< p
->start
|| start
>= p
->end
)
2321 p
= start
< p
->start
? p
->left
: p
->right
;
2326 /* Insert a new node into the tree for a block of memory with start
2327 address START, end address END, and type TYPE. Value is a
2328 pointer to the node that was inserted. */
2330 static struct mem_node
*
2331 mem_insert (start
, end
, type
)
2335 struct mem_node
*c
, *parent
, *x
;
2337 /* See where in the tree a node for START belongs. In this
2338 particular application, it shouldn't happen that a node is already
2339 present. For debugging purposes, let's check that. */
2343 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2345 while (c
!= MEM_NIL
)
2347 if (start
>= c
->start
&& start
< c
->end
)
2350 c
= start
< c
->start
? c
->left
: c
->right
;
2353 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2355 while (c
!= MEM_NIL
)
2358 c
= start
< c
->start
? c
->left
: c
->right
;
2361 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2363 /* Create a new node. */
2364 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2369 x
->left
= x
->right
= MEM_NIL
;
2372 /* Insert it as child of PARENT or install it as root. */
2375 if (start
< parent
->start
)
2383 /* Re-establish red-black tree properties. */
2384 mem_insert_fixup (x
);
2389 /* Re-establish the red-black properties of the tree, and thereby
2390 balance the tree, after node X has been inserted; X is always red. */
2393 mem_insert_fixup (x
)
2396 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2398 /* X is red and its parent is red. This is a violation of
2399 red-black tree property #3. */
2401 if (x
->parent
== x
->parent
->parent
->left
)
2403 /* We're on the left side of our grandparent, and Y is our
2405 struct mem_node
*y
= x
->parent
->parent
->right
;
2407 if (y
->color
== MEM_RED
)
2409 /* Uncle and parent are red but should be black because
2410 X is red. Change the colors accordingly and proceed
2411 with the grandparent. */
2412 x
->parent
->color
= MEM_BLACK
;
2413 y
->color
= MEM_BLACK
;
2414 x
->parent
->parent
->color
= MEM_RED
;
2415 x
= x
->parent
->parent
;
2419 /* Parent and uncle have different colors; parent is
2420 red, uncle is black. */
2421 if (x
== x
->parent
->right
)
2424 mem_rotate_left (x
);
2427 x
->parent
->color
= MEM_BLACK
;
2428 x
->parent
->parent
->color
= MEM_RED
;
2429 mem_rotate_right (x
->parent
->parent
);
2434 /* This is the symmetrical case of above. */
2435 struct mem_node
*y
= x
->parent
->parent
->left
;
2437 if (y
->color
== MEM_RED
)
2439 x
->parent
->color
= MEM_BLACK
;
2440 y
->color
= MEM_BLACK
;
2441 x
->parent
->parent
->color
= MEM_RED
;
2442 x
= x
->parent
->parent
;
2446 if (x
== x
->parent
->left
)
2449 mem_rotate_right (x
);
2452 x
->parent
->color
= MEM_BLACK
;
2453 x
->parent
->parent
->color
= MEM_RED
;
2454 mem_rotate_left (x
->parent
->parent
);
2459 /* The root may have been changed to red due to the algorithm. Set
2460 it to black so that property #5 is satisfied. */
2461 mem_root
->color
= MEM_BLACK
;
2477 /* Turn y's left sub-tree into x's right sub-tree. */
2480 if (y
->left
!= MEM_NIL
)
2481 y
->left
->parent
= x
;
2483 /* Y's parent was x's parent. */
2485 y
->parent
= x
->parent
;
2487 /* Get the parent to point to y instead of x. */
2490 if (x
== x
->parent
->left
)
2491 x
->parent
->left
= y
;
2493 x
->parent
->right
= y
;
2498 /* Put x on y's left. */
2512 mem_rotate_right (x
)
2515 struct mem_node
*y
= x
->left
;
2518 if (y
->right
!= MEM_NIL
)
2519 y
->right
->parent
= x
;
2522 y
->parent
= x
->parent
;
2525 if (x
== x
->parent
->right
)
2526 x
->parent
->right
= y
;
2528 x
->parent
->left
= y
;
2539 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2545 struct mem_node
*x
, *y
;
2547 if (!z
|| z
== MEM_NIL
)
2550 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2555 while (y
->left
!= MEM_NIL
)
2559 if (y
->left
!= MEM_NIL
)
2564 x
->parent
= y
->parent
;
2567 if (y
== y
->parent
->left
)
2568 y
->parent
->left
= x
;
2570 y
->parent
->right
= x
;
2577 z
->start
= y
->start
;
2582 if (y
->color
== MEM_BLACK
)
2583 mem_delete_fixup (x
);
2588 /* Re-establish the red-black properties of the tree, after a
2592 mem_delete_fixup (x
)
2595 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2597 if (x
== x
->parent
->left
)
2599 struct mem_node
*w
= x
->parent
->right
;
2601 if (w
->color
== MEM_RED
)
2603 w
->color
= MEM_BLACK
;
2604 x
->parent
->color
= MEM_RED
;
2605 mem_rotate_left (x
->parent
);
2606 w
= x
->parent
->right
;
2609 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2616 if (w
->right
->color
== MEM_BLACK
)
2618 w
->left
->color
= MEM_BLACK
;
2620 mem_rotate_right (w
);
2621 w
= x
->parent
->right
;
2623 w
->color
= x
->parent
->color
;
2624 x
->parent
->color
= MEM_BLACK
;
2625 w
->right
->color
= MEM_BLACK
;
2626 mem_rotate_left (x
->parent
);
2632 struct mem_node
*w
= x
->parent
->left
;
2634 if (w
->color
== MEM_RED
)
2636 w
->color
= MEM_BLACK
;
2637 x
->parent
->color
= MEM_RED
;
2638 mem_rotate_right (x
->parent
);
2639 w
= x
->parent
->left
;
2642 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2649 if (w
->left
->color
== MEM_BLACK
)
2651 w
->right
->color
= MEM_BLACK
;
2653 mem_rotate_left (w
);
2654 w
= x
->parent
->left
;
2657 w
->color
= x
->parent
->color
;
2658 x
->parent
->color
= MEM_BLACK
;
2659 w
->left
->color
= MEM_BLACK
;
2660 mem_rotate_right (x
->parent
);
2666 x
->color
= MEM_BLACK
;
2670 /* Value is non-zero if P is a pointer to a live Lisp string on
2671 the heap. M is a pointer to the mem_block for P. */
2674 live_string_p (m
, p
)
2678 if (m
->type
== MEM_TYPE_STRING
)
2680 struct string_block
*b
= (struct string_block
*) m
->start
;
2681 int offset
= (char *) p
- (char *) &b
->strings
[0];
2683 /* P must point to the start of a Lisp_String structure, and it
2684 must not be on the free-list. */
2685 return (offset
% sizeof b
->strings
[0] == 0
2686 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2693 /* Value is non-zero if P is a pointer to a live Lisp cons on
2694 the heap. M is a pointer to the mem_block for P. */
2701 if (m
->type
== MEM_TYPE_CONS
)
2703 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2704 int offset
= (char *) p
- (char *) &b
->conses
[0];
2706 /* P must point to the start of a Lisp_Cons, not be
2707 one of the unused cells in the current cons block,
2708 and not be on the free-list. */
2709 return (offset
% sizeof b
->conses
[0] == 0
2711 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2712 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2719 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2720 the heap. M is a pointer to the mem_block for P. */
2723 live_symbol_p (m
, p
)
2727 if (m
->type
== MEM_TYPE_SYMBOL
)
2729 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2730 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2732 /* P must point to the start of a Lisp_Symbol, not be
2733 one of the unused cells in the current symbol block,
2734 and not be on the free-list. */
2735 return (offset
% sizeof b
->symbols
[0] == 0
2736 && (b
!= symbol_block
2737 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2738 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2745 /* Value is non-zero if P is a pointer to a live Lisp float on
2746 the heap. M is a pointer to the mem_block for P. */
2753 if (m
->type
== MEM_TYPE_FLOAT
)
2755 struct float_block
*b
= (struct float_block
*) m
->start
;
2756 int offset
= (char *) p
- (char *) &b
->floats
[0];
2758 /* P must point to the start of a Lisp_Float, not be
2759 one of the unused cells in the current float block,
2760 and not be on the free-list. */
2761 return (offset
% sizeof b
->floats
[0] == 0
2762 && (b
!= float_block
2763 || offset
/ sizeof b
->floats
[0] < float_block_index
)
2764 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
2771 /* Value is non-zero if P is a pointer to a live Lisp Misc on
2772 the heap. M is a pointer to the mem_block for P. */
2779 if (m
->type
== MEM_TYPE_MISC
)
2781 struct marker_block
*b
= (struct marker_block
*) m
->start
;
2782 int offset
= (char *) p
- (char *) &b
->markers
[0];
2784 /* P must point to the start of a Lisp_Misc, not be
2785 one of the unused cells in the current misc block,
2786 and not be on the free-list. */
2787 return (offset
% sizeof b
->markers
[0] == 0
2788 && (b
!= marker_block
2789 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
2790 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
2797 /* Value is non-zero if P is a pointer to a live vector-like object.
2798 M is a pointer to the mem_block for P. */
2801 live_vector_p (m
, p
)
2805 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
2809 /* Value is non-zero of P is a pointer to a live buffer. M is a
2810 pointer to the mem_block for P. */
2813 live_buffer_p (m
, p
)
2817 /* P must point to the start of the block, and the buffer
2818 must not have been killed. */
2819 return (m
->type
== MEM_TYPE_BUFFER
2821 && !NILP (((struct buffer
*) p
)->name
));
2825 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2827 /* Array of objects that are kept alive because the C stack contains
2828 a pattern that looks like a reference to them . */
2830 #define MAX_ZOMBIES 10
2831 static Lisp_Object zombies
[MAX_ZOMBIES
];
2833 /* Number of zombie objects. */
2835 static int nzombies
;
2837 /* Number of garbage collections. */
2841 /* Average percentage of zombies per collection. */
2843 static double avg_zombies
;
2845 /* Max. number of live and zombie objects. */
2847 static int max_live
, max_zombies
;
2849 /* Average number of live objects per GC. */
2851 static double avg_live
;
2853 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
2854 "Show information about live and zombie objects.")
2857 Lisp_Object args
[7];
2858 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2859 args
[1] = make_number (ngcs
);
2860 args
[2] = make_float (avg_live
);
2861 args
[3] = make_float (avg_zombies
);
2862 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
2863 args
[5] = make_number (max_live
);
2864 args
[6] = make_number (max_zombies
);
2865 return Fmessage (7, args
);
2868 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2871 /* Mark OBJ if we can prove it's a Lisp_Object. */
2874 mark_maybe_object (obj
)
2877 void *po
= (void *) XPNTR (obj
);
2878 struct mem_node
*m
= mem_find (po
);
2884 switch (XGCTYPE (obj
))
2887 mark_p
= (live_string_p (m
, po
)
2888 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
2892 mark_p
= (live_cons_p (m
, po
)
2893 && !XMARKBIT (XCONS (obj
)->car
));
2897 mark_p
= (live_symbol_p (m
, po
)
2898 && !XMARKBIT (XSYMBOL (obj
)->plist
));
2902 mark_p
= (live_float_p (m
, po
)
2903 && !XMARKBIT (XFLOAT (obj
)->type
));
2906 case Lisp_Vectorlike
:
2907 /* Note: can't check GC_BUFFERP before we know it's a
2908 buffer because checking that dereferences the pointer
2909 PO which might point anywhere. */
2910 if (live_vector_p (m
, po
))
2911 mark_p
= (!GC_SUBRP (obj
)
2912 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
2913 else if (live_buffer_p (m
, po
))
2914 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
2918 if (live_misc_p (m
, po
))
2920 switch (XMISCTYPE (obj
))
2922 case Lisp_Misc_Marker
:
2923 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
2926 case Lisp_Misc_Buffer_Local_Value
:
2927 case Lisp_Misc_Some_Buffer_Local_Value
:
2928 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2931 case Lisp_Misc_Overlay
:
2932 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
2944 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2945 if (nzombies
< MAX_ZOMBIES
)
2946 zombies
[nzombies
] = *p
;
2954 /* Mark Lisp objects in the address range START..END. */
2957 mark_memory (start
, end
)
2962 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2966 /* Make START the pointer to the start of the memory region,
2967 if it isn't already. */
2975 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
2976 mark_maybe_object (*p
);
2980 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2982 static int setjmp_tested_p
, longjmps_done
;
2984 #define SETJMP_WILL_LIKELY_WORK "\
2986 Emacs garbage collector has been changed to use conservative stack\n\
2987 marking. Emacs has determined that the method it uses to do the\n\
2988 marking will likely work on your system, but this isn't sure.\n\
2990 If you are a system-programmer, or can get the help of a local wizard\n\
2991 who is, please take a look at the function mark_stack in alloc.c, and\n\
2992 verify that the methods used are appropriate for your system.\n\
2994 Please mail the result to <gerd@gnu.org>.\n\
2997 #define SETJMP_WILL_NOT_WORK "\
2999 Emacs garbage collector has been changed to use conservative stack\n\
3000 marking. Emacs has determined that the default method it uses to do the\n\
3001 marking will not work on your system. We will need a system-dependent\n\
3002 solution for your system.\n\
3004 Please take a look at the function mark_stack in alloc.c, and\n\
3005 try to find a way to make it work on your system.\n\
3006 Please mail the result to <gerd@gnu.org>.\n\
3010 /* Perform a quick check if it looks like setjmp saves registers in a
3011 jmp_buf. Print a message to stderr saying so. When this test
3012 succeeds, this is _not_ a proof that setjmp is sufficient for
3013 conservative stack marking. Only the sources or a disassembly
3024 /* Arrange for X to be put in a register. */
3030 if (longjmps_done
== 1)
3032 /* Came here after the longjmp at the end of the function.
3034 If x == 1, the longjmp has restored the register to its
3035 value before the setjmp, and we can hope that setjmp
3036 saves all such registers in the jmp_buf, although that
3039 For other values of X, either something really strange is
3040 taking place, or the setjmp just didn't save the register. */
3043 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3046 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3053 if (longjmps_done
== 1)
3057 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3060 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3062 /* Abort if anything GCPRO'd doesn't survive the GC. */
3070 for (p
= gcprolist
; p
; p
= p
->next
)
3071 for (i
= 0; i
< p
->nvars
; ++i
)
3072 if (!survives_gc_p (p
->var
[i
]))
3076 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3083 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3084 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3086 fprintf (stderr
, " %d = ", i
);
3087 debug_print (zombies
[i
]);
3091 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3094 /* Mark live Lisp objects on the C stack.
3096 There are several system-dependent problems to consider when
3097 porting this to new architectures:
3101 We have to mark Lisp objects in CPU registers that can hold local
3102 variables or are used to pass parameters.
3104 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3105 something that either saves relevant registers on the stack, or
3106 calls mark_maybe_object passing it each register's contents.
3108 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3109 implementation assumes that calling setjmp saves registers we need
3110 to see in a jmp_buf which itself lies on the stack. This doesn't
3111 have to be true! It must be verified for each system, possibly
3112 by taking a look at the source code of setjmp.
3116 Architectures differ in the way their processor stack is organized.
3117 For example, the stack might look like this
3120 | Lisp_Object | size = 4
3122 | something else | size = 2
3124 | Lisp_Object | size = 4
3128 In such a case, not every Lisp_Object will be aligned equally. To
3129 find all Lisp_Object on the stack it won't be sufficient to walk
3130 the stack in steps of 4 bytes. Instead, two passes will be
3131 necessary, one starting at the start of the stack, and a second
3132 pass starting at the start of the stack + 2. Likewise, if the
3133 minimal alignment of Lisp_Objects on the stack is 1, four passes
3134 would be necessary, each one starting with one byte more offset
3135 from the stack start.
3137 The current code assumes by default that Lisp_Objects are aligned
3138 equally on the stack. */
3144 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3147 /* This trick flushes the register windows so that all the state of
3148 the process is contained in the stack. */
3153 /* Save registers that we need to see on the stack. We need to see
3154 registers used to hold register variables and registers used to
3156 #ifdef GC_SAVE_REGISTERS_ON_STACK
3157 GC_SAVE_REGISTERS_ON_STACK (end
);
3158 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3160 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3161 setjmp will definitely work, test it
3162 and print a message with the result
3164 if (!setjmp_tested_p
)
3166 setjmp_tested_p
= 1;
3169 #endif /* GC_SETJMP_WORKS */
3172 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3173 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3175 /* This assumes that the stack is a contiguous region in memory. If
3176 that's not the case, something has to be done here to iterate
3177 over the stack segments. */
3178 #if GC_LISP_OBJECT_ALIGNMENT == 1
3179 mark_memory (stack_base
, end
);
3180 mark_memory ((char *) stack_base
+ 1, end
);
3181 mark_memory ((char *) stack_base
+ 2, end
);
3182 mark_memory ((char *) stack_base
+ 3, end
);
3183 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3184 mark_memory (stack_base
, end
);
3185 mark_memory ((char *) stack_base
+ 2, end
);
3187 mark_memory (stack_base
, end
);
3190 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3196 #endif /* GC_MARK_STACK != 0 */
3200 /***********************************************************************
3201 Pure Storage Management
3202 ***********************************************************************/
3204 /* Return a string allocated in pure space. DATA is a buffer holding
3205 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3206 non-zero means make the result string multibyte.
3208 Must get an error if pure storage is full, since if it cannot hold
3209 a large string it may be able to hold conses that point to that
3210 string; then the string is not protected from gc. */
3213 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3219 struct Lisp_String
*s
;
3220 int string_size
, data_size
;
3222 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3224 string_size
= PAD (sizeof (struct Lisp_String
));
3225 data_size
= PAD (nbytes
+ 1);
3229 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3230 error ("Pure Lisp storage exhausted");
3232 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3233 pureptr
+= string_size
;
3234 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3235 pureptr
+= data_size
;
3238 s
->size_byte
= multibyte
? nbytes
: -1;
3239 bcopy (data
, s
->data
, nbytes
);
3240 s
->data
[nbytes
] = '\0';
3241 s
->intervals
= NULL_INTERVAL
;
3243 XSETSTRING (string
, s
);
3248 /* Return a cons allocated from pure space. Give it pure copies
3249 of CAR as car and CDR as cdr. */
3252 pure_cons (car
, cdr
)
3253 Lisp_Object car
, cdr
;
3255 register Lisp_Object
new;
3257 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3258 error ("Pure Lisp storage exhausted");
3259 XSETCONS (new, PUREBEG
+ pureptr
);
3260 pureptr
+= sizeof (struct Lisp_Cons
);
3261 XCAR (new) = Fpurecopy (car
);
3262 XCDR (new) = Fpurecopy (cdr
);
3267 /* Value is a float object with value NUM allocated from pure space. */
3270 make_pure_float (num
)
3273 register Lisp_Object
new;
3275 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3276 (double) boundary. Some architectures (like the sparc) require
3277 this, and I suspect that floats are rare enough that it's no
3278 tragedy for those that do. */
3281 char *p
= PUREBEG
+ pureptr
;
3285 alignment
= __alignof (struct Lisp_Float
);
3287 alignment
= sizeof (struct Lisp_Float
);
3290 alignment
= sizeof (struct Lisp_Float
);
3292 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3293 pureptr
= p
- PUREBEG
;
3296 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3297 error ("Pure Lisp storage exhausted");
3298 XSETFLOAT (new, PUREBEG
+ pureptr
);
3299 pureptr
+= sizeof (struct Lisp_Float
);
3300 XFLOAT_DATA (new) = num
;
3301 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3306 /* Return a vector with room for LEN Lisp_Objects allocated from
3310 make_pure_vector (len
)
3313 register Lisp_Object
new;
3314 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3315 + (len
- 1) * sizeof (Lisp_Object
));
3317 if (pureptr
+ size
> PURESIZE
)
3318 error ("Pure Lisp storage exhausted");
3320 XSETVECTOR (new, PUREBEG
+ pureptr
);
3322 XVECTOR (new)->size
= len
;
3327 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3328 "Make a copy of OBJECT in pure storage.\n\
3329 Recursively copies contents of vectors and cons cells.\n\
3330 Does not copy symbols. Copies strings without text properties.")
3332 register Lisp_Object obj
;
3334 if (NILP (Vpurify_flag
))
3337 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3338 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3342 return pure_cons (XCAR (obj
), XCDR (obj
));
3343 else if (FLOATP (obj
))
3344 return make_pure_float (XFLOAT_DATA (obj
));
3345 else if (STRINGP (obj
))
3346 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3347 STRING_BYTES (XSTRING (obj
)),
3348 STRING_MULTIBYTE (obj
));
3349 else if (COMPILEDP (obj
) || VECTORP (obj
))
3351 register struct Lisp_Vector
*vec
;
3352 register int i
, size
;
3354 size
= XVECTOR (obj
)->size
;
3355 if (size
& PSEUDOVECTOR_FLAG
)
3356 size
&= PSEUDOVECTOR_SIZE_MASK
;
3357 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3358 for (i
= 0; i
< size
; i
++)
3359 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3360 if (COMPILEDP (obj
))
3361 XSETCOMPILED (obj
, vec
);
3363 XSETVECTOR (obj
, vec
);
3366 else if (MARKERP (obj
))
3367 error ("Attempt to copy a marker to pure storage");
3374 /***********************************************************************
3376 ***********************************************************************/
3378 /* Recording what needs to be marked for gc. */
3380 struct gcpro
*gcprolist
;
3382 /* Addresses of staticpro'd variables. */
3384 #define NSTATICS 1024
3385 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3387 /* Index of next unused slot in staticvec. */
3392 /* Put an entry in staticvec, pointing at the variable with address
3396 staticpro (varaddress
)
3397 Lisp_Object
*varaddress
;
3399 staticvec
[staticidx
++] = varaddress
;
3400 if (staticidx
>= NSTATICS
)
3408 struct catchtag
*next
;
3413 struct backtrace
*next
;
3414 Lisp_Object
*function
;
3415 Lisp_Object
*args
; /* Points to vector of args. */
3416 int nargs
; /* Length of vector. */
3417 /* If nargs is UNEVALLED, args points to slot holding list of
3424 /***********************************************************************
3426 ***********************************************************************/
3428 /* Temporarily prevent garbage collection. */
3431 inhibit_garbage_collection ()
3433 int count
= specpdl_ptr
- specpdl
;
3435 int nbits
= min (VALBITS
, BITS_PER_INT
);
3437 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3439 specbind (Qgc_cons_threshold
, number
);
3445 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3446 "Reclaim storage for Lisp objects no longer needed.\n\
3447 Returns info on amount of space in use:\n\
3448 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3449 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3450 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3451 (USED-STRINGS . FREE-STRINGS))\n\
3452 Garbage collection happens automatically if you cons more than\n\
3453 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3456 register struct gcpro
*tail
;
3457 register struct specbinding
*bind
;
3458 struct catchtag
*catch;
3459 struct handler
*handler
;
3460 register struct backtrace
*backlist
;
3461 char stack_top_variable
;
3464 Lisp_Object total
[7];
3466 /* In case user calls debug_print during GC,
3467 don't let that cause a recursive GC. */
3468 consing_since_gc
= 0;
3470 /* Save what's currently displayed in the echo area. */
3471 message_p
= push_message ();
3473 /* Save a copy of the contents of the stack, for debugging. */
3474 #if MAX_SAVE_STACK > 0
3475 if (NILP (Vpurify_flag
))
3477 i
= &stack_top_variable
- stack_bottom
;
3479 if (i
< MAX_SAVE_STACK
)
3481 if (stack_copy
== 0)
3482 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3483 else if (stack_copy_size
< i
)
3484 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3487 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3488 bcopy (stack_bottom
, stack_copy
, i
);
3490 bcopy (&stack_top_variable
, stack_copy
, i
);
3494 #endif /* MAX_SAVE_STACK > 0 */
3496 if (garbage_collection_messages
)
3497 message1_nolog ("Garbage collecting...");
3501 shrink_regexp_cache ();
3503 /* Don't keep undo information around forever. */
3505 register struct buffer
*nextb
= all_buffers
;
3509 /* If a buffer's undo list is Qt, that means that undo is
3510 turned off in that buffer. Calling truncate_undo_list on
3511 Qt tends to return NULL, which effectively turns undo back on.
3512 So don't call truncate_undo_list if undo_list is Qt. */
3513 if (! EQ (nextb
->undo_list
, Qt
))
3515 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3517 nextb
= nextb
->next
;
3523 /* clear_marks (); */
3525 /* Mark all the special slots that serve as the roots of accessibility.
3527 Usually the special slots to mark are contained in particular structures.
3528 Then we know no slot is marked twice because the structures don't overlap.
3529 In some cases, the structures point to the slots to be marked.
3530 For these, we use MARKBIT to avoid double marking of the slot. */
3532 for (i
= 0; i
< staticidx
; i
++)
3533 mark_object (staticvec
[i
]);
3535 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3536 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3539 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3540 for (i
= 0; i
< tail
->nvars
; i
++)
3541 if (!XMARKBIT (tail
->var
[i
]))
3543 mark_object (&tail
->var
[i
]);
3544 XMARK (tail
->var
[i
]);
3549 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3551 mark_object (&bind
->symbol
);
3552 mark_object (&bind
->old_value
);
3554 for (catch = catchlist
; catch; catch = catch->next
)
3556 mark_object (&catch->tag
);
3557 mark_object (&catch->val
);
3559 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3561 mark_object (&handler
->handler
);
3562 mark_object (&handler
->var
);
3564 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3566 if (!XMARKBIT (*backlist
->function
))
3568 mark_object (backlist
->function
);
3569 XMARK (*backlist
->function
);
3571 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3574 i
= backlist
->nargs
- 1;
3576 if (!XMARKBIT (backlist
->args
[i
]))
3578 mark_object (&backlist
->args
[i
]);
3579 XMARK (backlist
->args
[i
]);
3584 /* Look thru every buffer's undo list
3585 for elements that update markers that were not marked,
3588 register struct buffer
*nextb
= all_buffers
;
3592 /* If a buffer's undo list is Qt, that means that undo is
3593 turned off in that buffer. Calling truncate_undo_list on
3594 Qt tends to return NULL, which effectively turns undo back on.
3595 So don't call truncate_undo_list if undo_list is Qt. */
3596 if (! EQ (nextb
->undo_list
, Qt
))
3598 Lisp_Object tail
, prev
;
3599 tail
= nextb
->undo_list
;
3601 while (CONSP (tail
))
3603 if (GC_CONSP (XCAR (tail
))
3604 && GC_MARKERP (XCAR (XCAR (tail
)))
3605 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3608 nextb
->undo_list
= tail
= XCDR (tail
);
3610 tail
= XCDR (prev
) = XCDR (tail
);
3620 nextb
= nextb
->next
;
3624 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3630 /* Clear the mark bits that we set in certain root slots. */
3632 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3633 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3634 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3635 for (i
= 0; i
< tail
->nvars
; i
++)
3636 XUNMARK (tail
->var
[i
]);
3639 unmark_byte_stack ();
3640 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3642 XUNMARK (*backlist
->function
);
3643 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3646 i
= backlist
->nargs
- 1;
3648 XUNMARK (backlist
->args
[i
]);
3650 XUNMARK (buffer_defaults
.name
);
3651 XUNMARK (buffer_local_symbols
.name
);
3653 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3659 /* clear_marks (); */
3662 consing_since_gc
= 0;
3663 if (gc_cons_threshold
< 10000)
3664 gc_cons_threshold
= 10000;
3666 if (garbage_collection_messages
)
3668 if (message_p
|| minibuf_level
> 0)
3671 message1_nolog ("Garbage collecting...done");
3676 total
[0] = Fcons (make_number (total_conses
),
3677 make_number (total_free_conses
));
3678 total
[1] = Fcons (make_number (total_symbols
),
3679 make_number (total_free_symbols
));
3680 total
[2] = Fcons (make_number (total_markers
),
3681 make_number (total_free_markers
));
3682 total
[3] = Fcons (make_number (total_string_size
),
3683 make_number (total_vector_size
));
3684 total
[4] = Fcons (make_number (total_floats
),
3685 make_number (total_free_floats
));
3686 total
[5] = Fcons (make_number (total_intervals
),
3687 make_number (total_free_intervals
));
3688 total
[6] = Fcons (make_number (total_strings
),
3689 make_number (total_free_strings
));
3691 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3693 /* Compute average percentage of zombies. */
3696 for (i
= 0; i
< 7; ++i
)
3697 nlive
+= XFASTINT (XCAR (total
[i
]));
3699 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3700 max_live
= max (nlive
, max_live
);
3701 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3702 max_zombies
= max (nzombies
, max_zombies
);
3707 return Flist (7, total
);
3711 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3712 only interesting objects referenced from glyphs are strings. */
3715 mark_glyph_matrix (matrix
)
3716 struct glyph_matrix
*matrix
;
3718 struct glyph_row
*row
= matrix
->rows
;
3719 struct glyph_row
*end
= row
+ matrix
->nrows
;
3721 for (; row
< end
; ++row
)
3725 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3727 struct glyph
*glyph
= row
->glyphs
[area
];
3728 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3730 for (; glyph
< end_glyph
; ++glyph
)
3731 if (GC_STRINGP (glyph
->object
)
3732 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3733 mark_object (&glyph
->object
);
3739 /* Mark Lisp faces in the face cache C. */
3743 struct face_cache
*c
;
3748 for (i
= 0; i
< c
->used
; ++i
)
3750 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3754 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3755 mark_object (&face
->lface
[j
]);
3762 #ifdef HAVE_WINDOW_SYSTEM
3764 /* Mark Lisp objects in image IMG. */
3770 mark_object (&img
->spec
);
3772 if (!NILP (img
->data
.lisp_val
))
3773 mark_object (&img
->data
.lisp_val
);
3777 /* Mark Lisp objects in image cache of frame F. It's done this way so
3778 that we don't have to include xterm.h here. */
3781 mark_image_cache (f
)
3784 forall_images_in_image_cache (f
, mark_image
);
3787 #endif /* HAVE_X_WINDOWS */
3791 /* Mark reference to a Lisp_Object.
3792 If the object referred to has not been seen yet, recursively mark
3793 all the references contained in it. */
3795 #define LAST_MARKED_SIZE 500
3796 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3797 int last_marked_index
;
3800 mark_object (argptr
)
3801 Lisp_Object
*argptr
;
3803 Lisp_Object
*objptr
= argptr
;
3804 register Lisp_Object obj
;
3805 #ifdef GC_CHECK_MARKED_OBJECTS
3815 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3818 last_marked
[last_marked_index
++] = objptr
;
3819 if (last_marked_index
== LAST_MARKED_SIZE
)
3820 last_marked_index
= 0;
3822 /* Perform some sanity checks on the objects marked here. Abort if
3823 we encounter an object we know is bogus. This increases GC time
3824 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
3825 #ifdef GC_CHECK_MARKED_OBJECTS
3827 po
= (void *) XPNTR (obj
);
3829 /* Check that the object pointed to by PO is known to be a Lisp
3830 structure allocated from the heap. */
3831 #define CHECK_ALLOCATED() \
3833 m = mem_find (po); \
3838 /* Check that the object pointed to by PO is live, using predicate
3840 #define CHECK_LIVE(LIVEP) \
3842 if (!LIVEP (m, po)) \
3846 /* Check both of the above conditions. */
3847 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
3849 CHECK_ALLOCATED (); \
3850 CHECK_LIVE (LIVEP); \
3853 #else /* not GC_CHECK_MARKED_OBJECTS */
3855 #define CHECK_ALLOCATED() (void) 0
3856 #define CHECK_LIVE(LIVEP) (void) 0
3857 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
3859 #endif /* not GC_CHECK_MARKED_OBJECTS */
3861 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3865 register struct Lisp_String
*ptr
= XSTRING (obj
);
3866 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
3867 MARK_INTERVAL_TREE (ptr
->intervals
);
3872 case Lisp_Vectorlike
:
3873 #ifdef GC_CHECK_MARKED_OBJECTS
3875 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
3876 && po
!= &buffer_defaults
3877 && po
!= &buffer_local_symbols
)
3879 #endif /* GC_CHECK_MARKED_OBJECTS */
3881 if (GC_BUFFERP (obj
))
3883 if (!XMARKBIT (XBUFFER (obj
)->name
))
3885 #ifdef GC_CHECK_MARKED_OBJECTS
3886 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
3889 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
3894 #endif /* GC_CHECK_MARKED_OBJECTS */
3898 else if (GC_SUBRP (obj
))
3900 else if (GC_COMPILEDP (obj
))
3901 /* We could treat this just like a vector, but it is better to
3902 save the COMPILED_CONSTANTS element for last and avoid
3905 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3906 register EMACS_INT size
= ptr
->size
;
3907 /* See comment above under Lisp_Vector. */
3908 struct Lisp_Vector
*volatile ptr1
= ptr
;
3911 if (size
& ARRAY_MARK_FLAG
)
3912 break; /* Already marked */
3914 CHECK_LIVE (live_vector_p
);
3915 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3916 size
&= PSEUDOVECTOR_SIZE_MASK
;
3917 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3919 if (i
!= COMPILED_CONSTANTS
)
3920 mark_object (&ptr1
->contents
[i
]);
3922 /* This cast should be unnecessary, but some Mips compiler complains
3923 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3924 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
3927 else if (GC_FRAMEP (obj
))
3929 /* See comment above under Lisp_Vector for why this is volatile. */
3930 register struct frame
*volatile ptr
= XFRAME (obj
);
3931 register EMACS_INT size
= ptr
->size
;
3933 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3934 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3936 CHECK_LIVE (live_vector_p
);
3937 mark_object (&ptr
->name
);
3938 mark_object (&ptr
->icon_name
);
3939 mark_object (&ptr
->title
);
3940 mark_object (&ptr
->focus_frame
);
3941 mark_object (&ptr
->selected_window
);
3942 mark_object (&ptr
->minibuffer_window
);
3943 mark_object (&ptr
->param_alist
);
3944 mark_object (&ptr
->scroll_bars
);
3945 mark_object (&ptr
->condemned_scroll_bars
);
3946 mark_object (&ptr
->menu_bar_items
);
3947 mark_object (&ptr
->face_alist
);
3948 mark_object (&ptr
->menu_bar_vector
);
3949 mark_object (&ptr
->buffer_predicate
);
3950 mark_object (&ptr
->buffer_list
);
3951 mark_object (&ptr
->menu_bar_window
);
3952 mark_object (&ptr
->tool_bar_window
);
3953 mark_face_cache (ptr
->face_cache
);
3954 #ifdef HAVE_WINDOW_SYSTEM
3955 mark_image_cache (ptr
);
3956 mark_object (&ptr
->desired_tool_bar_items
);
3957 mark_object (&ptr
->current_tool_bar_items
);
3958 mark_object (&ptr
->desired_tool_bar_string
);
3959 mark_object (&ptr
->current_tool_bar_string
);
3960 #endif /* HAVE_WINDOW_SYSTEM */
3962 else if (GC_BOOL_VECTOR_P (obj
))
3964 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3966 if (ptr
->size
& ARRAY_MARK_FLAG
)
3967 break; /* Already marked */
3968 CHECK_LIVE (live_vector_p
);
3969 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3971 else if (GC_WINDOWP (obj
))
3973 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3974 struct window
*w
= XWINDOW (obj
);
3975 register EMACS_INT size
= ptr
->size
;
3976 /* The reason we use ptr1 is to avoid an apparent hardware bug
3977 that happens occasionally on the FSF's HP 300s.
3978 The bug is that a2 gets clobbered by recursive calls to mark_object.
3979 The clobberage seems to happen during function entry,
3980 perhaps in the moveml instruction.
3981 Yes, this is a crock, but we have to do it. */
3982 struct Lisp_Vector
*volatile ptr1
= ptr
;
3985 /* Stop if already marked. */
3986 if (size
& ARRAY_MARK_FLAG
)
3990 CHECK_LIVE (live_vector_p
);
3991 ptr
->size
|= ARRAY_MARK_FLAG
;
3993 /* There is no Lisp data above The member CURRENT_MATRIX in
3994 struct WINDOW. Stop marking when that slot is reached. */
3996 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
3998 mark_object (&ptr1
->contents
[i
]);
4000 /* Mark glyphs for leaf windows. Marking window matrices is
4001 sufficient because frame matrices use the same glyph
4003 if (NILP (w
->hchild
)
4005 && w
->current_matrix
)
4007 mark_glyph_matrix (w
->current_matrix
);
4008 mark_glyph_matrix (w
->desired_matrix
);
4011 else if (GC_HASH_TABLE_P (obj
))
4013 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4014 EMACS_INT size
= h
->size
;
4016 /* Stop if already marked. */
4017 if (size
& ARRAY_MARK_FLAG
)
4021 CHECK_LIVE (live_vector_p
);
4022 h
->size
|= ARRAY_MARK_FLAG
;
4024 /* Mark contents. */
4025 mark_object (&h
->test
);
4026 mark_object (&h
->weak
);
4027 mark_object (&h
->rehash_size
);
4028 mark_object (&h
->rehash_threshold
);
4029 mark_object (&h
->hash
);
4030 mark_object (&h
->next
);
4031 mark_object (&h
->index
);
4032 mark_object (&h
->user_hash_function
);
4033 mark_object (&h
->user_cmp_function
);
4035 /* If hash table is not weak, mark all keys and values.
4036 For weak tables, mark only the vector. */
4037 if (GC_NILP (h
->weak
))
4038 mark_object (&h
->key_and_value
);
4040 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
4045 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4046 register EMACS_INT size
= ptr
->size
;
4047 /* The reason we use ptr1 is to avoid an apparent hardware bug
4048 that happens occasionally on the FSF's HP 300s.
4049 The bug is that a2 gets clobbered by recursive calls to mark_object.
4050 The clobberage seems to happen during function entry,
4051 perhaps in the moveml instruction.
4052 Yes, this is a crock, but we have to do it. */
4053 struct Lisp_Vector
*volatile ptr1
= ptr
;
4056 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4057 CHECK_LIVE (live_vector_p
);
4058 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4059 if (size
& PSEUDOVECTOR_FLAG
)
4060 size
&= PSEUDOVECTOR_SIZE_MASK
;
4062 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4063 mark_object (&ptr1
->contents
[i
]);
4069 /* See comment above under Lisp_Vector for why this is volatile. */
4070 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
4071 struct Lisp_Symbol
*ptrx
;
4073 if (XMARKBIT (ptr
->plist
)) break;
4074 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4076 mark_object ((Lisp_Object
*) &ptr
->value
);
4077 mark_object (&ptr
->function
);
4078 mark_object (&ptr
->plist
);
4080 if (!PURE_POINTER_P (ptr
->name
))
4081 MARK_STRING (ptr
->name
);
4082 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
4084 /* Note that we do not mark the obarray of the symbol.
4085 It is safe not to do so because nothing accesses that
4086 slot except to check whether it is nil. */
4090 /* For the benefit of the last_marked log. */
4091 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4092 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4093 XSETSYMBOL (obj
, ptrx
);
4094 /* We can't goto loop here because *objptr doesn't contain an
4095 actual Lisp_Object with valid datatype field. */
4102 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4103 switch (XMISCTYPE (obj
))
4105 case Lisp_Misc_Marker
:
4106 XMARK (XMARKER (obj
)->chain
);
4107 /* DO NOT mark thru the marker's chain.
4108 The buffer's markers chain does not preserve markers from gc;
4109 instead, markers are removed from the chain when freed by gc. */
4112 case Lisp_Misc_Buffer_Local_Value
:
4113 case Lisp_Misc_Some_Buffer_Local_Value
:
4115 register struct Lisp_Buffer_Local_Value
*ptr
4116 = XBUFFER_LOCAL_VALUE (obj
);
4117 if (XMARKBIT (ptr
->realvalue
)) break;
4118 XMARK (ptr
->realvalue
);
4119 /* If the cdr is nil, avoid recursion for the car. */
4120 if (EQ (ptr
->cdr
, Qnil
))
4122 objptr
= &ptr
->realvalue
;
4125 mark_object (&ptr
->realvalue
);
4126 mark_object (&ptr
->buffer
);
4127 mark_object (&ptr
->frame
);
4128 /* See comment above under Lisp_Vector for why not use ptr here. */
4129 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
4133 case Lisp_Misc_Intfwd
:
4134 case Lisp_Misc_Boolfwd
:
4135 case Lisp_Misc_Objfwd
:
4136 case Lisp_Misc_Buffer_Objfwd
:
4137 case Lisp_Misc_Kboard_Objfwd
:
4138 /* Don't bother with Lisp_Buffer_Objfwd,
4139 since all markable slots in current buffer marked anyway. */
4140 /* Don't need to do Lisp_Objfwd, since the places they point
4141 are protected with staticpro. */
4144 case Lisp_Misc_Overlay
:
4146 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4147 if (!XMARKBIT (ptr
->plist
))
4150 mark_object (&ptr
->start
);
4151 mark_object (&ptr
->end
);
4152 objptr
= &ptr
->plist
;
4165 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4166 if (XMARKBIT (ptr
->car
)) break;
4167 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
4169 /* If the cdr is nil, avoid recursion for the car. */
4170 if (EQ (ptr
->cdr
, Qnil
))
4175 mark_object (&ptr
->car
);
4176 /* See comment above under Lisp_Vector for why not use ptr here. */
4177 objptr
= &XCDR (obj
);
4182 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
4183 XMARK (XFLOAT (obj
)->type
);
4194 #undef CHECK_ALLOCATED
4195 #undef CHECK_ALLOCATED_AND_LIVE
4198 /* Mark the pointers in a buffer structure. */
4204 register struct buffer
*buffer
= XBUFFER (buf
);
4205 register Lisp_Object
*ptr
;
4206 Lisp_Object base_buffer
;
4208 /* This is the buffer's markbit */
4209 mark_object (&buffer
->name
);
4210 XMARK (buffer
->name
);
4212 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4214 if (CONSP (buffer
->undo_list
))
4217 tail
= buffer
->undo_list
;
4219 while (CONSP (tail
))
4221 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4223 if (XMARKBIT (ptr
->car
))
4226 if (GC_CONSP (ptr
->car
)
4227 && ! XMARKBIT (XCAR (ptr
->car
))
4228 && GC_MARKERP (XCAR (ptr
->car
)))
4230 XMARK (XCAR (ptr
->car
));
4231 mark_object (&XCDR (ptr
->car
));
4234 mark_object (&ptr
->car
);
4236 if (CONSP (ptr
->cdr
))
4242 mark_object (&XCDR (tail
));
4245 mark_object (&buffer
->undo_list
);
4247 for (ptr
= &buffer
->name
+ 1;
4248 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4252 /* If this is an indirect buffer, mark its base buffer. */
4253 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4255 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4256 mark_buffer (base_buffer
);
4261 /* Mark the pointers in the kboard objects. */
4268 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4270 if (kb
->kbd_macro_buffer
)
4271 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4273 mark_object (&kb
->Voverriding_terminal_local_map
);
4274 mark_object (&kb
->Vlast_command
);
4275 mark_object (&kb
->Vreal_last_command
);
4276 mark_object (&kb
->Vprefix_arg
);
4277 mark_object (&kb
->Vlast_prefix_arg
);
4278 mark_object (&kb
->kbd_queue
);
4279 mark_object (&kb
->defining_kbd_macro
);
4280 mark_object (&kb
->Vlast_kbd_macro
);
4281 mark_object (&kb
->Vsystem_key_alist
);
4282 mark_object (&kb
->system_key_syms
);
4283 mark_object (&kb
->Vdefault_minibuffer_frame
);
4288 /* Value is non-zero if OBJ will survive the current GC because it's
4289 either marked or does not need to be marked to survive. */
4297 switch (XGCTYPE (obj
))
4304 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4308 switch (XMISCTYPE (obj
))
4310 case Lisp_Misc_Marker
:
4311 survives_p
= XMARKBIT (obj
);
4314 case Lisp_Misc_Buffer_Local_Value
:
4315 case Lisp_Misc_Some_Buffer_Local_Value
:
4316 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4319 case Lisp_Misc_Intfwd
:
4320 case Lisp_Misc_Boolfwd
:
4321 case Lisp_Misc_Objfwd
:
4322 case Lisp_Misc_Buffer_Objfwd
:
4323 case Lisp_Misc_Kboard_Objfwd
:
4327 case Lisp_Misc_Overlay
:
4328 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4338 struct Lisp_String
*s
= XSTRING (obj
);
4339 survives_p
= STRING_MARKED_P (s
);
4343 case Lisp_Vectorlike
:
4344 if (GC_BUFFERP (obj
))
4345 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4346 else if (GC_SUBRP (obj
))
4349 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4353 survives_p
= XMARKBIT (XCAR (obj
));
4357 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4364 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4369 /* Sweep: find all structures not marked, and free them. */
4374 /* Remove or mark entries in weak hash tables.
4375 This must be done before any object is unmarked. */
4376 sweep_weak_hash_tables ();
4380 /* Put all unmarked conses on free list */
4382 register struct cons_block
*cblk
;
4383 struct cons_block
**cprev
= &cons_block
;
4384 register int lim
= cons_block_index
;
4385 register int num_free
= 0, num_used
= 0;
4389 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4393 for (i
= 0; i
< lim
; i
++)
4394 if (!XMARKBIT (cblk
->conses
[i
].car
))
4397 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4398 cons_free_list
= &cblk
->conses
[i
];
4400 cons_free_list
->car
= Vdead
;
4406 XUNMARK (cblk
->conses
[i
].car
);
4408 lim
= CONS_BLOCK_SIZE
;
4409 /* If this block contains only free conses and we have already
4410 seen more than two blocks worth of free conses then deallocate
4412 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4414 *cprev
= cblk
->next
;
4415 /* Unhook from the free list. */
4416 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4422 num_free
+= this_free
;
4423 cprev
= &cblk
->next
;
4426 total_conses
= num_used
;
4427 total_free_conses
= num_free
;
4430 /* Put all unmarked floats on free list */
4432 register struct float_block
*fblk
;
4433 struct float_block
**fprev
= &float_block
;
4434 register int lim
= float_block_index
;
4435 register int num_free
= 0, num_used
= 0;
4437 float_free_list
= 0;
4439 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4443 for (i
= 0; i
< lim
; i
++)
4444 if (!XMARKBIT (fblk
->floats
[i
].type
))
4447 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4448 float_free_list
= &fblk
->floats
[i
];
4450 float_free_list
->type
= Vdead
;
4456 XUNMARK (fblk
->floats
[i
].type
);
4458 lim
= FLOAT_BLOCK_SIZE
;
4459 /* If this block contains only free floats and we have already
4460 seen more than two blocks worth of free floats then deallocate
4462 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4464 *fprev
= fblk
->next
;
4465 /* Unhook from the free list. */
4466 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4472 num_free
+= this_free
;
4473 fprev
= &fblk
->next
;
4476 total_floats
= num_used
;
4477 total_free_floats
= num_free
;
4480 /* Put all unmarked intervals on free list */
4482 register struct interval_block
*iblk
;
4483 struct interval_block
**iprev
= &interval_block
;
4484 register int lim
= interval_block_index
;
4485 register int num_free
= 0, num_used
= 0;
4487 interval_free_list
= 0;
4489 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4494 for (i
= 0; i
< lim
; i
++)
4496 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4498 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4499 interval_free_list
= &iblk
->intervals
[i
];
4505 XUNMARK (iblk
->intervals
[i
].plist
);
4508 lim
= INTERVAL_BLOCK_SIZE
;
4509 /* If this block contains only free intervals and we have already
4510 seen more than two blocks worth of free intervals then
4511 deallocate this block. */
4512 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4514 *iprev
= iblk
->next
;
4515 /* Unhook from the free list. */
4516 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4518 n_interval_blocks
--;
4522 num_free
+= this_free
;
4523 iprev
= &iblk
->next
;
4526 total_intervals
= num_used
;
4527 total_free_intervals
= num_free
;
4530 /* Put all unmarked symbols on free list */
4532 register struct symbol_block
*sblk
;
4533 struct symbol_block
**sprev
= &symbol_block
;
4534 register int lim
= symbol_block_index
;
4535 register int num_free
= 0, num_used
= 0;
4537 symbol_free_list
= 0;
4539 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4543 for (i
= 0; i
< lim
; i
++)
4544 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4546 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4547 symbol_free_list
= &sblk
->symbols
[i
];
4549 symbol_free_list
->function
= Vdead
;
4556 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4557 UNMARK_STRING (sblk
->symbols
[i
].name
);
4558 XUNMARK (sblk
->symbols
[i
].plist
);
4560 lim
= SYMBOL_BLOCK_SIZE
;
4561 /* If this block contains only free symbols and we have already
4562 seen more than two blocks worth of free symbols then deallocate
4564 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4566 *sprev
= sblk
->next
;
4567 /* Unhook from the free list. */
4568 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4574 num_free
+= this_free
;
4575 sprev
= &sblk
->next
;
4578 total_symbols
= num_used
;
4579 total_free_symbols
= num_free
;
4582 /* Put all unmarked misc's on free list.
4583 For a marker, first unchain it from the buffer it points into. */
4585 register struct marker_block
*mblk
;
4586 struct marker_block
**mprev
= &marker_block
;
4587 register int lim
= marker_block_index
;
4588 register int num_free
= 0, num_used
= 0;
4590 marker_free_list
= 0;
4592 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4596 EMACS_INT already_free
= -1;
4598 for (i
= 0; i
< lim
; i
++)
4600 Lisp_Object
*markword
;
4601 switch (mblk
->markers
[i
].u_marker
.type
)
4603 case Lisp_Misc_Marker
:
4604 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4606 case Lisp_Misc_Buffer_Local_Value
:
4607 case Lisp_Misc_Some_Buffer_Local_Value
:
4608 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4610 case Lisp_Misc_Overlay
:
4611 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4613 case Lisp_Misc_Free
:
4614 /* If the object was already free, keep it
4615 on the free list. */
4616 markword
= (Lisp_Object
*) &already_free
;
4622 if (markword
&& !XMARKBIT (*markword
))
4625 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4627 /* tem1 avoids Sun compiler bug */
4628 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4629 XSETMARKER (tem
, tem1
);
4630 unchain_marker (tem
);
4632 /* Set the type of the freed object to Lisp_Misc_Free.
4633 We could leave the type alone, since nobody checks it,
4634 but this might catch bugs faster. */
4635 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4636 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4637 marker_free_list
= &mblk
->markers
[i
];
4644 XUNMARK (*markword
);
4647 lim
= MARKER_BLOCK_SIZE
;
4648 /* If this block contains only free markers and we have already
4649 seen more than two blocks worth of free markers then deallocate
4651 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4653 *mprev
= mblk
->next
;
4654 /* Unhook from the free list. */
4655 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4661 num_free
+= this_free
;
4662 mprev
= &mblk
->next
;
4666 total_markers
= num_used
;
4667 total_free_markers
= num_free
;
4670 /* Free all unmarked buffers */
4672 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4675 if (!XMARKBIT (buffer
->name
))
4678 prev
->next
= buffer
->next
;
4680 all_buffers
= buffer
->next
;
4681 next
= buffer
->next
;
4687 XUNMARK (buffer
->name
);
4688 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4689 prev
= buffer
, buffer
= buffer
->next
;
4693 /* Free all unmarked vectors */
4695 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4696 total_vector_size
= 0;
4699 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4702 prev
->next
= vector
->next
;
4704 all_vectors
= vector
->next
;
4705 next
= vector
->next
;
4713 vector
->size
&= ~ARRAY_MARK_FLAG
;
4714 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4715 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4717 total_vector_size
+= vector
->size
;
4718 prev
= vector
, vector
= vector
->next
;
4726 /* Debugging aids. */
4728 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4729 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4730 This may be helpful in debugging Emacs's memory usage.\n\
4731 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4736 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4741 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4742 "Return a list of counters that measure how much consing there has been.\n\
4743 Each of these counters increments for a certain kind of object.\n\
4744 The counters wrap around from the largest positive integer to zero.\n\
4745 Garbage collection does not decrease them.\n\
4746 The elements of the value are as follows:\n\
4747 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4748 All are in units of 1 = one object consed\n\
4749 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4751 MISCS include overlays, markers, and some internal types.\n\
4752 Frames, windows, buffers, and subprocesses count as vectors\n\
4753 (but the contents of a buffer's text do not count here).")
4756 Lisp_Object consed
[8];
4759 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4761 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4763 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4765 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4767 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4769 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4771 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4773 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4775 return Flist (8, consed
);
4778 int suppress_checking
;
4780 die (msg
, file
, line
)
4785 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4790 /* Initialization */
4795 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4799 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4802 pure_size
= PURESIZE
;
4805 ignore_warnings
= 1;
4806 #ifdef DOUG_LEA_MALLOC
4807 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4808 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4809 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4819 malloc_hysteresis
= 32;
4821 malloc_hysteresis
= 0;
4824 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4826 ignore_warnings
= 0;
4828 byte_stack_list
= 0;
4830 consing_since_gc
= 0;
4831 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4832 #ifdef VIRT_ADDR_VARIES
4833 malloc_sbrk_unused
= 1<<22; /* A large number */
4834 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4835 #endif /* VIRT_ADDR_VARIES */
4842 byte_stack_list
= 0;
4844 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4845 setjmp_tested_p
= longjmps_done
= 0;
4853 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4854 "*Number of bytes of consing between garbage collections.\n\
4855 Garbage collection can happen automatically once this many bytes have been\n\
4856 allocated since the last garbage collection. All data types count.\n\n\
4857 Garbage collection happens automatically only when `eval' is called.\n\n\
4858 By binding this temporarily to a large number, you can effectively\n\
4859 prevent garbage collection during a part of the program.");
4861 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4862 "Number of bytes of sharable Lisp data allocated so far.");
4864 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4865 "Number of cons cells that have been consed so far.");
4867 DEFVAR_INT ("floats-consed", &floats_consed
,
4868 "Number of floats that have been consed so far.");
4870 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4871 "Number of vector cells that have been consed so far.");
4873 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4874 "Number of symbols that have been consed so far.");
4876 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4877 "Number of string characters that have been consed so far.");
4879 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4880 "Number of miscellaneous objects that have been consed so far.");
4882 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4883 "Number of intervals that have been consed so far.");
4885 DEFVAR_INT ("strings-consed", &strings_consed
,
4886 "Number of strings that have been consed so far.");
4888 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4889 "Non-nil means loading Lisp code in order to dump an executable.\n\
4890 This means that certain objects should be allocated in shared (pure) space.");
4892 DEFVAR_INT ("undo-limit", &undo_limit
,
4893 "Keep no more undo information once it exceeds this size.\n\
4894 This limit is applied when garbage collection happens.\n\
4895 The size is counted as the number of bytes occupied,\n\
4896 which includes both saved text and other data.");
4899 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
4900 "Don't keep more than this much size of undo information.\n\
4901 A command which pushes past this size is itself forgotten.\n\
4902 This limit is applied when garbage collection happens.\n\
4903 The size is counted as the number of bytes occupied,\n\
4904 which includes both saved text and other data.");
4905 undo_strong_limit
= 30000;
4907 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
4908 "Non-nil means display messages at start and end of garbage collection.");
4909 garbage_collection_messages
= 0;
4911 /* We build this in advance because if we wait until we need it, we might
4912 not be able to allocate the memory to hold it. */
4914 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
4915 staticpro (&memory_signal_data
);
4917 staticpro (&Qgc_cons_threshold
);
4918 Qgc_cons_threshold
= intern ("gc-cons-threshold");
4920 staticpro (&Qchar_table_extra_slots
);
4921 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
4926 defsubr (&Smake_byte_code
);
4927 defsubr (&Smake_list
);
4928 defsubr (&Smake_vector
);
4929 defsubr (&Smake_char_table
);
4930 defsubr (&Smake_string
);
4931 defsubr (&Smake_bool_vector
);
4932 defsubr (&Smake_symbol
);
4933 defsubr (&Smake_marker
);
4934 defsubr (&Spurecopy
);
4935 defsubr (&Sgarbage_collect
);
4936 defsubr (&Smemory_limit
);
4937 defsubr (&Smemory_use_counts
);
4939 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4940 defsubr (&Sgc_status
);