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
);
2941 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2942 if (nzombies
< MAX_ZOMBIES
)
2943 zombies
[nzombies
] = *p
;
2951 /* Mark Lisp objects in the address range START..END. */
2954 mark_memory (start
, end
)
2959 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2963 /* Make START the pointer to the start of the memory region,
2964 if it isn't already. */
2972 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
2973 mark_maybe_object (*p
);
2977 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
2979 static int setjmp_tested_p
, longjmps_done
;
2981 #define SETJMP_WILL_LIKELY_WORK "\
2983 Emacs garbage collector has been changed to use conservative stack\n\
2984 marking. Emacs has determined that the method it uses to do the\n\
2985 marking will likely work on your system, but this isn't sure.\n\
2987 If you are a system-programmer, or can get the help of a local wizard\n\
2988 who is, please take a look at the function mark_stack in alloc.c, and\n\
2989 verify that the methods used are appropriate for your system.\n\
2991 Please mail the result to <gerd@gnu.org>.\n\
2994 #define SETJMP_WILL_NOT_WORK "\
2996 Emacs garbage collector has been changed to use conservative stack\n\
2997 marking. Emacs has determined that the default method it uses to do the\n\
2998 marking will not work on your system. We will need a system-dependent\n\
2999 solution for your system.\n\
3001 Please take a look at the function mark_stack in alloc.c, and\n\
3002 try to find a way to make it work on your system.\n\
3003 Please mail the result to <gerd@gnu.org>.\n\
3007 /* Perform a quick check if it looks like setjmp saves registers in a
3008 jmp_buf. Print a message to stderr saying so. When this test
3009 succeeds, this is _not_ a proof that setjmp is sufficient for
3010 conservative stack marking. Only the sources or a disassembly
3021 /* Arrange for X to be put in a register. */
3027 if (longjmps_done
== 1)
3029 /* Came here after the longjmp at the end of the function.
3031 If x == 1, the longjmp has restored the register to its
3032 value before the setjmp, and we can hope that setjmp
3033 saves all such registers in the jmp_buf, although that
3036 For other values of X, either something really strange is
3037 taking place, or the setjmp just didn't save the register. */
3040 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3043 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3050 if (longjmps_done
== 1)
3054 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3057 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3059 /* Abort if anything GCPRO'd doesn't survive the GC. */
3067 for (p
= gcprolist
; p
; p
= p
->next
)
3068 for (i
= 0; i
< p
->nvars
; ++i
)
3069 if (!survives_gc_p (p
->var
[i
]))
3073 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3080 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3081 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3083 fprintf (stderr
, " %d = ", i
);
3084 debug_print (zombies
[i
]);
3088 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3091 /* Mark live Lisp objects on the C stack.
3093 There are several system-dependent problems to consider when
3094 porting this to new architectures:
3098 We have to mark Lisp objects in CPU registers that can hold local
3099 variables or are used to pass parameters.
3101 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3102 something that either saves relevant registers on the stack, or
3103 calls mark_maybe_object passing it each register's contents.
3105 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3106 implementation assumes that calling setjmp saves registers we need
3107 to see in a jmp_buf which itself lies on the stack. This doesn't
3108 have to be true! It must be verified for each system, possibly
3109 by taking a look at the source code of setjmp.
3113 Architectures differ in the way their processor stack is organized.
3114 For example, the stack might look like this
3117 | Lisp_Object | size = 4
3119 | something else | size = 2
3121 | Lisp_Object | size = 4
3125 In such a case, not every Lisp_Object will be aligned equally. To
3126 find all Lisp_Object on the stack it won't be sufficient to walk
3127 the stack in steps of 4 bytes. Instead, two passes will be
3128 necessary, one starting at the start of the stack, and a second
3129 pass starting at the start of the stack + 2. Likewise, if the
3130 minimal alignment of Lisp_Objects on the stack is 1, four passes
3131 would be necessary, each one starting with one byte more offset
3132 from the stack start.
3134 The current code assumes by default that Lisp_Objects are aligned
3135 equally on the stack. */
3141 int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3144 /* This trick flushes the register windows so that all the state of
3145 the process is contained in the stack. */
3150 /* Save registers that we need to see on the stack. We need to see
3151 registers used to hold register variables and registers used to
3153 #ifdef GC_SAVE_REGISTERS_ON_STACK
3154 GC_SAVE_REGISTERS_ON_STACK (end
);
3155 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3157 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3158 setjmp will definitely work, test it
3159 and print a message with the result
3161 if (!setjmp_tested_p
)
3163 setjmp_tested_p
= 1;
3166 #endif /* GC_SETJMP_WORKS */
3169 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3170 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3172 /* This assumes that the stack is a contiguous region in memory. If
3173 that's not the case, something has to be done here to iterate
3174 over the stack segments. */
3175 #if GC_LISP_OBJECT_ALIGNMENT == 1
3176 mark_memory (stack_base
, end
);
3177 mark_memory ((char *) stack_base
+ 1, end
);
3178 mark_memory ((char *) stack_base
+ 2, end
);
3179 mark_memory ((char *) stack_base
+ 3, end
);
3180 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3181 mark_memory (stack_base
, end
);
3182 mark_memory ((char *) stack_base
+ 2, end
);
3184 mark_memory (stack_base
, end
);
3187 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3193 #endif /* GC_MARK_STACK != 0 */
3197 /***********************************************************************
3198 Pure Storage Management
3199 ***********************************************************************/
3201 /* Return a string allocated in pure space. DATA is a buffer holding
3202 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3203 non-zero means make the result string multibyte.
3205 Must get an error if pure storage is full, since if it cannot hold
3206 a large string it may be able to hold conses that point to that
3207 string; then the string is not protected from gc. */
3210 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3216 struct Lisp_String
*s
;
3217 int string_size
, data_size
;
3219 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3221 string_size
= PAD (sizeof (struct Lisp_String
));
3222 data_size
= PAD (nbytes
+ 1);
3226 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3227 error ("Pure Lisp storage exhausted");
3229 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3230 pureptr
+= string_size
;
3231 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3232 pureptr
+= data_size
;
3235 s
->size_byte
= multibyte
? nbytes
: -1;
3236 bcopy (data
, s
->data
, nbytes
);
3237 s
->data
[nbytes
] = '\0';
3238 s
->intervals
= NULL_INTERVAL
;
3240 XSETSTRING (string
, s
);
3245 /* Return a cons allocated from pure space. Give it pure copies
3246 of CAR as car and CDR as cdr. */
3249 pure_cons (car
, cdr
)
3250 Lisp_Object car
, cdr
;
3252 register Lisp_Object
new;
3254 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3255 error ("Pure Lisp storage exhausted");
3256 XSETCONS (new, PUREBEG
+ pureptr
);
3257 pureptr
+= sizeof (struct Lisp_Cons
);
3258 XCAR (new) = Fpurecopy (car
);
3259 XCDR (new) = Fpurecopy (cdr
);
3264 /* Value is a float object with value NUM allocated from pure space. */
3267 make_pure_float (num
)
3270 register Lisp_Object
new;
3272 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3273 (double) boundary. Some architectures (like the sparc) require
3274 this, and I suspect that floats are rare enough that it's no
3275 tragedy for those that do. */
3278 char *p
= PUREBEG
+ pureptr
;
3282 alignment
= __alignof (struct Lisp_Float
);
3284 alignment
= sizeof (struct Lisp_Float
);
3287 alignment
= sizeof (struct Lisp_Float
);
3289 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3290 pureptr
= p
- PUREBEG
;
3293 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3294 error ("Pure Lisp storage exhausted");
3295 XSETFLOAT (new, PUREBEG
+ pureptr
);
3296 pureptr
+= sizeof (struct Lisp_Float
);
3297 XFLOAT_DATA (new) = num
;
3298 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3303 /* Return a vector with room for LEN Lisp_Objects allocated from
3307 make_pure_vector (len
)
3310 register Lisp_Object
new;
3311 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3312 + (len
- 1) * sizeof (Lisp_Object
));
3314 if (pureptr
+ size
> PURESIZE
)
3315 error ("Pure Lisp storage exhausted");
3317 XSETVECTOR (new, PUREBEG
+ pureptr
);
3319 XVECTOR (new)->size
= len
;
3324 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3325 "Make a copy of OBJECT in pure storage.\n\
3326 Recursively copies contents of vectors and cons cells.\n\
3327 Does not copy symbols. Copies strings without text properties.")
3329 register Lisp_Object obj
;
3331 if (NILP (Vpurify_flag
))
3334 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3335 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3339 return pure_cons (XCAR (obj
), XCDR (obj
));
3340 else if (FLOATP (obj
))
3341 return make_pure_float (XFLOAT_DATA (obj
));
3342 else if (STRINGP (obj
))
3343 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3344 STRING_BYTES (XSTRING (obj
)),
3345 STRING_MULTIBYTE (obj
));
3346 else if (COMPILEDP (obj
) || VECTORP (obj
))
3348 register struct Lisp_Vector
*vec
;
3349 register int i
, size
;
3351 size
= XVECTOR (obj
)->size
;
3352 if (size
& PSEUDOVECTOR_FLAG
)
3353 size
&= PSEUDOVECTOR_SIZE_MASK
;
3354 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3355 for (i
= 0; i
< size
; i
++)
3356 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3357 if (COMPILEDP (obj
))
3358 XSETCOMPILED (obj
, vec
);
3360 XSETVECTOR (obj
, vec
);
3363 else if (MARKERP (obj
))
3364 error ("Attempt to copy a marker to pure storage");
3371 /***********************************************************************
3373 ***********************************************************************/
3375 /* Recording what needs to be marked for gc. */
3377 struct gcpro
*gcprolist
;
3379 /* Addresses of staticpro'd variables. */
3381 #define NSTATICS 1024
3382 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3384 /* Index of next unused slot in staticvec. */
3389 /* Put an entry in staticvec, pointing at the variable with address
3393 staticpro (varaddress
)
3394 Lisp_Object
*varaddress
;
3396 staticvec
[staticidx
++] = varaddress
;
3397 if (staticidx
>= NSTATICS
)
3405 struct catchtag
*next
;
3410 struct backtrace
*next
;
3411 Lisp_Object
*function
;
3412 Lisp_Object
*args
; /* Points to vector of args. */
3413 int nargs
; /* Length of vector. */
3414 /* If nargs is UNEVALLED, args points to slot holding list of
3421 /***********************************************************************
3423 ***********************************************************************/
3425 /* Temporarily prevent garbage collection. */
3428 inhibit_garbage_collection ()
3430 int count
= specpdl_ptr
- specpdl
;
3432 int nbits
= min (VALBITS
, BITS_PER_INT
);
3434 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3436 specbind (Qgc_cons_threshold
, number
);
3442 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3443 "Reclaim storage for Lisp objects no longer needed.\n\
3444 Returns info on amount of space in use:\n\
3445 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3446 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3447 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3448 (USED-STRINGS . FREE-STRINGS))\n\
3449 Garbage collection happens automatically if you cons more than\n\
3450 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3453 register struct gcpro
*tail
;
3454 register struct specbinding
*bind
;
3455 struct catchtag
*catch;
3456 struct handler
*handler
;
3457 register struct backtrace
*backlist
;
3458 char stack_top_variable
;
3461 Lisp_Object total
[7];
3463 /* In case user calls debug_print during GC,
3464 don't let that cause a recursive GC. */
3465 consing_since_gc
= 0;
3467 /* Save what's currently displayed in the echo area. */
3468 message_p
= push_message ();
3470 /* Save a copy of the contents of the stack, for debugging. */
3471 #if MAX_SAVE_STACK > 0
3472 if (NILP (Vpurify_flag
))
3474 i
= &stack_top_variable
- stack_bottom
;
3476 if (i
< MAX_SAVE_STACK
)
3478 if (stack_copy
== 0)
3479 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3480 else if (stack_copy_size
< i
)
3481 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3484 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3485 bcopy (stack_bottom
, stack_copy
, i
);
3487 bcopy (&stack_top_variable
, stack_copy
, i
);
3491 #endif /* MAX_SAVE_STACK > 0 */
3493 if (garbage_collection_messages
)
3494 message1_nolog ("Garbage collecting...");
3498 shrink_regexp_cache ();
3500 /* Don't keep undo information around forever. */
3502 register struct buffer
*nextb
= all_buffers
;
3506 /* If a buffer's undo list is Qt, that means that undo is
3507 turned off in that buffer. Calling truncate_undo_list on
3508 Qt tends to return NULL, which effectively turns undo back on.
3509 So don't call truncate_undo_list if undo_list is Qt. */
3510 if (! EQ (nextb
->undo_list
, Qt
))
3512 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3514 nextb
= nextb
->next
;
3520 /* clear_marks (); */
3522 /* Mark all the special slots that serve as the roots of accessibility.
3524 Usually the special slots to mark are contained in particular structures.
3525 Then we know no slot is marked twice because the structures don't overlap.
3526 In some cases, the structures point to the slots to be marked.
3527 For these, we use MARKBIT to avoid double marking of the slot. */
3529 for (i
= 0; i
< staticidx
; i
++)
3530 mark_object (staticvec
[i
]);
3532 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3533 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3536 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3537 for (i
= 0; i
< tail
->nvars
; i
++)
3538 if (!XMARKBIT (tail
->var
[i
]))
3540 mark_object (&tail
->var
[i
]);
3541 XMARK (tail
->var
[i
]);
3546 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3548 mark_object (&bind
->symbol
);
3549 mark_object (&bind
->old_value
);
3551 for (catch = catchlist
; catch; catch = catch->next
)
3553 mark_object (&catch->tag
);
3554 mark_object (&catch->val
);
3556 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3558 mark_object (&handler
->handler
);
3559 mark_object (&handler
->var
);
3561 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3563 if (!XMARKBIT (*backlist
->function
))
3565 mark_object (backlist
->function
);
3566 XMARK (*backlist
->function
);
3568 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3571 i
= backlist
->nargs
- 1;
3573 if (!XMARKBIT (backlist
->args
[i
]))
3575 mark_object (&backlist
->args
[i
]);
3576 XMARK (backlist
->args
[i
]);
3581 /* Look thru every buffer's undo list
3582 for elements that update markers that were not marked,
3585 register struct buffer
*nextb
= all_buffers
;
3589 /* If a buffer's undo list is Qt, that means that undo is
3590 turned off in that buffer. Calling truncate_undo_list on
3591 Qt tends to return NULL, which effectively turns undo back on.
3592 So don't call truncate_undo_list if undo_list is Qt. */
3593 if (! EQ (nextb
->undo_list
, Qt
))
3595 Lisp_Object tail
, prev
;
3596 tail
= nextb
->undo_list
;
3598 while (CONSP (tail
))
3600 if (GC_CONSP (XCAR (tail
))
3601 && GC_MARKERP (XCAR (XCAR (tail
)))
3602 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3605 nextb
->undo_list
= tail
= XCDR (tail
);
3607 tail
= XCDR (prev
) = XCDR (tail
);
3617 nextb
= nextb
->next
;
3621 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3627 /* Clear the mark bits that we set in certain root slots. */
3629 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3630 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3631 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3632 for (i
= 0; i
< tail
->nvars
; i
++)
3633 XUNMARK (tail
->var
[i
]);
3636 unmark_byte_stack ();
3637 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3639 XUNMARK (*backlist
->function
);
3640 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3643 i
= backlist
->nargs
- 1;
3645 XUNMARK (backlist
->args
[i
]);
3647 XUNMARK (buffer_defaults
.name
);
3648 XUNMARK (buffer_local_symbols
.name
);
3650 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3656 /* clear_marks (); */
3659 consing_since_gc
= 0;
3660 if (gc_cons_threshold
< 10000)
3661 gc_cons_threshold
= 10000;
3663 if (garbage_collection_messages
)
3665 if (message_p
|| minibuf_level
> 0)
3668 message1_nolog ("Garbage collecting...done");
3673 total
[0] = Fcons (make_number (total_conses
),
3674 make_number (total_free_conses
));
3675 total
[1] = Fcons (make_number (total_symbols
),
3676 make_number (total_free_symbols
));
3677 total
[2] = Fcons (make_number (total_markers
),
3678 make_number (total_free_markers
));
3679 total
[3] = Fcons (make_number (total_string_size
),
3680 make_number (total_vector_size
));
3681 total
[4] = Fcons (make_number (total_floats
),
3682 make_number (total_free_floats
));
3683 total
[5] = Fcons (make_number (total_intervals
),
3684 make_number (total_free_intervals
));
3685 total
[6] = Fcons (make_number (total_strings
),
3686 make_number (total_free_strings
));
3688 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3690 /* Compute average percentage of zombies. */
3693 for (i
= 0; i
< 7; ++i
)
3694 nlive
+= XFASTINT (XCAR (total
[i
]));
3696 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3697 max_live
= max (nlive
, max_live
);
3698 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3699 max_zombies
= max (nzombies
, max_zombies
);
3704 return Flist (7, total
);
3708 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3709 only interesting objects referenced from glyphs are strings. */
3712 mark_glyph_matrix (matrix
)
3713 struct glyph_matrix
*matrix
;
3715 struct glyph_row
*row
= matrix
->rows
;
3716 struct glyph_row
*end
= row
+ matrix
->nrows
;
3718 for (; row
< end
; ++row
)
3722 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3724 struct glyph
*glyph
= row
->glyphs
[area
];
3725 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3727 for (; glyph
< end_glyph
; ++glyph
)
3728 if (GC_STRINGP (glyph
->object
)
3729 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3730 mark_object (&glyph
->object
);
3736 /* Mark Lisp faces in the face cache C. */
3740 struct face_cache
*c
;
3745 for (i
= 0; i
< c
->used
; ++i
)
3747 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3751 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3752 mark_object (&face
->lface
[j
]);
3759 #ifdef HAVE_WINDOW_SYSTEM
3761 /* Mark Lisp objects in image IMG. */
3767 mark_object (&img
->spec
);
3769 if (!NILP (img
->data
.lisp_val
))
3770 mark_object (&img
->data
.lisp_val
);
3774 /* Mark Lisp objects in image cache of frame F. It's done this way so
3775 that we don't have to include xterm.h here. */
3778 mark_image_cache (f
)
3781 forall_images_in_image_cache (f
, mark_image
);
3784 #endif /* HAVE_X_WINDOWS */
3788 /* Mark reference to a Lisp_Object.
3789 If the object referred to has not been seen yet, recursively mark
3790 all the references contained in it. */
3792 #define LAST_MARKED_SIZE 500
3793 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3794 int last_marked_index
;
3797 mark_object (argptr
)
3798 Lisp_Object
*argptr
;
3800 Lisp_Object
*objptr
= argptr
;
3801 register Lisp_Object obj
;
3802 #ifdef GC_CHECK_MARKED_OBJECTS
3812 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3815 last_marked
[last_marked_index
++] = objptr
;
3816 if (last_marked_index
== LAST_MARKED_SIZE
)
3817 last_marked_index
= 0;
3819 /* Perform some sanity checks on the objects marked here. Abort if
3820 we encounter an object we know is bogus. This increases GC time
3821 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
3822 #ifdef GC_CHECK_MARKED_OBJECTS
3824 po
= (void *) XPNTR (obj
);
3826 /* Check that the object pointed to by PO is known to be a Lisp
3827 structure allocated from the heap. */
3828 #define CHECK_ALLOCATED() \
3830 m = mem_find (po); \
3835 /* Check that the object pointed to by PO is live, using predicate
3837 #define CHECK_LIVE(LIVEP) \
3839 if (!LIVEP (m, po)) \
3843 /* Check both of the above conditions. */
3844 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
3846 CHECK_ALLOCATED (); \
3847 CHECK_LIVE (LIVEP); \
3850 #else /* not GC_CHECK_MARKED_OBJECTS */
3852 #define CHECK_ALLOCATED() (void) 0
3853 #define CHECK_LIVE(LIVEP) (void) 0
3854 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
3856 #endif /* not GC_CHECK_MARKED_OBJECTS */
3858 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3862 register struct Lisp_String
*ptr
= XSTRING (obj
);
3863 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
3864 MARK_INTERVAL_TREE (ptr
->intervals
);
3869 case Lisp_Vectorlike
:
3870 #ifdef GC_CHECK_MARKED_OBJECTS
3872 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
3873 && po
!= &buffer_defaults
3874 && po
!= &buffer_local_symbols
)
3876 #endif /* GC_CHECK_MARKED_OBJECTS */
3878 if (GC_BUFFERP (obj
))
3880 if (!XMARKBIT (XBUFFER (obj
)->name
))
3882 #ifdef GC_CHECK_MARKED_OBJECTS
3883 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
3886 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
3891 #endif /* GC_CHECK_MARKED_OBJECTS */
3895 else if (GC_SUBRP (obj
))
3897 else if (GC_COMPILEDP (obj
))
3898 /* We could treat this just like a vector, but it is better to
3899 save the COMPILED_CONSTANTS element for last and avoid
3902 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3903 register EMACS_INT size
= ptr
->size
;
3904 /* See comment above under Lisp_Vector. */
3905 struct Lisp_Vector
*volatile ptr1
= ptr
;
3908 if (size
& ARRAY_MARK_FLAG
)
3909 break; /* Already marked */
3911 CHECK_LIVE (live_vector_p
);
3912 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3913 size
&= PSEUDOVECTOR_SIZE_MASK
;
3914 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
3916 if (i
!= COMPILED_CONSTANTS
)
3917 mark_object (&ptr1
->contents
[i
]);
3919 /* This cast should be unnecessary, but some Mips compiler complains
3920 (MIPS-ABI + SysVR4, DC/OSx, etc). */
3921 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
3924 else if (GC_FRAMEP (obj
))
3926 /* See comment above under Lisp_Vector for why this is volatile. */
3927 register struct frame
*volatile ptr
= XFRAME (obj
);
3928 register EMACS_INT size
= ptr
->size
;
3930 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
3931 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3933 CHECK_LIVE (live_vector_p
);
3934 mark_object (&ptr
->name
);
3935 mark_object (&ptr
->icon_name
);
3936 mark_object (&ptr
->title
);
3937 mark_object (&ptr
->focus_frame
);
3938 mark_object (&ptr
->selected_window
);
3939 mark_object (&ptr
->minibuffer_window
);
3940 mark_object (&ptr
->param_alist
);
3941 mark_object (&ptr
->scroll_bars
);
3942 mark_object (&ptr
->condemned_scroll_bars
);
3943 mark_object (&ptr
->menu_bar_items
);
3944 mark_object (&ptr
->face_alist
);
3945 mark_object (&ptr
->menu_bar_vector
);
3946 mark_object (&ptr
->buffer_predicate
);
3947 mark_object (&ptr
->buffer_list
);
3948 mark_object (&ptr
->menu_bar_window
);
3949 mark_object (&ptr
->tool_bar_window
);
3950 mark_face_cache (ptr
->face_cache
);
3951 #ifdef HAVE_WINDOW_SYSTEM
3952 mark_image_cache (ptr
);
3953 mark_object (&ptr
->desired_tool_bar_items
);
3954 mark_object (&ptr
->current_tool_bar_items
);
3955 mark_object (&ptr
->desired_tool_bar_string
);
3956 mark_object (&ptr
->current_tool_bar_string
);
3957 #endif /* HAVE_WINDOW_SYSTEM */
3959 else if (GC_BOOL_VECTOR_P (obj
))
3961 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3963 if (ptr
->size
& ARRAY_MARK_FLAG
)
3964 break; /* Already marked */
3965 CHECK_LIVE (live_vector_p
);
3966 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
3968 else if (GC_WINDOWP (obj
))
3970 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
3971 struct window
*w
= XWINDOW (obj
);
3972 register EMACS_INT size
= ptr
->size
;
3973 /* The reason we use ptr1 is to avoid an apparent hardware bug
3974 that happens occasionally on the FSF's HP 300s.
3975 The bug is that a2 gets clobbered by recursive calls to mark_object.
3976 The clobberage seems to happen during function entry,
3977 perhaps in the moveml instruction.
3978 Yes, this is a crock, but we have to do it. */
3979 struct Lisp_Vector
*volatile ptr1
= ptr
;
3982 /* Stop if already marked. */
3983 if (size
& ARRAY_MARK_FLAG
)
3987 CHECK_LIVE (live_vector_p
);
3988 ptr
->size
|= ARRAY_MARK_FLAG
;
3990 /* There is no Lisp data above The member CURRENT_MATRIX in
3991 struct WINDOW. Stop marking when that slot is reached. */
3993 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
3995 mark_object (&ptr1
->contents
[i
]);
3997 /* Mark glyphs for leaf windows. Marking window matrices is
3998 sufficient because frame matrices use the same glyph
4000 if (NILP (w
->hchild
)
4002 && w
->current_matrix
)
4004 mark_glyph_matrix (w
->current_matrix
);
4005 mark_glyph_matrix (w
->desired_matrix
);
4008 else if (GC_HASH_TABLE_P (obj
))
4010 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4011 EMACS_INT size
= h
->size
;
4013 /* Stop if already marked. */
4014 if (size
& ARRAY_MARK_FLAG
)
4018 CHECK_LIVE (live_vector_p
);
4019 h
->size
|= ARRAY_MARK_FLAG
;
4021 /* Mark contents. */
4022 mark_object (&h
->test
);
4023 mark_object (&h
->weak
);
4024 mark_object (&h
->rehash_size
);
4025 mark_object (&h
->rehash_threshold
);
4026 mark_object (&h
->hash
);
4027 mark_object (&h
->next
);
4028 mark_object (&h
->index
);
4029 mark_object (&h
->user_hash_function
);
4030 mark_object (&h
->user_cmp_function
);
4032 /* If hash table is not weak, mark all keys and values.
4033 For weak tables, mark only the vector. */
4034 if (GC_NILP (h
->weak
))
4035 mark_object (&h
->key_and_value
);
4037 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
4042 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4043 register EMACS_INT size
= ptr
->size
;
4044 /* The reason we use ptr1 is to avoid an apparent hardware bug
4045 that happens occasionally on the FSF's HP 300s.
4046 The bug is that a2 gets clobbered by recursive calls to mark_object.
4047 The clobberage seems to happen during function entry,
4048 perhaps in the moveml instruction.
4049 Yes, this is a crock, but we have to do it. */
4050 struct Lisp_Vector
*volatile ptr1
= ptr
;
4053 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4054 CHECK_LIVE (live_vector_p
);
4055 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4056 if (size
& PSEUDOVECTOR_FLAG
)
4057 size
&= PSEUDOVECTOR_SIZE_MASK
;
4059 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4060 mark_object (&ptr1
->contents
[i
]);
4066 /* See comment above under Lisp_Vector for why this is volatile. */
4067 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
4068 struct Lisp_Symbol
*ptrx
;
4070 if (XMARKBIT (ptr
->plist
)) break;
4071 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4073 mark_object ((Lisp_Object
*) &ptr
->value
);
4074 mark_object (&ptr
->function
);
4075 mark_object (&ptr
->plist
);
4077 if (!PURE_POINTER_P (ptr
->name
))
4078 MARK_STRING (ptr
->name
);
4079 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
4081 /* Note that we do not mark the obarray of the symbol.
4082 It is safe not to do so because nothing accesses that
4083 slot except to check whether it is nil. */
4087 /* For the benefit of the last_marked log. */
4088 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4089 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4090 XSETSYMBOL (obj
, ptrx
);
4091 /* We can't goto loop here because *objptr doesn't contain an
4092 actual Lisp_Object with valid datatype field. */
4099 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4100 switch (XMISCTYPE (obj
))
4102 case Lisp_Misc_Marker
:
4103 XMARK (XMARKER (obj
)->chain
);
4104 /* DO NOT mark thru the marker's chain.
4105 The buffer's markers chain does not preserve markers from gc;
4106 instead, markers are removed from the chain when freed by gc. */
4109 case Lisp_Misc_Buffer_Local_Value
:
4110 case Lisp_Misc_Some_Buffer_Local_Value
:
4112 register struct Lisp_Buffer_Local_Value
*ptr
4113 = XBUFFER_LOCAL_VALUE (obj
);
4114 if (XMARKBIT (ptr
->realvalue
)) break;
4115 XMARK (ptr
->realvalue
);
4116 /* If the cdr is nil, avoid recursion for the car. */
4117 if (EQ (ptr
->cdr
, Qnil
))
4119 objptr
= &ptr
->realvalue
;
4122 mark_object (&ptr
->realvalue
);
4123 mark_object (&ptr
->buffer
);
4124 mark_object (&ptr
->frame
);
4125 /* See comment above under Lisp_Vector for why not use ptr here. */
4126 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
4130 case Lisp_Misc_Intfwd
:
4131 case Lisp_Misc_Boolfwd
:
4132 case Lisp_Misc_Objfwd
:
4133 case Lisp_Misc_Buffer_Objfwd
:
4134 case Lisp_Misc_Kboard_Objfwd
:
4135 /* Don't bother with Lisp_Buffer_Objfwd,
4136 since all markable slots in current buffer marked anyway. */
4137 /* Don't need to do Lisp_Objfwd, since the places they point
4138 are protected with staticpro. */
4141 case Lisp_Misc_Overlay
:
4143 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4144 if (!XMARKBIT (ptr
->plist
))
4147 mark_object (&ptr
->start
);
4148 mark_object (&ptr
->end
);
4149 objptr
= &ptr
->plist
;
4162 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4163 if (XMARKBIT (ptr
->car
)) break;
4164 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
4166 /* If the cdr is nil, avoid recursion for the car. */
4167 if (EQ (ptr
->cdr
, Qnil
))
4172 mark_object (&ptr
->car
);
4173 /* See comment above under Lisp_Vector for why not use ptr here. */
4174 objptr
= &XCDR (obj
);
4179 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
4180 XMARK (XFLOAT (obj
)->type
);
4191 #undef CHECK_ALLOCATED
4192 #undef CHECK_ALLOCATED_AND_LIVE
4195 /* Mark the pointers in a buffer structure. */
4201 register struct buffer
*buffer
= XBUFFER (buf
);
4202 register Lisp_Object
*ptr
;
4203 Lisp_Object base_buffer
;
4205 /* This is the buffer's markbit */
4206 mark_object (&buffer
->name
);
4207 XMARK (buffer
->name
);
4209 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4211 if (CONSP (buffer
->undo_list
))
4214 tail
= buffer
->undo_list
;
4216 while (CONSP (tail
))
4218 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4220 if (XMARKBIT (ptr
->car
))
4223 if (GC_CONSP (ptr
->car
)
4224 && ! XMARKBIT (XCAR (ptr
->car
))
4225 && GC_MARKERP (XCAR (ptr
->car
)))
4227 XMARK (XCAR (ptr
->car
));
4228 mark_object (&XCDR (ptr
->car
));
4231 mark_object (&ptr
->car
);
4233 if (CONSP (ptr
->cdr
))
4239 mark_object (&XCDR (tail
));
4242 mark_object (&buffer
->undo_list
);
4244 for (ptr
= &buffer
->name
+ 1;
4245 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4249 /* If this is an indirect buffer, mark its base buffer. */
4250 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4252 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4253 mark_buffer (base_buffer
);
4258 /* Mark the pointers in the kboard objects. */
4265 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4267 if (kb
->kbd_macro_buffer
)
4268 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4270 mark_object (&kb
->Voverriding_terminal_local_map
);
4271 mark_object (&kb
->Vlast_command
);
4272 mark_object (&kb
->Vreal_last_command
);
4273 mark_object (&kb
->Vprefix_arg
);
4274 mark_object (&kb
->Vlast_prefix_arg
);
4275 mark_object (&kb
->kbd_queue
);
4276 mark_object (&kb
->defining_kbd_macro
);
4277 mark_object (&kb
->Vlast_kbd_macro
);
4278 mark_object (&kb
->Vsystem_key_alist
);
4279 mark_object (&kb
->system_key_syms
);
4280 mark_object (&kb
->Vdefault_minibuffer_frame
);
4285 /* Value is non-zero if OBJ will survive the current GC because it's
4286 either marked or does not need to be marked to survive. */
4294 switch (XGCTYPE (obj
))
4301 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4305 switch (XMISCTYPE (obj
))
4307 case Lisp_Misc_Marker
:
4308 survives_p
= XMARKBIT (obj
);
4311 case Lisp_Misc_Buffer_Local_Value
:
4312 case Lisp_Misc_Some_Buffer_Local_Value
:
4313 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4316 case Lisp_Misc_Intfwd
:
4317 case Lisp_Misc_Boolfwd
:
4318 case Lisp_Misc_Objfwd
:
4319 case Lisp_Misc_Buffer_Objfwd
:
4320 case Lisp_Misc_Kboard_Objfwd
:
4324 case Lisp_Misc_Overlay
:
4325 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4335 struct Lisp_String
*s
= XSTRING (obj
);
4336 survives_p
= STRING_MARKED_P (s
);
4340 case Lisp_Vectorlike
:
4341 if (GC_BUFFERP (obj
))
4342 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4343 else if (GC_SUBRP (obj
))
4346 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4350 survives_p
= XMARKBIT (XCAR (obj
));
4354 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4361 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4366 /* Sweep: find all structures not marked, and free them. */
4371 /* Remove or mark entries in weak hash tables.
4372 This must be done before any object is unmarked. */
4373 sweep_weak_hash_tables ();
4377 /* Put all unmarked conses on free list */
4379 register struct cons_block
*cblk
;
4380 struct cons_block
**cprev
= &cons_block
;
4381 register int lim
= cons_block_index
;
4382 register int num_free
= 0, num_used
= 0;
4386 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4390 for (i
= 0; i
< lim
; i
++)
4391 if (!XMARKBIT (cblk
->conses
[i
].car
))
4394 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4395 cons_free_list
= &cblk
->conses
[i
];
4397 cons_free_list
->car
= Vdead
;
4403 XUNMARK (cblk
->conses
[i
].car
);
4405 lim
= CONS_BLOCK_SIZE
;
4406 /* If this block contains only free conses and we have already
4407 seen more than two blocks worth of free conses then deallocate
4409 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4411 *cprev
= cblk
->next
;
4412 /* Unhook from the free list. */
4413 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4419 num_free
+= this_free
;
4420 cprev
= &cblk
->next
;
4423 total_conses
= num_used
;
4424 total_free_conses
= num_free
;
4427 /* Put all unmarked floats on free list */
4429 register struct float_block
*fblk
;
4430 struct float_block
**fprev
= &float_block
;
4431 register int lim
= float_block_index
;
4432 register int num_free
= 0, num_used
= 0;
4434 float_free_list
= 0;
4436 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4440 for (i
= 0; i
< lim
; i
++)
4441 if (!XMARKBIT (fblk
->floats
[i
].type
))
4444 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4445 float_free_list
= &fblk
->floats
[i
];
4447 float_free_list
->type
= Vdead
;
4453 XUNMARK (fblk
->floats
[i
].type
);
4455 lim
= FLOAT_BLOCK_SIZE
;
4456 /* If this block contains only free floats and we have already
4457 seen more than two blocks worth of free floats then deallocate
4459 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4461 *fprev
= fblk
->next
;
4462 /* Unhook from the free list. */
4463 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4469 num_free
+= this_free
;
4470 fprev
= &fblk
->next
;
4473 total_floats
= num_used
;
4474 total_free_floats
= num_free
;
4477 /* Put all unmarked intervals on free list */
4479 register struct interval_block
*iblk
;
4480 struct interval_block
**iprev
= &interval_block
;
4481 register int lim
= interval_block_index
;
4482 register int num_free
= 0, num_used
= 0;
4484 interval_free_list
= 0;
4486 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4491 for (i
= 0; i
< lim
; i
++)
4493 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4495 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4496 interval_free_list
= &iblk
->intervals
[i
];
4502 XUNMARK (iblk
->intervals
[i
].plist
);
4505 lim
= INTERVAL_BLOCK_SIZE
;
4506 /* If this block contains only free intervals and we have already
4507 seen more than two blocks worth of free intervals then
4508 deallocate this block. */
4509 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4511 *iprev
= iblk
->next
;
4512 /* Unhook from the free list. */
4513 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4515 n_interval_blocks
--;
4519 num_free
+= this_free
;
4520 iprev
= &iblk
->next
;
4523 total_intervals
= num_used
;
4524 total_free_intervals
= num_free
;
4527 /* Put all unmarked symbols on free list */
4529 register struct symbol_block
*sblk
;
4530 struct symbol_block
**sprev
= &symbol_block
;
4531 register int lim
= symbol_block_index
;
4532 register int num_free
= 0, num_used
= 0;
4534 symbol_free_list
= 0;
4536 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4540 for (i
= 0; i
< lim
; i
++)
4541 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4543 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4544 symbol_free_list
= &sblk
->symbols
[i
];
4546 symbol_free_list
->function
= Vdead
;
4553 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4554 UNMARK_STRING (sblk
->symbols
[i
].name
);
4555 XUNMARK (sblk
->symbols
[i
].plist
);
4557 lim
= SYMBOL_BLOCK_SIZE
;
4558 /* If this block contains only free symbols and we have already
4559 seen more than two blocks worth of free symbols then deallocate
4561 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4563 *sprev
= sblk
->next
;
4564 /* Unhook from the free list. */
4565 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4571 num_free
+= this_free
;
4572 sprev
= &sblk
->next
;
4575 total_symbols
= num_used
;
4576 total_free_symbols
= num_free
;
4579 /* Put all unmarked misc's on free list.
4580 For a marker, first unchain it from the buffer it points into. */
4582 register struct marker_block
*mblk
;
4583 struct marker_block
**mprev
= &marker_block
;
4584 register int lim
= marker_block_index
;
4585 register int num_free
= 0, num_used
= 0;
4587 marker_free_list
= 0;
4589 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4593 EMACS_INT already_free
= -1;
4595 for (i
= 0; i
< lim
; i
++)
4597 Lisp_Object
*markword
;
4598 switch (mblk
->markers
[i
].u_marker
.type
)
4600 case Lisp_Misc_Marker
:
4601 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4603 case Lisp_Misc_Buffer_Local_Value
:
4604 case Lisp_Misc_Some_Buffer_Local_Value
:
4605 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4607 case Lisp_Misc_Overlay
:
4608 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4610 case Lisp_Misc_Free
:
4611 /* If the object was already free, keep it
4612 on the free list. */
4613 markword
= (Lisp_Object
*) &already_free
;
4619 if (markword
&& !XMARKBIT (*markword
))
4622 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4624 /* tem1 avoids Sun compiler bug */
4625 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4626 XSETMARKER (tem
, tem1
);
4627 unchain_marker (tem
);
4629 /* Set the type of the freed object to Lisp_Misc_Free.
4630 We could leave the type alone, since nobody checks it,
4631 but this might catch bugs faster. */
4632 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4633 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4634 marker_free_list
= &mblk
->markers
[i
];
4641 XUNMARK (*markword
);
4644 lim
= MARKER_BLOCK_SIZE
;
4645 /* If this block contains only free markers and we have already
4646 seen more than two blocks worth of free markers then deallocate
4648 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4650 *mprev
= mblk
->next
;
4651 /* Unhook from the free list. */
4652 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4658 num_free
+= this_free
;
4659 mprev
= &mblk
->next
;
4663 total_markers
= num_used
;
4664 total_free_markers
= num_free
;
4667 /* Free all unmarked buffers */
4669 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4672 if (!XMARKBIT (buffer
->name
))
4675 prev
->next
= buffer
->next
;
4677 all_buffers
= buffer
->next
;
4678 next
= buffer
->next
;
4684 XUNMARK (buffer
->name
);
4685 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4686 prev
= buffer
, buffer
= buffer
->next
;
4690 /* Free all unmarked vectors */
4692 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4693 total_vector_size
= 0;
4696 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4699 prev
->next
= vector
->next
;
4701 all_vectors
= vector
->next
;
4702 next
= vector
->next
;
4710 vector
->size
&= ~ARRAY_MARK_FLAG
;
4711 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4712 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4714 total_vector_size
+= vector
->size
;
4715 prev
= vector
, vector
= vector
->next
;
4723 /* Debugging aids. */
4725 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4726 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4727 This may be helpful in debugging Emacs's memory usage.\n\
4728 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4733 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4738 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4739 "Return a list of counters that measure how much consing there has been.\n\
4740 Each of these counters increments for a certain kind of object.\n\
4741 The counters wrap around from the largest positive integer to zero.\n\
4742 Garbage collection does not decrease them.\n\
4743 The elements of the value are as follows:\n\
4744 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4745 All are in units of 1 = one object consed\n\
4746 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4748 MISCS include overlays, markers, and some internal types.\n\
4749 Frames, windows, buffers, and subprocesses count as vectors\n\
4750 (but the contents of a buffer's text do not count here).")
4753 Lisp_Object consed
[8];
4756 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4758 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4760 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4762 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4764 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4766 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4768 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4770 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4772 return Flist (8, consed
);
4775 int suppress_checking
;
4777 die (msg
, file
, line
)
4782 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4787 /* Initialization */
4792 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4796 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4799 pure_size
= PURESIZE
;
4802 ignore_warnings
= 1;
4803 #ifdef DOUG_LEA_MALLOC
4804 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4805 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4806 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4816 malloc_hysteresis
= 32;
4818 malloc_hysteresis
= 0;
4821 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4823 ignore_warnings
= 0;
4825 byte_stack_list
= 0;
4827 consing_since_gc
= 0;
4828 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4829 #ifdef VIRT_ADDR_VARIES
4830 malloc_sbrk_unused
= 1<<22; /* A large number */
4831 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4832 #endif /* VIRT_ADDR_VARIES */
4839 byte_stack_list
= 0;
4841 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4842 setjmp_tested_p
= longjmps_done
= 0;
4850 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4851 "*Number of bytes of consing between garbage collections.\n\
4852 Garbage collection can happen automatically once this many bytes have been\n\
4853 allocated since the last garbage collection. All data types count.\n\n\
4854 Garbage collection happens automatically only when `eval' is called.\n\n\
4855 By binding this temporarily to a large number, you can effectively\n\
4856 prevent garbage collection during a part of the program.");
4858 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4859 "Number of bytes of sharable Lisp data allocated so far.");
4861 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4862 "Number of cons cells that have been consed so far.");
4864 DEFVAR_INT ("floats-consed", &floats_consed
,
4865 "Number of floats that have been consed so far.");
4867 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4868 "Number of vector cells that have been consed so far.");
4870 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4871 "Number of symbols that have been consed so far.");
4873 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4874 "Number of string characters that have been consed so far.");
4876 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4877 "Number of miscellaneous objects that have been consed so far.");
4879 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4880 "Number of intervals that have been consed so far.");
4882 DEFVAR_INT ("strings-consed", &strings_consed
,
4883 "Number of strings that have been consed so far.");
4885 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4886 "Non-nil means loading Lisp code in order to dump an executable.\n\
4887 This means that certain objects should be allocated in shared (pure) space.");
4889 DEFVAR_INT ("undo-limit", &undo_limit
,
4890 "Keep no more undo information once it exceeds this size.\n\
4891 This limit is applied when garbage collection happens.\n\
4892 The size is counted as the number of bytes occupied,\n\
4893 which includes both saved text and other data.");
4896 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
4897 "Don't keep more than this much size of undo information.\n\
4898 A command which pushes past this size is itself forgotten.\n\
4899 This limit is applied when garbage collection happens.\n\
4900 The size is counted as the number of bytes occupied,\n\
4901 which includes both saved text and other data.");
4902 undo_strong_limit
= 30000;
4904 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
4905 "Non-nil means display messages at start and end of garbage collection.");
4906 garbage_collection_messages
= 0;
4908 /* We build this in advance because if we wait until we need it, we might
4909 not be able to allocate the memory to hold it. */
4911 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
4912 staticpro (&memory_signal_data
);
4914 staticpro (&Qgc_cons_threshold
);
4915 Qgc_cons_threshold
= intern ("gc-cons-threshold");
4917 staticpro (&Qchar_table_extra_slots
);
4918 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
4923 defsubr (&Smake_byte_code
);
4924 defsubr (&Smake_list
);
4925 defsubr (&Smake_vector
);
4926 defsubr (&Smake_char_table
);
4927 defsubr (&Smake_string
);
4928 defsubr (&Smake_bool_vector
);
4929 defsubr (&Smake_symbol
);
4930 defsubr (&Smake_marker
);
4931 defsubr (&Spurecopy
);
4932 defsubr (&Sgarbage_collect
);
4933 defsubr (&Smemory_limit
);
4934 defsubr (&Smemory_use_counts
);
4936 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4937 defsubr (&Sgc_status
);