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 /* Define this temporarily to hunt a bug. If defined, the size of
30 strings is always recorded in sdata structures so that it can be
31 compared to the sizes recorded in Lisp strings. */
33 #define GC_CHECK_STRING_BYTES 1
35 /* This file is part of the core Lisp implementation, and thus must
36 deal with the real data structures. If the Lisp implementation is
37 replaced, this file likely will not be used. */
39 #undef HIDE_LISP_IMPLEMENTATION
41 #include "intervals.h"
47 #include "blockinput.h"
49 #include "syssignal.h"
55 extern POINTER_TYPE
*sbrk ();
58 #ifdef DOUG_LEA_MALLOC
61 /* malloc.h #defines this as size_t, at least in glibc2. */
62 #ifndef __malloc_size_t
63 #define __malloc_size_t int
66 /* Specify maximum number of areas to mmap. It would be nice to use a
67 value that explicitly means "no limit". */
69 #define MMAP_MAX_AREAS 100000000
71 #else /* not DOUG_LEA_MALLOC */
73 /* The following come from gmalloc.c. */
75 #define __malloc_size_t size_t
76 extern __malloc_size_t _bytes_used
;
77 extern __malloc_size_t __malloc_extra_blocks
;
79 #endif /* not DOUG_LEA_MALLOC */
81 #define max(A,B) ((A) > (B) ? (A) : (B))
82 #define min(A,B) ((A) < (B) ? (A) : (B))
84 /* Macro to verify that storage intended for Lisp objects is not
85 out of range to fit in the space for a pointer.
86 ADDRESS is the start of the block, and SIZE
87 is the amount of space within which objects can start. */
89 #define VALIDATE_LISP_STORAGE(address, size) \
93 XSETCONS (val, (char *) address + size); \
94 if ((char *) XCONS (val) != (char *) address + size) \
101 /* Value of _bytes_used, when spare_memory was freed. */
103 static __malloc_size_t bytes_used_when_full
;
105 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
106 to a struct Lisp_String. */
108 #define MARK_STRING(S) ((S)->size |= MARKBIT)
109 #define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
110 #define STRING_MARKED_P(S) ((S)->size & MARKBIT)
112 /* Value is the number of bytes/chars of S, a pointer to a struct
113 Lisp_String. This must be used instead of STRING_BYTES (S) or
114 S->size during GC, because S->size contains the mark bit for
117 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
118 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
120 /* Number of bytes of consing done since the last gc. */
122 int consing_since_gc
;
124 /* Count the amount of consing of various sorts of space. */
126 int cons_cells_consed
;
128 int vector_cells_consed
;
130 int string_chars_consed
;
131 int misc_objects_consed
;
132 int intervals_consed
;
135 /* Number of bytes of consing since GC before another GC should be done. */
137 int gc_cons_threshold
;
139 /* Nonzero during GC. */
143 /* Nonzero means display messages at beginning and end of GC. */
145 int garbage_collection_messages
;
147 #ifndef VIRT_ADDR_VARIES
149 #endif /* VIRT_ADDR_VARIES */
150 int malloc_sbrk_used
;
152 #ifndef VIRT_ADDR_VARIES
154 #endif /* VIRT_ADDR_VARIES */
155 int malloc_sbrk_unused
;
157 /* Two limits controlling how much undo information to keep. */
160 int undo_strong_limit
;
162 /* Number of live and free conses etc. */
164 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
165 static int total_free_conses
, total_free_markers
, total_free_symbols
;
166 static int total_free_floats
, total_floats
;
168 /* Points to memory space allocated as "spare", to be freed if we run
171 static char *spare_memory
;
173 /* Amount of spare memory to keep in reserve. */
175 #define SPARE_MEMORY (1 << 14)
177 /* Number of extra blocks malloc should get when it needs more core. */
179 static int malloc_hysteresis
;
181 /* Non-nil means defun should do purecopy on the function definition. */
183 Lisp_Object Vpurify_flag
;
187 /* Force it into data space! */
189 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,};
190 #define PUREBEG (char *) pure
192 #else /* not HAVE_SHM */
194 #define pure PURE_SEG_BITS /* Use shared memory segment */
195 #define PUREBEG (char *)PURE_SEG_BITS
197 /* This variable is used only by the XPNTR macro when HAVE_SHM is
198 defined. If we used the PURESIZE macro directly there, that would
199 make most of Emacs dependent on puresize.h, which we don't want -
200 you should be able to change that without too much recompilation.
201 So map_in_data initializes pure_size, and the dependencies work
206 #endif /* not HAVE_SHM */
208 /* Value is non-zero if P points into pure space. */
210 #define PURE_POINTER_P(P) \
211 (((PNTR_COMPARISON_TYPE) (P) \
212 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
213 && ((PNTR_COMPARISON_TYPE) (P) \
214 >= (PNTR_COMPARISON_TYPE) pure))
216 /* Index in pure at which next pure object will be allocated.. */
220 /* If nonzero, this is a warning delivered by malloc and not yet
223 char *pending_malloc_warning
;
225 /* Pre-computed signal argument for use when memory is exhausted. */
227 Lisp_Object memory_signal_data
;
229 /* Maximum amount of C stack to save when a GC happens. */
231 #ifndef MAX_SAVE_STACK
232 #define MAX_SAVE_STACK 16000
235 /* Buffer in which we save a copy of the C stack at each GC. */
240 /* Non-zero means ignore malloc warnings. Set during initialization.
241 Currently not used. */
245 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
247 static void mark_buffer
P_ ((Lisp_Object
));
248 static void mark_kboards
P_ ((void));
249 static void gc_sweep
P_ ((void));
250 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
251 static void mark_face_cache
P_ ((struct face_cache
*));
253 #ifdef HAVE_WINDOW_SYSTEM
254 static void mark_image
P_ ((struct image
*));
255 static void mark_image_cache
P_ ((struct frame
*));
256 #endif /* HAVE_WINDOW_SYSTEM */
258 static struct Lisp_String
*allocate_string
P_ ((void));
259 static void compact_small_strings
P_ ((void));
260 static void free_large_strings
P_ ((void));
261 static void sweep_strings
P_ ((void));
263 extern int message_enable_multibyte
;
265 /* When scanning the C stack for live Lisp objects, Emacs keeps track
266 of what memory allocated via lisp_malloc is intended for what
267 purpose. This enumeration specifies the type of memory. */
283 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
284 #include <stdio.h> /* For fprintf. */
287 /* A unique object in pure space used to make some Lisp objects
288 on free lists recognizable in O(1). */
293 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
294 static void lisp_free
P_ ((POINTER_TYPE
*));
295 static void mark_stack
P_ ((void));
296 static void init_stack
P_ ((Lisp_Object
*));
297 static int live_vector_p
P_ ((struct mem_node
*, void *));
298 static int live_buffer_p
P_ ((struct mem_node
*, void *));
299 static int live_string_p
P_ ((struct mem_node
*, void *));
300 static int live_cons_p
P_ ((struct mem_node
*, void *));
301 static int live_symbol_p
P_ ((struct mem_node
*, void *));
302 static int live_float_p
P_ ((struct mem_node
*, void *));
303 static int live_misc_p
P_ ((struct mem_node
*, void *));
304 static void mark_maybe_object
P_ ((Lisp_Object
));
305 static void mark_memory
P_ ((void *, void *));
306 static void mem_init
P_ ((void));
307 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
308 static void mem_insert_fixup
P_ ((struct mem_node
*));
309 static void mem_rotate_left
P_ ((struct mem_node
*));
310 static void mem_rotate_right
P_ ((struct mem_node
*));
311 static void mem_delete
P_ ((struct mem_node
*));
312 static void mem_delete_fixup
P_ ((struct mem_node
*));
313 static INLINE
struct mem_node
*mem_find
P_ ((void *));
315 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
316 static void check_gcpros
P_ ((void));
319 #endif /* GC_MARK_STACK != 0 */
322 /************************************************************************
324 ************************************************************************/
326 /* Write STR to Vstandard_output plus some advice on how to free some
327 memory. Called when memory gets low. */
330 malloc_warning_1 (str
)
333 Fprinc (str
, Vstandard_output
);
334 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
335 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
336 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
341 /* Function malloc calls this if it finds we are near exhausting
348 pending_malloc_warning
= str
;
352 /* Display a malloc warning in buffer *Danger*. */
355 display_malloc_warning ()
357 register Lisp_Object val
;
359 val
= build_string (pending_malloc_warning
);
360 pending_malloc_warning
= 0;
361 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
365 #ifdef DOUG_LEA_MALLOC
366 # define BYTES_USED (mallinfo ().arena)
368 # define BYTES_USED _bytes_used
372 /* Called if malloc returns zero. */
377 #ifndef SYSTEM_MALLOC
378 bytes_used_when_full
= BYTES_USED
;
381 /* The first time we get here, free the spare memory. */
388 /* This used to call error, but if we've run out of memory, we could
389 get infinite recursion trying to build the string. */
391 Fsignal (Qnil
, memory_signal_data
);
395 /* Called if we can't allocate relocatable space for a buffer. */
398 buffer_memory_full ()
400 /* If buffers use the relocating allocator, no need to free
401 spare_memory, because we may have plenty of malloc space left
402 that we could get, and if we don't, the malloc that fails will
403 itself cause spare_memory to be freed. If buffers don't use the
404 relocating allocator, treat this like any other failing
411 /* This used to call error, but if we've run out of memory, we could
412 get infinite recursion trying to build the string. */
414 Fsignal (Qerror
, memory_signal_data
);
418 /* Like malloc but check for no memory and block interrupt input.. */
424 register POINTER_TYPE
*val
;
427 val
= (POINTER_TYPE
*) malloc (size
);
436 /* Like realloc but check for no memory and block interrupt input.. */
439 xrealloc (block
, size
)
443 register POINTER_TYPE
*val
;
446 /* We must call malloc explicitly when BLOCK is 0, since some
447 reallocs don't do this. */
449 val
= (POINTER_TYPE
*) malloc (size
);
451 val
= (POINTER_TYPE
*) realloc (block
, size
);
454 if (!val
&& size
) memory_full ();
459 /* Like free but block interrupt input.. */
471 /* Like strdup, but uses xmalloc. */
477 size_t len
= strlen (s
) + 1;
478 char *p
= (char *) xmalloc (len
);
484 /* Like malloc but used for allocating Lisp data. NBYTES is the
485 number of bytes to allocate, TYPE describes the intended use of the
486 allcated memory block (for strings, for conses, ...). */
488 static POINTER_TYPE
*
489 lisp_malloc (nbytes
, type
)
496 val
= (void *) malloc (nbytes
);
499 if (val
&& type
!= MEM_TYPE_NON_LISP
)
500 mem_insert (val
, (char *) val
+ nbytes
, type
);
510 /* Return a new buffer structure allocated from the heap with
511 a call to lisp_malloc. */
516 return (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
521 /* Free BLOCK. This must be called to free memory allocated with a
522 call to lisp_malloc. */
531 mem_delete (mem_find (block
));
537 /* Arranging to disable input signals while we're in malloc.
539 This only works with GNU malloc. To help out systems which can't
540 use GNU malloc, all the calls to malloc, realloc, and free
541 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
542 pairs; unfortunately, we have no idea what C library functions
543 might call malloc, so we can't really protect them unless you're
544 using GNU malloc. Fortunately, most of the major operating can use
547 #ifndef SYSTEM_MALLOC
548 #ifndef DOUG_LEA_MALLOC
549 extern void * (*__malloc_hook
) P_ ((size_t));
550 extern void * (*__realloc_hook
) P_ ((void *, size_t));
551 extern void (*__free_hook
) P_ ((void *));
552 /* Else declared in malloc.h, perhaps with an extra arg. */
553 #endif /* DOUG_LEA_MALLOC */
554 static void * (*old_malloc_hook
) ();
555 static void * (*old_realloc_hook
) ();
556 static void (*old_free_hook
) ();
558 /* This function is used as the hook for free to call. */
561 emacs_blocked_free (ptr
)
565 __free_hook
= old_free_hook
;
567 /* If we released our reserve (due to running out of memory),
568 and we have a fair amount free once again,
569 try to set aside another reserve in case we run out once more. */
570 if (spare_memory
== 0
571 /* Verify there is enough space that even with the malloc
572 hysteresis this call won't run out again.
573 The code here is correct as long as SPARE_MEMORY
574 is substantially larger than the block size malloc uses. */
575 && (bytes_used_when_full
576 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
577 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
579 __free_hook
= emacs_blocked_free
;
584 /* If we released our reserve (due to running out of memory),
585 and we have a fair amount free once again,
586 try to set aside another reserve in case we run out once more.
588 This is called when a relocatable block is freed in ralloc.c. */
591 refill_memory_reserve ()
593 if (spare_memory
== 0)
594 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
598 /* This function is the malloc hook that Emacs uses. */
601 emacs_blocked_malloc (size
)
607 __malloc_hook
= old_malloc_hook
;
608 #ifdef DOUG_LEA_MALLOC
609 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
611 __malloc_extra_blocks
= malloc_hysteresis
;
613 value
= (void *) malloc (size
);
614 __malloc_hook
= emacs_blocked_malloc
;
621 /* This function is the realloc hook that Emacs uses. */
624 emacs_blocked_realloc (ptr
, size
)
631 __realloc_hook
= old_realloc_hook
;
632 value
= (void *) realloc (ptr
, size
);
633 __realloc_hook
= emacs_blocked_realloc
;
640 /* Called from main to set up malloc to use our hooks. */
643 uninterrupt_malloc ()
645 if (__free_hook
!= emacs_blocked_free
)
646 old_free_hook
= __free_hook
;
647 __free_hook
= emacs_blocked_free
;
649 if (__malloc_hook
!= emacs_blocked_malloc
)
650 old_malloc_hook
= __malloc_hook
;
651 __malloc_hook
= emacs_blocked_malloc
;
653 if (__realloc_hook
!= emacs_blocked_realloc
)
654 old_realloc_hook
= __realloc_hook
;
655 __realloc_hook
= emacs_blocked_realloc
;
658 #endif /* not SYSTEM_MALLOC */
662 /***********************************************************************
664 ***********************************************************************/
666 /* Number of intervals allocated in an interval_block structure.
667 The 1020 is 1024 minus malloc overhead. */
669 #define INTERVAL_BLOCK_SIZE \
670 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
672 /* Intervals are allocated in chunks in form of an interval_block
675 struct interval_block
677 struct interval_block
*next
;
678 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
681 /* Current interval block. Its `next' pointer points to older
684 struct interval_block
*interval_block
;
686 /* Index in interval_block above of the next unused interval
689 static int interval_block_index
;
691 /* Number of free and live intervals. */
693 static int total_free_intervals
, total_intervals
;
695 /* List of free intervals. */
697 INTERVAL interval_free_list
;
699 /* Total number of interval blocks now in use. */
701 int n_interval_blocks
;
704 /* Initialize interval allocation. */
710 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
712 interval_block
->next
= 0;
713 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
714 interval_block_index
= 0;
715 interval_free_list
= 0;
716 n_interval_blocks
= 1;
720 /* Return a new interval. */
727 if (interval_free_list
)
729 val
= interval_free_list
;
730 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
734 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
736 register struct interval_block
*newi
;
738 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
741 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
742 newi
->next
= interval_block
;
743 interval_block
= newi
;
744 interval_block_index
= 0;
747 val
= &interval_block
->intervals
[interval_block_index
++];
749 consing_since_gc
+= sizeof (struct interval
);
751 RESET_INTERVAL (val
);
756 /* Mark Lisp objects in interval I. */
759 mark_interval (i
, dummy
)
763 if (XMARKBIT (i
->plist
))
765 mark_object (&i
->plist
);
770 /* Mark the interval tree rooted in TREE. Don't call this directly;
771 use the macro MARK_INTERVAL_TREE instead. */
774 mark_interval_tree (tree
)
775 register INTERVAL tree
;
777 /* No need to test if this tree has been marked already; this
778 function is always called through the MARK_INTERVAL_TREE macro,
779 which takes care of that. */
781 /* XMARK expands to an assignment; the LHS of an assignment can't be
783 XMARK (tree
->up
.obj
);
785 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
789 /* Mark the interval tree rooted in I. */
791 #define MARK_INTERVAL_TREE(i) \
793 if (!NULL_INTERVAL_P (i) \
794 && ! XMARKBIT (i->up.obj)) \
795 mark_interval_tree (i); \
799 /* The oddity in the call to XUNMARK is necessary because XUNMARK
800 expands to an assignment to its argument, and most C compilers
801 don't support casts on the left operand of `='. */
803 #define UNMARK_BALANCE_INTERVALS(i) \
805 if (! NULL_INTERVAL_P (i)) \
807 XUNMARK ((i)->up.obj); \
808 (i) = balance_intervals (i); \
813 /* Number support. If NO_UNION_TYPE isn't in effect, we
814 can't create number objects in macros. */
822 obj
.s
.type
= Lisp_Int
;
827 /***********************************************************************
829 ***********************************************************************/
831 /* Lisp_Strings are allocated in string_block structures. When a new
832 string_block is allocated, all the Lisp_Strings it contains are
833 added to a free-list stiing_free_list. When a new Lisp_String is
834 needed, it is taken from that list. During the sweep phase of GC,
835 string_blocks that are entirely free are freed, except two which
838 String data is allocated from sblock structures. Strings larger
839 than LARGE_STRING_BYTES, get their own sblock, data for smaller
840 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
842 Sblocks consist internally of sdata structures, one for each
843 Lisp_String. The sdata structure points to the Lisp_String it
844 belongs to. The Lisp_String points back to the `u.data' member of
847 When a Lisp_String is freed during GC, it is put back on
848 string_free_list, and its `data' member and its sdata's `string'
849 pointer is set to null. The size of the string is recorded in the
850 `u.nbytes' member of the sdata. So, sdata structures that are no
851 longer used, can be easily recognized, and it's easy to compact the
852 sblocks of small strings which we do in compact_small_strings. */
854 /* Size in bytes of an sblock structure used for small strings. This
855 is 8192 minus malloc overhead. */
857 #define SBLOCK_SIZE 8188
859 /* Strings larger than this are considered large strings. String data
860 for large strings is allocated from individual sblocks. */
862 #define LARGE_STRING_BYTES 1024
864 /* Structure describing string memory sub-allocated from an sblock.
865 This is where the contents of Lisp strings are stored. */
869 /* Back-pointer to the string this sdata belongs to. If null, this
870 structure is free, and the NBYTES member of the union below
871 contains the string's byte size (the same value that STRING_BYTES
872 would return if STRING were non-null). If non-null, STRING_BYTES
873 (STRING) is the size of the data, and DATA contains the string's
875 struct Lisp_String
*string
;
877 #ifdef GC_CHECK_STRING_BYTES
880 unsigned char data
[1];
882 #define SDATA_NBYTES(S) (S)->nbytes
883 #define SDATA_DATA(S) (S)->data
885 #else /* not GC_CHECK_STRING_BYTES */
889 /* When STRING in non-null. */
890 unsigned char data
[1];
892 /* When STRING is null. */
897 #define SDATA_NBYTES(S) (S)->u.nbytes
898 #define SDATA_DATA(S) (S)->u.data
900 #endif /* not GC_CHECK_STRING_BYTES */
904 /* Structure describing a block of memory which is sub-allocated to
905 obtain string data memory for strings. Blocks for small strings
906 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
907 as large as needed. */
914 /* Pointer to the next free sdata block. This points past the end
915 of the sblock if there isn't any space left in this block. */
916 struct sdata
*next_free
;
919 struct sdata first_data
;
922 /* Number of Lisp strings in a string_block structure. The 1020 is
923 1024 minus malloc overhead. */
925 #define STRINGS_IN_STRING_BLOCK \
926 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
928 /* Structure describing a block from which Lisp_String structures
933 struct string_block
*next
;
934 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
937 /* Head and tail of the list of sblock structures holding Lisp string
938 data. We always allocate from current_sblock. The NEXT pointers
939 in the sblock structures go from oldest_sblock to current_sblock. */
941 static struct sblock
*oldest_sblock
, *current_sblock
;
943 /* List of sblocks for large strings. */
945 static struct sblock
*large_sblocks
;
947 /* List of string_block structures, and how many there are. */
949 static struct string_block
*string_blocks
;
950 static int n_string_blocks
;
952 /* Free-list of Lisp_Strings. */
954 static struct Lisp_String
*string_free_list
;
956 /* Number of live and free Lisp_Strings. */
958 static int total_strings
, total_free_strings
;
960 /* Number of bytes used by live strings. */
962 static int total_string_size
;
964 /* Given a pointer to a Lisp_String S which is on the free-list
965 string_free_list, return a pointer to its successor in the
968 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
970 /* Return a pointer to the sdata structure belonging to Lisp string S.
971 S must be live, i.e. S->data must not be null. S->data is actually
972 a pointer to the `u.data' member of its sdata structure; the
973 structure starts at a constant offset in front of that. */
975 #ifdef GC_CHECK_STRING_BYTES
977 #define SDATA_OF_STRING(S) \
978 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
979 - sizeof (EMACS_INT)))
981 #else /* not GC_CHECK_STRING_BYTES */
983 #define SDATA_OF_STRING(S) \
984 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
986 #endif /* not GC_CHECK_STRING_BYTES */
988 /* Value is the size of an sdata structure large enough to hold NBYTES
989 bytes of string data. The value returned includes a terminating
990 NUL byte, the size of the sdata structure, and padding. */
992 #ifdef GC_CHECK_STRING_BYTES
994 #define SDATA_SIZE(NBYTES) \
995 ((sizeof (struct Lisp_String *) \
997 + sizeof (EMACS_INT) \
998 + sizeof (EMACS_INT) - 1) \
999 & ~(sizeof (EMACS_INT) - 1))
1001 #else /* not GC_CHECK_STRING_BYTES */
1003 #define SDATA_SIZE(NBYTES) \
1004 ((sizeof (struct Lisp_String *) \
1006 + sizeof (EMACS_INT) - 1) \
1007 & ~(sizeof (EMACS_INT) - 1))
1009 #endif /* not GC_CHECK_STRING_BYTES */
1011 /* Initialize string allocation. Called from init_alloc_once. */
1016 total_strings
= total_free_strings
= total_string_size
= 0;
1017 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1018 string_blocks
= NULL
;
1019 n_string_blocks
= 0;
1020 string_free_list
= NULL
;
1024 #ifdef GC_CHECK_STRING_BYTES
1026 /* Check validity of all live Lisp strings' string_bytes member.
1027 Used for hunting a bug. */
1029 static int check_string_bytes_count
;
1032 check_string_bytes ()
1036 for (b
= large_sblocks
; b
; b
= b
->next
)
1038 struct Lisp_String
*s
= b
->first_data
.string
;
1039 if (s
&& GC_STRING_BYTES (s
) != SDATA_NBYTES (SDATA_OF_STRING (s
)))
1043 for (b
= oldest_sblock
; b
; b
= b
->next
)
1045 struct sdata
*from
, *end
, *from_end
;
1049 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1051 /* Compute the next FROM here because copying below may
1052 overwrite data we need to compute it. */
1055 /* Check that the string size recorded in the string is the
1056 same as the one recorded in the sdata structure. */
1058 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1062 nbytes
= GC_STRING_BYTES (from
->string
);
1064 nbytes
= SDATA_NBYTES (from
);
1066 nbytes
= SDATA_SIZE (nbytes
);
1067 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1072 #endif /* GC_CHECK_STRING_BYTES */
1075 /* Return a new Lisp_String. */
1077 static struct Lisp_String
*
1080 struct Lisp_String
*s
;
1082 /* If the free-list is empty, allocate a new string_block, and
1083 add all the Lisp_Strings in it to the free-list. */
1084 if (string_free_list
== NULL
)
1086 struct string_block
*b
;
1089 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1090 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
1091 bzero (b
, sizeof *b
);
1092 b
->next
= string_blocks
;
1096 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
1099 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1100 string_free_list
= s
;
1103 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
1106 /* Pop a Lisp_String off the free-list. */
1107 s
= string_free_list
;
1108 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1110 /* Probably not strictly necessary, but play it safe. */
1111 bzero (s
, sizeof *s
);
1113 --total_free_strings
;
1116 consing_since_gc
+= sizeof *s
;
1118 #ifdef GC_CHECK_STRING_BYTES
1119 if (++check_string_bytes_count
== 10)
1121 check_string_bytes_count
= 0;
1122 check_string_bytes ();
1130 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1131 plus a NUL byte at the end. Allocate an sdata structure for S, and
1132 set S->data to its `u.data' member. Store a NUL byte at the end of
1133 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1134 S->data if it was initially non-null. */
1137 allocate_string_data (s
, nchars
, nbytes
)
1138 struct Lisp_String
*s
;
1141 struct sdata
*data
, *old_data
;
1143 int needed
, old_nbytes
;
1145 /* Determine the number of bytes needed to store NBYTES bytes
1147 needed
= SDATA_SIZE (nbytes
);
1149 if (nbytes
> LARGE_STRING_BYTES
)
1151 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1153 #ifdef DOUG_LEA_MALLOC
1154 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1155 because mapped region contents are not preserved in
1157 mallopt (M_MMAP_MAX
, 0);
1160 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1162 #ifdef DOUG_LEA_MALLOC
1163 /* Back to a reasonable maximum of mmap'ed areas. */
1164 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1167 b
->next_free
= &b
->first_data
;
1168 b
->first_data
.string
= NULL
;
1169 b
->next
= large_sblocks
;
1172 else if (current_sblock
== NULL
1173 || (((char *) current_sblock
+ SBLOCK_SIZE
1174 - (char *) current_sblock
->next_free
)
1177 /* Not enough room in the current sblock. */
1178 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1179 b
->next_free
= &b
->first_data
;
1180 b
->first_data
.string
= NULL
;
1184 current_sblock
->next
= b
;
1192 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1193 old_nbytes
= GC_STRING_BYTES (s
);
1195 data
= b
->next_free
;
1197 s
->data
= SDATA_DATA (data
);
1198 #ifdef GC_CHECK_STRING_BYTES
1199 SDATA_NBYTES (data
) = nbytes
;
1202 s
->size_byte
= nbytes
;
1203 s
->data
[nbytes
] = '\0';
1204 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1206 /* If S had already data assigned, mark that as free by setting its
1207 string back-pointer to null, and recording the size of the data
1211 SDATA_NBYTES (old_data
) = old_nbytes
;
1212 old_data
->string
= NULL
;
1215 consing_since_gc
+= needed
;
1219 /* Sweep and compact strings. */
1224 struct string_block
*b
, *next
;
1225 struct string_block
*live_blocks
= NULL
;
1227 string_free_list
= NULL
;
1228 total_strings
= total_free_strings
= 0;
1229 total_string_size
= 0;
1231 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1232 for (b
= string_blocks
; b
; b
= next
)
1235 struct Lisp_String
*free_list_before
= string_free_list
;
1239 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1241 struct Lisp_String
*s
= b
->strings
+ i
;
1245 /* String was not on free-list before. */
1246 if (STRING_MARKED_P (s
))
1248 /* String is live; unmark it and its intervals. */
1251 if (!NULL_INTERVAL_P (s
->intervals
))
1252 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1255 total_string_size
+= STRING_BYTES (s
);
1259 /* String is dead. Put it on the free-list. */
1260 struct sdata
*data
= SDATA_OF_STRING (s
);
1262 /* Save the size of S in its sdata so that we know
1263 how large that is. Reset the sdata's string
1264 back-pointer so that we know it's free. */
1265 #ifdef GC_CHECK_STRING_BYTES
1266 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1269 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1271 data
->string
= NULL
;
1273 /* Reset the strings's `data' member so that we
1277 /* Put the string on the free-list. */
1278 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1279 string_free_list
= s
;
1285 /* S was on the free-list before. Put it there again. */
1286 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1287 string_free_list
= s
;
1292 /* Free blocks that contain free Lisp_Strings only, except
1293 the first two of them. */
1294 if (nfree
== STRINGS_IN_STRING_BLOCK
1295 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1299 string_free_list
= free_list_before
;
1303 total_free_strings
+= nfree
;
1304 b
->next
= live_blocks
;
1309 string_blocks
= live_blocks
;
1310 free_large_strings ();
1311 compact_small_strings ();
1315 /* Free dead large strings. */
1318 free_large_strings ()
1320 struct sblock
*b
, *next
;
1321 struct sblock
*live_blocks
= NULL
;
1323 for (b
= large_sblocks
; b
; b
= next
)
1327 if (b
->first_data
.string
== NULL
)
1331 b
->next
= live_blocks
;
1336 large_sblocks
= live_blocks
;
1340 /* Compact data of small strings. Free sblocks that don't contain
1341 data of live strings after compaction. */
1344 compact_small_strings ()
1346 struct sblock
*b
, *tb
, *next
;
1347 struct sdata
*from
, *to
, *end
, *tb_end
;
1348 struct sdata
*to_end
, *from_end
;
1350 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1351 to, and TB_END is the end of TB. */
1353 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1354 to
= &tb
->first_data
;
1356 /* Step through the blocks from the oldest to the youngest. We
1357 expect that old blocks will stabilize over time, so that less
1358 copying will happen this way. */
1359 for (b
= oldest_sblock
; b
; b
= b
->next
)
1362 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1364 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1366 /* Compute the next FROM here because copying below may
1367 overwrite data we need to compute it. */
1370 #ifdef GC_CHECK_STRING_BYTES
1371 /* Check that the string size recorded in the string is the
1372 same as the one recorded in the sdata structure. */
1374 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1376 #endif /* GC_CHECK_STRING_BYTES */
1379 nbytes
= GC_STRING_BYTES (from
->string
);
1381 nbytes
= SDATA_NBYTES (from
);
1383 nbytes
= SDATA_SIZE (nbytes
);
1384 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1386 /* FROM->string non-null means it's alive. Copy its data. */
1389 /* If TB is full, proceed with the next sblock. */
1390 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1391 if (to_end
> tb_end
)
1395 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1396 to
= &tb
->first_data
;
1397 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1400 /* Copy, and update the string's `data' pointer. */
1403 xassert (tb
!= b
|| to
<= from
);
1404 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1405 to
->string
->data
= SDATA_DATA (to
);
1408 /* Advance past the sdata we copied to. */
1414 /* The rest of the sblocks following TB don't contain live data, so
1415 we can free them. */
1416 for (b
= tb
->next
; b
; b
= next
)
1424 current_sblock
= tb
;
1428 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1429 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1430 Both LENGTH and INIT must be numbers.")
1432 Lisp_Object length
, init
;
1434 register Lisp_Object val
;
1435 register unsigned char *p
, *end
;
1438 CHECK_NATNUM (length
, 0);
1439 CHECK_NUMBER (init
, 1);
1442 if (SINGLE_BYTE_CHAR_P (c
))
1444 nbytes
= XINT (length
);
1445 val
= make_uninit_string (nbytes
);
1446 p
= XSTRING (val
)->data
;
1447 end
= p
+ XSTRING (val
)->size
;
1453 unsigned char str
[4];
1454 int len
= CHAR_STRING (c
, str
);
1456 nbytes
= len
* XINT (length
);
1457 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1458 p
= XSTRING (val
)->data
;
1462 bcopy (str
, p
, len
);
1472 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1473 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1474 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1476 Lisp_Object length
, init
;
1478 register Lisp_Object val
;
1479 struct Lisp_Bool_Vector
*p
;
1481 int length_in_chars
, length_in_elts
, bits_per_value
;
1483 CHECK_NATNUM (length
, 0);
1485 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1487 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1488 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1490 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1491 slot `size' of the struct Lisp_Bool_Vector. */
1492 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1493 p
= XBOOL_VECTOR (val
);
1495 /* Get rid of any bits that would cause confusion. */
1497 XSETBOOL_VECTOR (val
, p
);
1498 p
->size
= XFASTINT (length
);
1500 real_init
= (NILP (init
) ? 0 : -1);
1501 for (i
= 0; i
< length_in_chars
; i
++)
1502 p
->data
[i
] = real_init
;
1504 /* Clear the extraneous bits in the last byte. */
1505 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1506 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1507 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1513 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1514 of characters from the contents. This string may be unibyte or
1515 multibyte, depending on the contents. */
1518 make_string (contents
, nbytes
)
1522 register Lisp_Object val
;
1523 int nchars
, multibyte_nbytes
;
1525 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1526 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1527 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1528 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1529 /* CONTENTS contains no multibyte sequences or contains an invalid
1530 multibyte sequence. We must make unibyte string. */
1531 SET_STRING_BYTES (XSTRING (val
), -1);
1536 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1539 make_unibyte_string (contents
, length
)
1543 register Lisp_Object val
;
1544 val
= make_uninit_string (length
);
1545 bcopy (contents
, XSTRING (val
)->data
, length
);
1546 SET_STRING_BYTES (XSTRING (val
), -1);
1551 /* Make a multibyte string from NCHARS characters occupying NBYTES
1552 bytes at CONTENTS. */
1555 make_multibyte_string (contents
, nchars
, nbytes
)
1559 register Lisp_Object val
;
1560 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1561 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1566 /* Make a string from NCHARS characters occupying NBYTES bytes at
1567 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1570 make_string_from_bytes (contents
, nchars
, nbytes
)
1574 register Lisp_Object val
;
1575 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1576 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1577 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1578 SET_STRING_BYTES (XSTRING (val
), -1);
1583 /* Make a string from NCHARS characters occupying NBYTES bytes at
1584 CONTENTS. The argument MULTIBYTE controls whether to label the
1585 string as multibyte. */
1588 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1593 register Lisp_Object val
;
1594 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1595 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1597 SET_STRING_BYTES (XSTRING (val
), -1);
1602 /* Make a string from the data at STR, treating it as multibyte if the
1609 return make_string (str
, strlen (str
));
1613 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1614 occupying LENGTH bytes. */
1617 make_uninit_string (length
)
1621 val
= make_uninit_multibyte_string (length
, length
);
1622 SET_STRING_BYTES (XSTRING (val
), -1);
1627 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1628 which occupy NBYTES bytes. */
1631 make_uninit_multibyte_string (nchars
, nbytes
)
1635 struct Lisp_String
*s
;
1640 s
= allocate_string ();
1641 allocate_string_data (s
, nchars
, nbytes
);
1642 XSETSTRING (string
, s
);
1643 string_chars_consed
+= nbytes
;
1649 /***********************************************************************
1651 ***********************************************************************/
1653 /* We store float cells inside of float_blocks, allocating a new
1654 float_block with malloc whenever necessary. Float cells reclaimed
1655 by GC are put on a free list to be reallocated before allocating
1656 any new float cells from the latest float_block.
1658 Each float_block is just under 1020 bytes long, since malloc really
1659 allocates in units of powers of two and uses 4 bytes for its own
1662 #define FLOAT_BLOCK_SIZE \
1663 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1667 struct float_block
*next
;
1668 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1671 /* Current float_block. */
1673 struct float_block
*float_block
;
1675 /* Index of first unused Lisp_Float in the current float_block. */
1677 int float_block_index
;
1679 /* Total number of float blocks now in use. */
1683 /* Free-list of Lisp_Floats. */
1685 struct Lisp_Float
*float_free_list
;
1688 /* Initialze float allocation. */
1693 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1695 float_block
->next
= 0;
1696 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1697 float_block_index
= 0;
1698 float_free_list
= 0;
1703 /* Explicitly free a float cell by putting it on the free-list. */
1707 struct Lisp_Float
*ptr
;
1709 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1713 float_free_list
= ptr
;
1717 /* Return a new float object with value FLOAT_VALUE. */
1720 make_float (float_value
)
1723 register Lisp_Object val
;
1725 if (float_free_list
)
1727 /* We use the data field for chaining the free list
1728 so that we won't use the same field that has the mark bit. */
1729 XSETFLOAT (val
, float_free_list
);
1730 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1734 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1736 register struct float_block
*new;
1738 new = (struct float_block
*) lisp_malloc (sizeof *new,
1740 VALIDATE_LISP_STORAGE (new, sizeof *new);
1741 new->next
= float_block
;
1743 float_block_index
= 0;
1746 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1749 XFLOAT_DATA (val
) = float_value
;
1750 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1751 consing_since_gc
+= sizeof (struct Lisp_Float
);
1758 /***********************************************************************
1760 ***********************************************************************/
1762 /* We store cons cells inside of cons_blocks, allocating a new
1763 cons_block with malloc whenever necessary. Cons cells reclaimed by
1764 GC are put on a free list to be reallocated before allocating
1765 any new cons cells from the latest cons_block.
1767 Each cons_block is just under 1020 bytes long,
1768 since malloc really allocates in units of powers of two
1769 and uses 4 bytes for its own overhead. */
1771 #define CONS_BLOCK_SIZE \
1772 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1776 struct cons_block
*next
;
1777 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1780 /* Current cons_block. */
1782 struct cons_block
*cons_block
;
1784 /* Index of first unused Lisp_Cons in the current block. */
1786 int cons_block_index
;
1788 /* Free-list of Lisp_Cons structures. */
1790 struct Lisp_Cons
*cons_free_list
;
1792 /* Total number of cons blocks now in use. */
1797 /* Initialize cons allocation. */
1802 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1804 cons_block
->next
= 0;
1805 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1806 cons_block_index
= 0;
1812 /* Explicitly free a cons cell by putting it on the free-list. */
1816 struct Lisp_Cons
*ptr
;
1818 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1822 cons_free_list
= ptr
;
1826 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
1827 "Create a new cons, give it CAR and CDR as components, and return it.")
1829 Lisp_Object car
, cdr
;
1831 register Lisp_Object val
;
1835 /* We use the cdr for chaining the free list
1836 so that we won't use the same field that has the mark bit. */
1837 XSETCONS (val
, cons_free_list
);
1838 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
1842 if (cons_block_index
== CONS_BLOCK_SIZE
)
1844 register struct cons_block
*new;
1845 new = (struct cons_block
*) lisp_malloc (sizeof *new,
1847 VALIDATE_LISP_STORAGE (new, sizeof *new);
1848 new->next
= cons_block
;
1850 cons_block_index
= 0;
1853 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
1858 consing_since_gc
+= sizeof (struct Lisp_Cons
);
1859 cons_cells_consed
++;
1864 /* Make a list of 2, 3, 4 or 5 specified objects. */
1868 Lisp_Object arg1
, arg2
;
1870 return Fcons (arg1
, Fcons (arg2
, Qnil
));
1875 list3 (arg1
, arg2
, arg3
)
1876 Lisp_Object arg1
, arg2
, arg3
;
1878 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
1883 list4 (arg1
, arg2
, arg3
, arg4
)
1884 Lisp_Object arg1
, arg2
, arg3
, arg4
;
1886 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
1891 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
1892 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
1894 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
1895 Fcons (arg5
, Qnil
)))));
1899 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
1900 "Return a newly created list with specified arguments as elements.\n\
1901 Any number of arguments, even zero arguments, are allowed.")
1904 register Lisp_Object
*args
;
1906 register Lisp_Object val
;
1912 val
= Fcons (args
[nargs
], val
);
1918 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
1919 "Return a newly created list of length LENGTH, with each element being INIT.")
1921 register Lisp_Object length
, init
;
1923 register Lisp_Object val
;
1926 CHECK_NATNUM (length
, 0);
1927 size
= XFASTINT (length
);
1931 val
= Fcons (init
, val
);
1937 /***********************************************************************
1939 ***********************************************************************/
1941 /* Singly-linked list of all vectors. */
1943 struct Lisp_Vector
*all_vectors
;
1945 /* Total number of vector-like objects now in use. */
1950 /* Value is a pointer to a newly allocated Lisp_Vector structure
1951 with room for LEN Lisp_Objects. */
1953 struct Lisp_Vector
*
1954 allocate_vectorlike (len
)
1957 struct Lisp_Vector
*p
;
1960 #ifdef DOUG_LEA_MALLOC
1961 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1962 because mapped region contents are not preserved in
1964 mallopt (M_MMAP_MAX
, 0);
1967 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
1968 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
1970 #ifdef DOUG_LEA_MALLOC
1971 /* Back to a reasonable maximum of mmap'ed areas. */
1972 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1975 VALIDATE_LISP_STORAGE (p
, 0);
1976 consing_since_gc
+= nbytes
;
1977 vector_cells_consed
+= len
;
1979 p
->next
= all_vectors
;
1986 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
1987 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
1988 See also the function `vector'.")
1990 register Lisp_Object length
, init
;
1993 register EMACS_INT sizei
;
1995 register struct Lisp_Vector
*p
;
1997 CHECK_NATNUM (length
, 0);
1998 sizei
= XFASTINT (length
);
2000 p
= allocate_vectorlike (sizei
);
2002 for (index
= 0; index
< sizei
; index
++)
2003 p
->contents
[index
] = init
;
2005 XSETVECTOR (vector
, p
);
2010 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2011 "Return a newly created char-table, with purpose PURPOSE.\n\
2012 Each element is initialized to INIT, which defaults to nil.\n\
2013 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
2014 The property's value should be an integer between 0 and 10.")
2016 register Lisp_Object purpose
, init
;
2020 CHECK_SYMBOL (purpose
, 1);
2021 n
= Fget (purpose
, Qchar_table_extra_slots
);
2022 CHECK_NUMBER (n
, 0);
2023 if (XINT (n
) < 0 || XINT (n
) > 10)
2024 args_out_of_range (n
, Qnil
);
2025 /* Add 2 to the size for the defalt and parent slots. */
2026 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2028 XCHAR_TABLE (vector
)->top
= Qt
;
2029 XCHAR_TABLE (vector
)->parent
= Qnil
;
2030 XCHAR_TABLE (vector
)->purpose
= purpose
;
2031 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2036 /* Return a newly created sub char table with default value DEFALT.
2037 Since a sub char table does not appear as a top level Emacs Lisp
2038 object, we don't need a Lisp interface to make it. */
2041 make_sub_char_table (defalt
)
2045 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2046 XCHAR_TABLE (vector
)->top
= Qnil
;
2047 XCHAR_TABLE (vector
)->defalt
= defalt
;
2048 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2053 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2054 "Return a newly created vector with specified arguments as elements.\n\
2055 Any number of arguments, even zero arguments, are allowed.")
2060 register Lisp_Object len
, val
;
2062 register struct Lisp_Vector
*p
;
2064 XSETFASTINT (len
, nargs
);
2065 val
= Fmake_vector (len
, Qnil
);
2067 for (index
= 0; index
< nargs
; index
++)
2068 p
->contents
[index
] = args
[index
];
2073 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2074 "Create a byte-code object with specified arguments as elements.\n\
2075 The arguments should be the arglist, bytecode-string, constant vector,\n\
2076 stack size, (optional) doc string, and (optional) interactive spec.\n\
2077 The first four arguments are required; at most six have any\n\
2083 register Lisp_Object len
, val
;
2085 register struct Lisp_Vector
*p
;
2087 XSETFASTINT (len
, nargs
);
2088 if (!NILP (Vpurify_flag
))
2089 val
= make_pure_vector ((EMACS_INT
) nargs
);
2091 val
= Fmake_vector (len
, Qnil
);
2093 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2094 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2095 earlier because they produced a raw 8-bit string for byte-code
2096 and now such a byte-code string is loaded as multibyte while
2097 raw 8-bit characters converted to multibyte form. Thus, now we
2098 must convert them back to the original unibyte form. */
2099 args
[1] = Fstring_as_unibyte (args
[1]);
2102 for (index
= 0; index
< nargs
; index
++)
2104 if (!NILP (Vpurify_flag
))
2105 args
[index
] = Fpurecopy (args
[index
]);
2106 p
->contents
[index
] = args
[index
];
2108 XSETCOMPILED (val
, p
);
2114 /***********************************************************************
2116 ***********************************************************************/
2118 /* Each symbol_block is just under 1020 bytes long, since malloc
2119 really allocates in units of powers of two and uses 4 bytes for its
2122 #define SYMBOL_BLOCK_SIZE \
2123 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2127 struct symbol_block
*next
;
2128 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2131 /* Current symbol block and index of first unused Lisp_Symbol
2134 struct symbol_block
*symbol_block
;
2135 int symbol_block_index
;
2137 /* List of free symbols. */
2139 struct Lisp_Symbol
*symbol_free_list
;
2141 /* Total number of symbol blocks now in use. */
2143 int n_symbol_blocks
;
2146 /* Initialize symbol allocation. */
2151 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
2153 symbol_block
->next
= 0;
2154 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
2155 symbol_block_index
= 0;
2156 symbol_free_list
= 0;
2157 n_symbol_blocks
= 1;
2161 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2162 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2163 Its value and function definition are void, and its property list is nil.")
2167 register Lisp_Object val
;
2168 register struct Lisp_Symbol
*p
;
2170 CHECK_STRING (name
, 0);
2172 if (symbol_free_list
)
2174 XSETSYMBOL (val
, symbol_free_list
);
2175 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2179 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2181 struct symbol_block
*new;
2182 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2184 VALIDATE_LISP_STORAGE (new, sizeof *new);
2185 new->next
= symbol_block
;
2187 symbol_block_index
= 0;
2190 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2194 p
->name
= XSTRING (name
);
2197 p
->value
= Qunbound
;
2198 p
->function
= Qunbound
;
2200 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2207 /***********************************************************************
2208 Marker (Misc) Allocation
2209 ***********************************************************************/
2211 /* Allocation of markers and other objects that share that structure.
2212 Works like allocation of conses. */
2214 #define MARKER_BLOCK_SIZE \
2215 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2219 struct marker_block
*next
;
2220 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2223 struct marker_block
*marker_block
;
2224 int marker_block_index
;
2226 union Lisp_Misc
*marker_free_list
;
2228 /* Total number of marker blocks now in use. */
2230 int n_marker_blocks
;
2235 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2237 marker_block
->next
= 0;
2238 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2239 marker_block_index
= 0;
2240 marker_free_list
= 0;
2241 n_marker_blocks
= 1;
2244 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2251 if (marker_free_list
)
2253 XSETMISC (val
, marker_free_list
);
2254 marker_free_list
= marker_free_list
->u_free
.chain
;
2258 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2260 struct marker_block
*new;
2261 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2263 VALIDATE_LISP_STORAGE (new, sizeof *new);
2264 new->next
= marker_block
;
2266 marker_block_index
= 0;
2269 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2272 consing_since_gc
+= sizeof (union Lisp_Misc
);
2273 misc_objects_consed
++;
2277 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2278 "Return a newly allocated marker which does not point at any place.")
2281 register Lisp_Object val
;
2282 register struct Lisp_Marker
*p
;
2284 val
= allocate_misc ();
2285 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2291 p
->insertion_type
= 0;
2295 /* Put MARKER back on the free list after using it temporarily. */
2298 free_marker (marker
)
2301 unchain_marker (marker
);
2303 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2304 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2305 marker_free_list
= XMISC (marker
);
2307 total_free_markers
++;
2311 /* Return a newly created vector or string with specified arguments as
2312 elements. If all the arguments are characters that can fit
2313 in a string of events, make a string; otherwise, make a vector.
2315 Any number of arguments, even zero arguments, are allowed. */
2318 make_event_array (nargs
, args
)
2324 for (i
= 0; i
< nargs
; i
++)
2325 /* The things that fit in a string
2326 are characters that are in 0...127,
2327 after discarding the meta bit and all the bits above it. */
2328 if (!INTEGERP (args
[i
])
2329 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2330 return Fvector (nargs
, args
);
2332 /* Since the loop exited, we know that all the things in it are
2333 characters, so we can make a string. */
2337 result
= Fmake_string (make_number (nargs
), make_number (0));
2338 for (i
= 0; i
< nargs
; i
++)
2340 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2341 /* Move the meta bit to the right place for a string char. */
2342 if (XINT (args
[i
]) & CHAR_META
)
2343 XSTRING (result
)->data
[i
] |= 0x80;
2352 /************************************************************************
2354 ************************************************************************/
2359 /* Base address of stack. Set in main. */
2361 Lisp_Object
*stack_base
;
2363 /* A node in the red-black tree describing allocated memory containing
2364 Lisp data. Each such block is recorded with its start and end
2365 address when it is allocated, and removed from the tree when it
2368 A red-black tree is a balanced binary tree with the following
2371 1. Every node is either red or black.
2372 2. Every leaf is black.
2373 3. If a node is red, then both of its children are black.
2374 4. Every simple path from a node to a descendant leaf contains
2375 the same number of black nodes.
2376 5. The root is always black.
2378 When nodes are inserted into the tree, or deleted from the tree,
2379 the tree is "fixed" so that these properties are always true.
2381 A red-black tree with N internal nodes has height at most 2
2382 log(N+1). Searches, insertions and deletions are done in O(log N).
2383 Please see a text book about data structures for a detailed
2384 description of red-black trees. Any book worth its salt should
2389 struct mem_node
*left
, *right
, *parent
;
2391 /* Start and end of allocated region. */
2395 enum {MEM_BLACK
, MEM_RED
} color
;
2401 /* Root of the tree describing allocated Lisp memory. */
2403 static struct mem_node
*mem_root
;
2405 /* Sentinel node of the tree. */
2407 static struct mem_node mem_z
;
2408 #define MEM_NIL &mem_z
2411 /* Initialize this part of alloc.c. */
2416 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2417 mem_z
.parent
= NULL
;
2418 mem_z
.color
= MEM_BLACK
;
2419 mem_z
.start
= mem_z
.end
= NULL
;
2424 /* Value is a pointer to the mem_node containing START. Value is
2425 MEM_NIL if there is no node in the tree containing START. */
2427 static INLINE
struct mem_node
*
2433 /* Make the search always successful to speed up the loop below. */
2434 mem_z
.start
= start
;
2435 mem_z
.end
= (char *) start
+ 1;
2438 while (start
< p
->start
|| start
>= p
->end
)
2439 p
= start
< p
->start
? p
->left
: p
->right
;
2444 /* Insert a new node into the tree for a block of memory with start
2445 address START, end address END, and type TYPE. Value is a
2446 pointer to the node that was inserted. */
2448 static struct mem_node
*
2449 mem_insert (start
, end
, type
)
2453 struct mem_node
*c
, *parent
, *x
;
2455 /* See where in the tree a node for START belongs. In this
2456 particular application, it shouldn't happen that a node is already
2457 present. For debugging purposes, let's check that. */
2461 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2463 while (c
!= MEM_NIL
)
2465 if (start
>= c
->start
&& start
< c
->end
)
2468 c
= start
< c
->start
? c
->left
: c
->right
;
2471 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2473 while (c
!= MEM_NIL
)
2476 c
= start
< c
->start
? c
->left
: c
->right
;
2479 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2481 /* Create a new node. */
2482 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2487 x
->left
= x
->right
= MEM_NIL
;
2490 /* Insert it as child of PARENT or install it as root. */
2493 if (start
< parent
->start
)
2501 /* Re-establish red-black tree properties. */
2502 mem_insert_fixup (x
);
2507 /* Re-establish the red-black properties of the tree, and thereby
2508 balance the tree, after node X has been inserted; X is always red. */
2511 mem_insert_fixup (x
)
2514 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2516 /* X is red and its parent is red. This is a violation of
2517 red-black tree property #3. */
2519 if (x
->parent
== x
->parent
->parent
->left
)
2521 /* We're on the left side of our grandparent, and Y is our
2523 struct mem_node
*y
= x
->parent
->parent
->right
;
2525 if (y
->color
== MEM_RED
)
2527 /* Uncle and parent are red but should be black because
2528 X is red. Change the colors accordingly and proceed
2529 with the grandparent. */
2530 x
->parent
->color
= MEM_BLACK
;
2531 y
->color
= MEM_BLACK
;
2532 x
->parent
->parent
->color
= MEM_RED
;
2533 x
= x
->parent
->parent
;
2537 /* Parent and uncle have different colors; parent is
2538 red, uncle is black. */
2539 if (x
== x
->parent
->right
)
2542 mem_rotate_left (x
);
2545 x
->parent
->color
= MEM_BLACK
;
2546 x
->parent
->parent
->color
= MEM_RED
;
2547 mem_rotate_right (x
->parent
->parent
);
2552 /* This is the symmetrical case of above. */
2553 struct mem_node
*y
= x
->parent
->parent
->left
;
2555 if (y
->color
== MEM_RED
)
2557 x
->parent
->color
= MEM_BLACK
;
2558 y
->color
= MEM_BLACK
;
2559 x
->parent
->parent
->color
= MEM_RED
;
2560 x
= x
->parent
->parent
;
2564 if (x
== x
->parent
->left
)
2567 mem_rotate_right (x
);
2570 x
->parent
->color
= MEM_BLACK
;
2571 x
->parent
->parent
->color
= MEM_RED
;
2572 mem_rotate_left (x
->parent
->parent
);
2577 /* The root may have been changed to red due to the algorithm. Set
2578 it to black so that property #5 is satisfied. */
2579 mem_root
->color
= MEM_BLACK
;
2595 /* Turn y's left sub-tree into x's right sub-tree. */
2598 if (y
->left
!= MEM_NIL
)
2599 y
->left
->parent
= x
;
2601 /* Y's parent was x's parent. */
2603 y
->parent
= x
->parent
;
2605 /* Get the parent to point to y instead of x. */
2608 if (x
== x
->parent
->left
)
2609 x
->parent
->left
= y
;
2611 x
->parent
->right
= y
;
2616 /* Put x on y's left. */
2630 mem_rotate_right (x
)
2633 struct mem_node
*y
= x
->left
;
2636 if (y
->right
!= MEM_NIL
)
2637 y
->right
->parent
= x
;
2640 y
->parent
= x
->parent
;
2643 if (x
== x
->parent
->right
)
2644 x
->parent
->right
= y
;
2646 x
->parent
->left
= y
;
2657 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2663 struct mem_node
*x
, *y
;
2665 if (!z
|| z
== MEM_NIL
)
2668 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2673 while (y
->left
!= MEM_NIL
)
2677 if (y
->left
!= MEM_NIL
)
2682 x
->parent
= y
->parent
;
2685 if (y
== y
->parent
->left
)
2686 y
->parent
->left
= x
;
2688 y
->parent
->right
= x
;
2695 z
->start
= y
->start
;
2700 if (y
->color
== MEM_BLACK
)
2701 mem_delete_fixup (x
);
2706 /* Re-establish the red-black properties of the tree, after a
2710 mem_delete_fixup (x
)
2713 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2715 if (x
== x
->parent
->left
)
2717 struct mem_node
*w
= x
->parent
->right
;
2719 if (w
->color
== MEM_RED
)
2721 w
->color
= MEM_BLACK
;
2722 x
->parent
->color
= MEM_RED
;
2723 mem_rotate_left (x
->parent
);
2724 w
= x
->parent
->right
;
2727 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2734 if (w
->right
->color
== MEM_BLACK
)
2736 w
->left
->color
= MEM_BLACK
;
2738 mem_rotate_right (w
);
2739 w
= x
->parent
->right
;
2741 w
->color
= x
->parent
->color
;
2742 x
->parent
->color
= MEM_BLACK
;
2743 w
->right
->color
= MEM_BLACK
;
2744 mem_rotate_left (x
->parent
);
2750 struct mem_node
*w
= x
->parent
->left
;
2752 if (w
->color
== MEM_RED
)
2754 w
->color
= MEM_BLACK
;
2755 x
->parent
->color
= MEM_RED
;
2756 mem_rotate_right (x
->parent
);
2757 w
= x
->parent
->left
;
2760 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2767 if (w
->left
->color
== MEM_BLACK
)
2769 w
->right
->color
= MEM_BLACK
;
2771 mem_rotate_left (w
);
2772 w
= x
->parent
->left
;
2775 w
->color
= x
->parent
->color
;
2776 x
->parent
->color
= MEM_BLACK
;
2777 w
->left
->color
= MEM_BLACK
;
2778 mem_rotate_right (x
->parent
);
2784 x
->color
= MEM_BLACK
;
2788 /* Value is non-zero if P is a pointer to a live Lisp string on
2789 the heap. M is a pointer to the mem_block for P. */
2792 live_string_p (m
, p
)
2796 if (m
->type
== MEM_TYPE_STRING
)
2798 struct string_block
*b
= (struct string_block
*) m
->start
;
2799 int offset
= (char *) p
- (char *) &b
->strings
[0];
2801 /* P must point to the start of a Lisp_String structure, and it
2802 must not be on the free-list. */
2803 return (offset
% sizeof b
->strings
[0] == 0
2804 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2811 /* Value is non-zero if P is a pointer to a live Lisp cons on
2812 the heap. M is a pointer to the mem_block for P. */
2819 if (m
->type
== MEM_TYPE_CONS
)
2821 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2822 int offset
= (char *) p
- (char *) &b
->conses
[0];
2824 /* P must point to the start of a Lisp_Cons, not be
2825 one of the unused cells in the current cons block,
2826 and not be on the free-list. */
2827 return (offset
% sizeof b
->conses
[0] == 0
2829 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2830 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2837 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2838 the heap. M is a pointer to the mem_block for P. */
2841 live_symbol_p (m
, p
)
2845 if (m
->type
== MEM_TYPE_SYMBOL
)
2847 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2848 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2850 /* P must point to the start of a Lisp_Symbol, not be
2851 one of the unused cells in the current symbol block,
2852 and not be on the free-list. */
2853 return (offset
% sizeof b
->symbols
[0] == 0
2854 && (b
!= symbol_block
2855 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2856 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2863 /* Value is non-zero if P is a pointer to a live Lisp float on
2864 the heap. M is a pointer to the mem_block for P. */
2871 if (m
->type
== MEM_TYPE_FLOAT
)
2873 struct float_block
*b
= (struct float_block
*) m
->start
;
2874 int offset
= (char *) p
- (char *) &b
->floats
[0];
2876 /* P must point to the start of a Lisp_Float, not be
2877 one of the unused cells in the current float block,
2878 and not be on the free-list. */
2879 return (offset
% sizeof b
->floats
[0] == 0
2880 && (b
!= float_block
2881 || offset
/ sizeof b
->floats
[0] < float_block_index
)
2882 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
2889 /* Value is non-zero if P is a pointer to a live Lisp Misc on
2890 the heap. M is a pointer to the mem_block for P. */
2897 if (m
->type
== MEM_TYPE_MISC
)
2899 struct marker_block
*b
= (struct marker_block
*) m
->start
;
2900 int offset
= (char *) p
- (char *) &b
->markers
[0];
2902 /* P must point to the start of a Lisp_Misc, not be
2903 one of the unused cells in the current misc block,
2904 and not be on the free-list. */
2905 return (offset
% sizeof b
->markers
[0] == 0
2906 && (b
!= marker_block
2907 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
2908 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
2915 /* Value is non-zero if P is a pointer to a live vector-like object.
2916 M is a pointer to the mem_block for P. */
2919 live_vector_p (m
, p
)
2923 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
2927 /* Value is non-zero of P is a pointer to a live buffer. M is a
2928 pointer to the mem_block for P. */
2931 live_buffer_p (m
, p
)
2935 /* P must point to the start of the block, and the buffer
2936 must not have been killed. */
2937 return (m
->type
== MEM_TYPE_BUFFER
2939 && !NILP (((struct buffer
*) p
)->name
));
2943 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
2945 /* Array of objects that are kept alive because the C stack contains
2946 a pattern that looks like a reference to them . */
2948 #define MAX_ZOMBIES 10
2949 static Lisp_Object zombies
[MAX_ZOMBIES
];
2951 /* Number of zombie objects. */
2953 static int nzombies
;
2955 /* Number of garbage collections. */
2959 /* Average percentage of zombies per collection. */
2961 static double avg_zombies
;
2963 /* Max. number of live and zombie objects. */
2965 static int max_live
, max_zombies
;
2967 /* Average number of live objects per GC. */
2969 static double avg_live
;
2971 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
2972 "Show information about live and zombie objects.")
2975 Lisp_Object args
[7];
2976 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
2977 args
[1] = make_number (ngcs
);
2978 args
[2] = make_float (avg_live
);
2979 args
[3] = make_float (avg_zombies
);
2980 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
2981 args
[5] = make_number (max_live
);
2982 args
[6] = make_number (max_zombies
);
2983 return Fmessage (7, args
);
2986 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
2989 /* Mark OBJ if we can prove it's a Lisp_Object. */
2992 mark_maybe_object (obj
)
2995 void *po
= (void *) XPNTR (obj
);
2996 struct mem_node
*m
= mem_find (po
);
3002 switch (XGCTYPE (obj
))
3005 mark_p
= (live_string_p (m
, po
)
3006 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3010 mark_p
= (live_cons_p (m
, po
)
3011 && !XMARKBIT (XCONS (obj
)->car
));
3015 mark_p
= (live_symbol_p (m
, po
)
3016 && !XMARKBIT (XSYMBOL (obj
)->plist
));
3020 mark_p
= (live_float_p (m
, po
)
3021 && !XMARKBIT (XFLOAT (obj
)->type
));
3024 case Lisp_Vectorlike
:
3025 /* Note: can't check GC_BUFFERP before we know it's a
3026 buffer because checking that dereferences the pointer
3027 PO which might point anywhere. */
3028 if (live_vector_p (m
, po
))
3029 mark_p
= (!GC_SUBRP (obj
)
3030 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
3031 else if (live_buffer_p (m
, po
))
3032 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
3036 if (live_misc_p (m
, po
))
3038 switch (XMISCTYPE (obj
))
3040 case Lisp_Misc_Marker
:
3041 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
3044 case Lisp_Misc_Buffer_Local_Value
:
3045 case Lisp_Misc_Some_Buffer_Local_Value
:
3046 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
3049 case Lisp_Misc_Overlay
:
3050 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
3057 case Lisp_Type_Limit
:
3063 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3064 if (nzombies
< MAX_ZOMBIES
)
3065 zombies
[nzombies
] = *p
;
3073 /* Mark Lisp objects in the address range START..END. */
3076 mark_memory (start
, end
)
3081 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3085 /* Make START the pointer to the start of the memory region,
3086 if it isn't already. */
3094 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3095 mark_maybe_object (*p
);
3099 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3101 static int setjmp_tested_p
, longjmps_done
;
3103 #define SETJMP_WILL_LIKELY_WORK "\
3105 Emacs garbage collector has been changed to use conservative stack\n\
3106 marking. Emacs has determined that the method it uses to do the\n\
3107 marking will likely work on your system, but this isn't sure.\n\
3109 If you are a system-programmer, or can get the help of a local wizard\n\
3110 who is, please take a look at the function mark_stack in alloc.c, and\n\
3111 verify that the methods used are appropriate for your system.\n\
3113 Please mail the result to <gerd@gnu.org>.\n\
3116 #define SETJMP_WILL_NOT_WORK "\
3118 Emacs garbage collector has been changed to use conservative stack\n\
3119 marking. Emacs has determined that the default method it uses to do the\n\
3120 marking will not work on your system. We will need a system-dependent\n\
3121 solution for your system.\n\
3123 Please take a look at the function mark_stack in alloc.c, and\n\
3124 try to find a way to make it work on your system.\n\
3125 Please mail the result to <gerd@gnu.org>.\n\
3129 /* Perform a quick check if it looks like setjmp saves registers in a
3130 jmp_buf. Print a message to stderr saying so. When this test
3131 succeeds, this is _not_ a proof that setjmp is sufficient for
3132 conservative stack marking. Only the sources or a disassembly
3143 /* Arrange for X to be put in a register. */
3149 if (longjmps_done
== 1)
3151 /* Came here after the longjmp at the end of the function.
3153 If x == 1, the longjmp has restored the register to its
3154 value before the setjmp, and we can hope that setjmp
3155 saves all such registers in the jmp_buf, although that
3158 For other values of X, either something really strange is
3159 taking place, or the setjmp just didn't save the register. */
3162 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3165 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3172 if (longjmps_done
== 1)
3176 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3179 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3181 /* Abort if anything GCPRO'd doesn't survive the GC. */
3189 for (p
= gcprolist
; p
; p
= p
->next
)
3190 for (i
= 0; i
< p
->nvars
; ++i
)
3191 if (!survives_gc_p (p
->var
[i
]))
3195 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3202 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3203 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3205 fprintf (stderr
, " %d = ", i
);
3206 debug_print (zombies
[i
]);
3210 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3213 /* Mark live Lisp objects on the C stack.
3215 There are several system-dependent problems to consider when
3216 porting this to new architectures:
3220 We have to mark Lisp objects in CPU registers that can hold local
3221 variables or are used to pass parameters.
3223 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3224 something that either saves relevant registers on the stack, or
3225 calls mark_maybe_object passing it each register's contents.
3227 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3228 implementation assumes that calling setjmp saves registers we need
3229 to see in a jmp_buf which itself lies on the stack. This doesn't
3230 have to be true! It must be verified for each system, possibly
3231 by taking a look at the source code of setjmp.
3235 Architectures differ in the way their processor stack is organized.
3236 For example, the stack might look like this
3239 | Lisp_Object | size = 4
3241 | something else | size = 2
3243 | Lisp_Object | size = 4
3247 In such a case, not every Lisp_Object will be aligned equally. To
3248 find all Lisp_Object on the stack it won't be sufficient to walk
3249 the stack in steps of 4 bytes. Instead, two passes will be
3250 necessary, one starting at the start of the stack, and a second
3251 pass starting at the start of the stack + 2. Likewise, if the
3252 minimal alignment of Lisp_Objects on the stack is 1, four passes
3253 would be necessary, each one starting with one byte more offset
3254 from the stack start.
3256 The current code assumes by default that Lisp_Objects are aligned
3257 equally on the stack. */
3263 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3266 /* This trick flushes the register windows so that all the state of
3267 the process is contained in the stack. */
3272 /* Save registers that we need to see on the stack. We need to see
3273 registers used to hold register variables and registers used to
3275 #ifdef GC_SAVE_REGISTERS_ON_STACK
3276 GC_SAVE_REGISTERS_ON_STACK (end
);
3277 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3279 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3280 setjmp will definitely work, test it
3281 and print a message with the result
3283 if (!setjmp_tested_p
)
3285 setjmp_tested_p
= 1;
3288 #endif /* GC_SETJMP_WORKS */
3291 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3292 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3294 /* This assumes that the stack is a contiguous region in memory. If
3295 that's not the case, something has to be done here to iterate
3296 over the stack segments. */
3297 #if GC_LISP_OBJECT_ALIGNMENT == 1
3298 mark_memory (stack_base
, end
);
3299 mark_memory ((char *) stack_base
+ 1, end
);
3300 mark_memory ((char *) stack_base
+ 2, end
);
3301 mark_memory ((char *) stack_base
+ 3, end
);
3302 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3303 mark_memory (stack_base
, end
);
3304 mark_memory ((char *) stack_base
+ 2, end
);
3306 mark_memory (stack_base
, end
);
3309 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3315 #endif /* GC_MARK_STACK != 0 */
3319 /***********************************************************************
3320 Pure Storage Management
3321 ***********************************************************************/
3323 /* Return a string allocated in pure space. DATA is a buffer holding
3324 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3325 non-zero means make the result string multibyte.
3327 Must get an error if pure storage is full, since if it cannot hold
3328 a large string it may be able to hold conses that point to that
3329 string; then the string is not protected from gc. */
3332 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3338 struct Lisp_String
*s
;
3339 int string_size
, data_size
;
3341 #define PAD(SZ) (((SZ) + sizeof (EMACS_INT) - 1) & ~(sizeof (EMACS_INT) - 1))
3343 string_size
= PAD (sizeof (struct Lisp_String
));
3344 data_size
= PAD (nbytes
+ 1);
3348 if (pureptr
+ string_size
+ data_size
> PURESIZE
)
3349 error ("Pure Lisp storage exhausted");
3351 s
= (struct Lisp_String
*) (PUREBEG
+ pureptr
);
3352 pureptr
+= string_size
;
3353 s
->data
= (unsigned char *) (PUREBEG
+ pureptr
);
3354 pureptr
+= data_size
;
3357 s
->size_byte
= multibyte
? nbytes
: -1;
3358 bcopy (data
, s
->data
, nbytes
);
3359 s
->data
[nbytes
] = '\0';
3360 s
->intervals
= NULL_INTERVAL
;
3362 XSETSTRING (string
, s
);
3367 /* Return a cons allocated from pure space. Give it pure copies
3368 of CAR as car and CDR as cdr. */
3371 pure_cons (car
, cdr
)
3372 Lisp_Object car
, cdr
;
3374 register Lisp_Object
new;
3376 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
3377 error ("Pure Lisp storage exhausted");
3378 XSETCONS (new, PUREBEG
+ pureptr
);
3379 pureptr
+= sizeof (struct Lisp_Cons
);
3380 XCAR (new) = Fpurecopy (car
);
3381 XCDR (new) = Fpurecopy (cdr
);
3386 /* Value is a float object with value NUM allocated from pure space. */
3389 make_pure_float (num
)
3392 register Lisp_Object
new;
3394 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
3395 (double) boundary. Some architectures (like the sparc) require
3396 this, and I suspect that floats are rare enough that it's no
3397 tragedy for those that do. */
3400 char *p
= PUREBEG
+ pureptr
;
3404 alignment
= __alignof (struct Lisp_Float
);
3406 alignment
= sizeof (struct Lisp_Float
);
3409 alignment
= sizeof (struct Lisp_Float
);
3411 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
3412 pureptr
= p
- PUREBEG
;
3415 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
3416 error ("Pure Lisp storage exhausted");
3417 XSETFLOAT (new, PUREBEG
+ pureptr
);
3418 pureptr
+= sizeof (struct Lisp_Float
);
3419 XFLOAT_DATA (new) = num
;
3420 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
3425 /* Return a vector with room for LEN Lisp_Objects allocated from
3429 make_pure_vector (len
)
3432 register Lisp_Object
new;
3433 register EMACS_INT size
= (sizeof (struct Lisp_Vector
)
3434 + (len
- 1) * sizeof (Lisp_Object
));
3436 if (pureptr
+ size
> PURESIZE
)
3437 error ("Pure Lisp storage exhausted");
3439 XSETVECTOR (new, PUREBEG
+ pureptr
);
3441 XVECTOR (new)->size
= len
;
3446 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3447 "Make a copy of OBJECT in pure storage.\n\
3448 Recursively copies contents of vectors and cons cells.\n\
3449 Does not copy symbols. Copies strings without text properties.")
3451 register Lisp_Object obj
;
3453 if (NILP (Vpurify_flag
))
3456 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
3457 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
3461 return pure_cons (XCAR (obj
), XCDR (obj
));
3462 else if (FLOATP (obj
))
3463 return make_pure_float (XFLOAT_DATA (obj
));
3464 else if (STRINGP (obj
))
3465 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3466 STRING_BYTES (XSTRING (obj
)),
3467 STRING_MULTIBYTE (obj
));
3468 else if (COMPILEDP (obj
) || VECTORP (obj
))
3470 register struct Lisp_Vector
*vec
;
3471 register int i
, size
;
3473 size
= XVECTOR (obj
)->size
;
3474 if (size
& PSEUDOVECTOR_FLAG
)
3475 size
&= PSEUDOVECTOR_SIZE_MASK
;
3476 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3477 for (i
= 0; i
< size
; i
++)
3478 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3479 if (COMPILEDP (obj
))
3480 XSETCOMPILED (obj
, vec
);
3482 XSETVECTOR (obj
, vec
);
3485 else if (MARKERP (obj
))
3486 error ("Attempt to copy a marker to pure storage");
3493 /***********************************************************************
3495 ***********************************************************************/
3497 /* Recording what needs to be marked for gc. */
3499 struct gcpro
*gcprolist
;
3501 /* Addresses of staticpro'd variables. */
3503 #define NSTATICS 1024
3504 Lisp_Object
*staticvec
[NSTATICS
] = {0};
3506 /* Index of next unused slot in staticvec. */
3511 /* Put an entry in staticvec, pointing at the variable with address
3515 staticpro (varaddress
)
3516 Lisp_Object
*varaddress
;
3518 staticvec
[staticidx
++] = varaddress
;
3519 if (staticidx
>= NSTATICS
)
3527 struct catchtag
*next
;
3532 struct backtrace
*next
;
3533 Lisp_Object
*function
;
3534 Lisp_Object
*args
; /* Points to vector of args. */
3535 int nargs
; /* Length of vector. */
3536 /* If nargs is UNEVALLED, args points to slot holding list of
3543 /***********************************************************************
3545 ***********************************************************************/
3547 /* Temporarily prevent garbage collection. */
3550 inhibit_garbage_collection ()
3552 int count
= specpdl_ptr
- specpdl
;
3554 int nbits
= min (VALBITS
, BITS_PER_INT
);
3556 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3558 specbind (Qgc_cons_threshold
, number
);
3564 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3565 "Reclaim storage for Lisp objects no longer needed.\n\
3566 Returns info on amount of space in use:\n\
3567 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3568 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3569 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3570 (USED-STRINGS . FREE-STRINGS))\n\
3571 Garbage collection happens automatically if you cons more than\n\
3572 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3575 register struct gcpro
*tail
;
3576 register struct specbinding
*bind
;
3577 struct catchtag
*catch;
3578 struct handler
*handler
;
3579 register struct backtrace
*backlist
;
3580 char stack_top_variable
;
3583 Lisp_Object total
[7];
3585 /* In case user calls debug_print during GC,
3586 don't let that cause a recursive GC. */
3587 consing_since_gc
= 0;
3589 /* Save what's currently displayed in the echo area. */
3590 message_p
= push_message ();
3592 /* Save a copy of the contents of the stack, for debugging. */
3593 #if MAX_SAVE_STACK > 0
3594 if (NILP (Vpurify_flag
))
3596 i
= &stack_top_variable
- stack_bottom
;
3598 if (i
< MAX_SAVE_STACK
)
3600 if (stack_copy
== 0)
3601 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3602 else if (stack_copy_size
< i
)
3603 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3606 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3607 bcopy (stack_bottom
, stack_copy
, i
);
3609 bcopy (&stack_top_variable
, stack_copy
, i
);
3613 #endif /* MAX_SAVE_STACK > 0 */
3615 if (garbage_collection_messages
)
3616 message1_nolog ("Garbage collecting...");
3620 shrink_regexp_cache ();
3622 /* Don't keep undo information around forever. */
3624 register struct buffer
*nextb
= all_buffers
;
3628 /* If a buffer's undo list is Qt, that means that undo is
3629 turned off in that buffer. Calling truncate_undo_list on
3630 Qt tends to return NULL, which effectively turns undo back on.
3631 So don't call truncate_undo_list if undo_list is Qt. */
3632 if (! EQ (nextb
->undo_list
, Qt
))
3634 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3636 nextb
= nextb
->next
;
3642 /* clear_marks (); */
3644 /* Mark all the special slots that serve as the roots of accessibility.
3646 Usually the special slots to mark are contained in particular structures.
3647 Then we know no slot is marked twice because the structures don't overlap.
3648 In some cases, the structures point to the slots to be marked.
3649 For these, we use MARKBIT to avoid double marking of the slot. */
3651 for (i
= 0; i
< staticidx
; i
++)
3652 mark_object (staticvec
[i
]);
3654 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3655 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3658 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3659 for (i
= 0; i
< tail
->nvars
; i
++)
3660 if (!XMARKBIT (tail
->var
[i
]))
3662 /* Explicit casting prevents compiler warning about
3663 discarding the `volatile' qualifier. */
3664 mark_object ((Lisp_Object
*)&tail
->var
[i
]);
3665 XMARK (tail
->var
[i
]);
3670 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3672 mark_object (&bind
->symbol
);
3673 mark_object (&bind
->old_value
);
3675 for (catch = catchlist
; catch; catch = catch->next
)
3677 mark_object (&catch->tag
);
3678 mark_object (&catch->val
);
3680 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3682 mark_object (&handler
->handler
);
3683 mark_object (&handler
->var
);
3685 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3687 if (!XMARKBIT (*backlist
->function
))
3689 mark_object (backlist
->function
);
3690 XMARK (*backlist
->function
);
3692 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3695 i
= backlist
->nargs
- 1;
3697 if (!XMARKBIT (backlist
->args
[i
]))
3699 mark_object (&backlist
->args
[i
]);
3700 XMARK (backlist
->args
[i
]);
3705 /* Look thru every buffer's undo list
3706 for elements that update markers that were not marked,
3709 register struct buffer
*nextb
= all_buffers
;
3713 /* If a buffer's undo list is Qt, that means that undo is
3714 turned off in that buffer. Calling truncate_undo_list on
3715 Qt tends to return NULL, which effectively turns undo back on.
3716 So don't call truncate_undo_list if undo_list is Qt. */
3717 if (! EQ (nextb
->undo_list
, Qt
))
3719 Lisp_Object tail
, prev
;
3720 tail
= nextb
->undo_list
;
3722 while (CONSP (tail
))
3724 if (GC_CONSP (XCAR (tail
))
3725 && GC_MARKERP (XCAR (XCAR (tail
)))
3726 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3729 nextb
->undo_list
= tail
= XCDR (tail
);
3731 tail
= XCDR (prev
) = XCDR (tail
);
3741 nextb
= nextb
->next
;
3745 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3751 /* Clear the mark bits that we set in certain root slots. */
3753 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3754 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3755 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3756 for (i
= 0; i
< tail
->nvars
; i
++)
3757 XUNMARK (tail
->var
[i
]);
3760 unmark_byte_stack ();
3761 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3763 XUNMARK (*backlist
->function
);
3764 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3767 i
= backlist
->nargs
- 1;
3769 XUNMARK (backlist
->args
[i
]);
3771 XUNMARK (buffer_defaults
.name
);
3772 XUNMARK (buffer_local_symbols
.name
);
3774 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3780 /* clear_marks (); */
3783 consing_since_gc
= 0;
3784 if (gc_cons_threshold
< 10000)
3785 gc_cons_threshold
= 10000;
3787 if (garbage_collection_messages
)
3789 if (message_p
|| minibuf_level
> 0)
3792 message1_nolog ("Garbage collecting...done");
3797 total
[0] = Fcons (make_number (total_conses
),
3798 make_number (total_free_conses
));
3799 total
[1] = Fcons (make_number (total_symbols
),
3800 make_number (total_free_symbols
));
3801 total
[2] = Fcons (make_number (total_markers
),
3802 make_number (total_free_markers
));
3803 total
[3] = Fcons (make_number (total_string_size
),
3804 make_number (total_vector_size
));
3805 total
[4] = Fcons (make_number (total_floats
),
3806 make_number (total_free_floats
));
3807 total
[5] = Fcons (make_number (total_intervals
),
3808 make_number (total_free_intervals
));
3809 total
[6] = Fcons (make_number (total_strings
),
3810 make_number (total_free_strings
));
3812 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3814 /* Compute average percentage of zombies. */
3817 for (i
= 0; i
< 7; ++i
)
3818 nlive
+= XFASTINT (XCAR (total
[i
]));
3820 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3821 max_live
= max (nlive
, max_live
);
3822 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3823 max_zombies
= max (nzombies
, max_zombies
);
3828 return Flist (7, total
);
3832 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3833 only interesting objects referenced from glyphs are strings. */
3836 mark_glyph_matrix (matrix
)
3837 struct glyph_matrix
*matrix
;
3839 struct glyph_row
*row
= matrix
->rows
;
3840 struct glyph_row
*end
= row
+ matrix
->nrows
;
3842 for (; row
< end
; ++row
)
3846 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3848 struct glyph
*glyph
= row
->glyphs
[area
];
3849 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3851 for (; glyph
< end_glyph
; ++glyph
)
3852 if (GC_STRINGP (glyph
->object
)
3853 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3854 mark_object (&glyph
->object
);
3860 /* Mark Lisp faces in the face cache C. */
3864 struct face_cache
*c
;
3869 for (i
= 0; i
< c
->used
; ++i
)
3871 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3875 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3876 mark_object (&face
->lface
[j
]);
3883 #ifdef HAVE_WINDOW_SYSTEM
3885 /* Mark Lisp objects in image IMG. */
3891 mark_object (&img
->spec
);
3893 if (!NILP (img
->data
.lisp_val
))
3894 mark_object (&img
->data
.lisp_val
);
3898 /* Mark Lisp objects in image cache of frame F. It's done this way so
3899 that we don't have to include xterm.h here. */
3902 mark_image_cache (f
)
3905 forall_images_in_image_cache (f
, mark_image
);
3908 #endif /* HAVE_X_WINDOWS */
3912 /* Mark reference to a Lisp_Object.
3913 If the object referred to has not been seen yet, recursively mark
3914 all the references contained in it. */
3916 #define LAST_MARKED_SIZE 500
3917 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
3918 int last_marked_index
;
3921 mark_object (argptr
)
3922 Lisp_Object
*argptr
;
3924 Lisp_Object
*objptr
= argptr
;
3925 register Lisp_Object obj
;
3926 #ifdef GC_CHECK_MARKED_OBJECTS
3936 if (PURE_POINTER_P ((PNTR_COMPARISON_TYPE
) XPNTR (obj
)))
3939 last_marked
[last_marked_index
++] = objptr
;
3940 if (last_marked_index
== LAST_MARKED_SIZE
)
3941 last_marked_index
= 0;
3943 /* Perform some sanity checks on the objects marked here. Abort if
3944 we encounter an object we know is bogus. This increases GC time
3945 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
3946 #ifdef GC_CHECK_MARKED_OBJECTS
3948 po
= (void *) XPNTR (obj
);
3950 /* Check that the object pointed to by PO is known to be a Lisp
3951 structure allocated from the heap. */
3952 #define CHECK_ALLOCATED() \
3954 m = mem_find (po); \
3959 /* Check that the object pointed to by PO is live, using predicate
3961 #define CHECK_LIVE(LIVEP) \
3963 if (!LIVEP (m, po)) \
3967 /* Check both of the above conditions. */
3968 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
3970 CHECK_ALLOCATED (); \
3971 CHECK_LIVE (LIVEP); \
3974 #else /* not GC_CHECK_MARKED_OBJECTS */
3976 #define CHECK_ALLOCATED() (void) 0
3977 #define CHECK_LIVE(LIVEP) (void) 0
3978 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
3980 #endif /* not GC_CHECK_MARKED_OBJECTS */
3982 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
3986 register struct Lisp_String
*ptr
= XSTRING (obj
);
3987 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
3988 MARK_INTERVAL_TREE (ptr
->intervals
);
3990 #ifdef GC_CHECK_STRING_BYTES
3992 /* Check that the string size recorded in the string is the
3993 same as the one recorded in the sdata structure. */
3994 struct sdata
*p
= SDATA_OF_STRING (ptr
);
3995 if (GC_STRING_BYTES (ptr
) != SDATA_NBYTES (p
))
3998 #endif /* GC_CHECK_STRING_BYTES */
4002 case Lisp_Vectorlike
:
4003 #ifdef GC_CHECK_MARKED_OBJECTS
4005 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4006 && po
!= &buffer_defaults
4007 && po
!= &buffer_local_symbols
)
4009 #endif /* GC_CHECK_MARKED_OBJECTS */
4011 if (GC_BUFFERP (obj
))
4013 if (!XMARKBIT (XBUFFER (obj
)->name
))
4015 #ifdef GC_CHECK_MARKED_OBJECTS
4016 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4019 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4024 #endif /* GC_CHECK_MARKED_OBJECTS */
4028 else if (GC_SUBRP (obj
))
4030 else if (GC_COMPILEDP (obj
))
4031 /* We could treat this just like a vector, but it is better to
4032 save the COMPILED_CONSTANTS element for last and avoid
4035 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4036 register EMACS_INT size
= ptr
->size
;
4039 if (size
& ARRAY_MARK_FLAG
)
4040 break; /* Already marked */
4042 CHECK_LIVE (live_vector_p
);
4043 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4044 size
&= PSEUDOVECTOR_SIZE_MASK
;
4045 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4047 if (i
!= COMPILED_CONSTANTS
)
4048 mark_object (&ptr
->contents
[i
]);
4050 /* This cast should be unnecessary, but some Mips compiler complains
4051 (MIPS-ABI + SysVR4, DC/OSx, etc). */
4052 objptr
= (Lisp_Object
*) &ptr
->contents
[COMPILED_CONSTANTS
];
4055 else if (GC_FRAMEP (obj
))
4057 register struct frame
*ptr
= XFRAME (obj
);
4058 register EMACS_INT size
= ptr
->size
;
4060 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4061 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4063 CHECK_LIVE (live_vector_p
);
4064 mark_object (&ptr
->name
);
4065 mark_object (&ptr
->icon_name
);
4066 mark_object (&ptr
->title
);
4067 mark_object (&ptr
->focus_frame
);
4068 mark_object (&ptr
->selected_window
);
4069 mark_object (&ptr
->minibuffer_window
);
4070 mark_object (&ptr
->param_alist
);
4071 mark_object (&ptr
->scroll_bars
);
4072 mark_object (&ptr
->condemned_scroll_bars
);
4073 mark_object (&ptr
->menu_bar_items
);
4074 mark_object (&ptr
->face_alist
);
4075 mark_object (&ptr
->menu_bar_vector
);
4076 mark_object (&ptr
->buffer_predicate
);
4077 mark_object (&ptr
->buffer_list
);
4078 mark_object (&ptr
->menu_bar_window
);
4079 mark_object (&ptr
->tool_bar_window
);
4080 mark_face_cache (ptr
->face_cache
);
4081 #ifdef HAVE_WINDOW_SYSTEM
4082 mark_image_cache (ptr
);
4083 mark_object (&ptr
->desired_tool_bar_items
);
4084 mark_object (&ptr
->current_tool_bar_items
);
4085 mark_object (&ptr
->desired_tool_bar_string
);
4086 mark_object (&ptr
->current_tool_bar_string
);
4087 #endif /* HAVE_WINDOW_SYSTEM */
4089 else if (GC_BOOL_VECTOR_P (obj
))
4091 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4093 if (ptr
->size
& ARRAY_MARK_FLAG
)
4094 break; /* Already marked */
4095 CHECK_LIVE (live_vector_p
);
4096 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4098 else if (GC_WINDOWP (obj
))
4100 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4101 struct window
*w
= XWINDOW (obj
);
4102 register EMACS_INT size
= ptr
->size
;
4105 /* Stop if already marked. */
4106 if (size
& ARRAY_MARK_FLAG
)
4110 CHECK_LIVE (live_vector_p
);
4111 ptr
->size
|= ARRAY_MARK_FLAG
;
4113 /* There is no Lisp data above The member CURRENT_MATRIX in
4114 struct WINDOW. Stop marking when that slot is reached. */
4116 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4118 mark_object (&ptr
->contents
[i
]);
4120 /* Mark glyphs for leaf windows. Marking window matrices is
4121 sufficient because frame matrices use the same glyph
4123 if (NILP (w
->hchild
)
4125 && w
->current_matrix
)
4127 mark_glyph_matrix (w
->current_matrix
);
4128 mark_glyph_matrix (w
->desired_matrix
);
4131 else if (GC_HASH_TABLE_P (obj
))
4133 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4134 EMACS_INT size
= h
->size
;
4136 /* Stop if already marked. */
4137 if (size
& ARRAY_MARK_FLAG
)
4141 CHECK_LIVE (live_vector_p
);
4142 h
->size
|= ARRAY_MARK_FLAG
;
4144 /* Mark contents. */
4145 mark_object (&h
->test
);
4146 mark_object (&h
->weak
);
4147 mark_object (&h
->rehash_size
);
4148 mark_object (&h
->rehash_threshold
);
4149 mark_object (&h
->hash
);
4150 mark_object (&h
->next
);
4151 mark_object (&h
->index
);
4152 mark_object (&h
->user_hash_function
);
4153 mark_object (&h
->user_cmp_function
);
4155 /* If hash table is not weak, mark all keys and values.
4156 For weak tables, mark only the vector. */
4157 if (GC_NILP (h
->weak
))
4158 mark_object (&h
->key_and_value
);
4160 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
4165 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4166 register EMACS_INT size
= ptr
->size
;
4169 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4170 CHECK_LIVE (live_vector_p
);
4171 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4172 if (size
& PSEUDOVECTOR_FLAG
)
4173 size
&= PSEUDOVECTOR_SIZE_MASK
;
4175 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4176 mark_object (&ptr
->contents
[i
]);
4182 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4183 struct Lisp_Symbol
*ptrx
;
4185 if (XMARKBIT (ptr
->plist
)) break;
4186 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4188 mark_object ((Lisp_Object
*) &ptr
->value
);
4189 mark_object (&ptr
->function
);
4190 mark_object (&ptr
->plist
);
4192 if (!PURE_POINTER_P (ptr
->name
))
4193 MARK_STRING (ptr
->name
);
4194 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
4196 /* Note that we do not mark the obarray of the symbol.
4197 It is safe not to do so because nothing accesses that
4198 slot except to check whether it is nil. */
4202 /* For the benefit of the last_marked log. */
4203 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4204 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4205 XSETSYMBOL (obj
, ptrx
);
4206 /* We can't goto loop here because *objptr doesn't contain an
4207 actual Lisp_Object with valid datatype field. */
4214 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4215 switch (XMISCTYPE (obj
))
4217 case Lisp_Misc_Marker
:
4218 XMARK (XMARKER (obj
)->chain
);
4219 /* DO NOT mark thru the marker's chain.
4220 The buffer's markers chain does not preserve markers from gc;
4221 instead, markers are removed from the chain when freed by gc. */
4224 case Lisp_Misc_Buffer_Local_Value
:
4225 case Lisp_Misc_Some_Buffer_Local_Value
:
4227 register struct Lisp_Buffer_Local_Value
*ptr
4228 = XBUFFER_LOCAL_VALUE (obj
);
4229 if (XMARKBIT (ptr
->realvalue
)) break;
4230 XMARK (ptr
->realvalue
);
4231 /* If the cdr is nil, avoid recursion for the car. */
4232 if (EQ (ptr
->cdr
, Qnil
))
4234 objptr
= &ptr
->realvalue
;
4237 mark_object (&ptr
->realvalue
);
4238 mark_object (&ptr
->buffer
);
4239 mark_object (&ptr
->frame
);
4244 case Lisp_Misc_Intfwd
:
4245 case Lisp_Misc_Boolfwd
:
4246 case Lisp_Misc_Objfwd
:
4247 case Lisp_Misc_Buffer_Objfwd
:
4248 case Lisp_Misc_Kboard_Objfwd
:
4249 /* Don't bother with Lisp_Buffer_Objfwd,
4250 since all markable slots in current buffer marked anyway. */
4251 /* Don't need to do Lisp_Objfwd, since the places they point
4252 are protected with staticpro. */
4255 case Lisp_Misc_Overlay
:
4257 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4258 if (!XMARKBIT (ptr
->plist
))
4261 mark_object (&ptr
->start
);
4262 mark_object (&ptr
->end
);
4263 objptr
= &ptr
->plist
;
4276 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4277 if (XMARKBIT (ptr
->car
)) break;
4278 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
4280 /* If the cdr is nil, avoid recursion for the car. */
4281 if (EQ (ptr
->cdr
, Qnil
))
4286 mark_object (&ptr
->car
);
4292 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
4293 XMARK (XFLOAT (obj
)->type
);
4304 #undef CHECK_ALLOCATED
4305 #undef CHECK_ALLOCATED_AND_LIVE
4308 /* Mark the pointers in a buffer structure. */
4314 register struct buffer
*buffer
= XBUFFER (buf
);
4315 register Lisp_Object
*ptr
;
4316 Lisp_Object base_buffer
;
4318 /* This is the buffer's markbit */
4319 mark_object (&buffer
->name
);
4320 XMARK (buffer
->name
);
4322 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4324 if (CONSP (buffer
->undo_list
))
4327 tail
= buffer
->undo_list
;
4329 while (CONSP (tail
))
4331 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4333 if (XMARKBIT (ptr
->car
))
4336 if (GC_CONSP (ptr
->car
)
4337 && ! XMARKBIT (XCAR (ptr
->car
))
4338 && GC_MARKERP (XCAR (ptr
->car
)))
4340 XMARK (XCAR (ptr
->car
));
4341 mark_object (&XCDR (ptr
->car
));
4344 mark_object (&ptr
->car
);
4346 if (CONSP (ptr
->cdr
))
4352 mark_object (&XCDR (tail
));
4355 mark_object (&buffer
->undo_list
);
4357 for (ptr
= &buffer
->name
+ 1;
4358 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4362 /* If this is an indirect buffer, mark its base buffer. */
4363 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4365 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4366 mark_buffer (base_buffer
);
4371 /* Mark the pointers in the kboard objects. */
4378 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4380 if (kb
->kbd_macro_buffer
)
4381 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4383 mark_object (&kb
->Voverriding_terminal_local_map
);
4384 mark_object (&kb
->Vlast_command
);
4385 mark_object (&kb
->Vreal_last_command
);
4386 mark_object (&kb
->Vprefix_arg
);
4387 mark_object (&kb
->Vlast_prefix_arg
);
4388 mark_object (&kb
->kbd_queue
);
4389 mark_object (&kb
->defining_kbd_macro
);
4390 mark_object (&kb
->Vlast_kbd_macro
);
4391 mark_object (&kb
->Vsystem_key_alist
);
4392 mark_object (&kb
->system_key_syms
);
4393 mark_object (&kb
->Vdefault_minibuffer_frame
);
4398 /* Value is non-zero if OBJ will survive the current GC because it's
4399 either marked or does not need to be marked to survive. */
4407 switch (XGCTYPE (obj
))
4414 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4418 switch (XMISCTYPE (obj
))
4420 case Lisp_Misc_Marker
:
4421 survives_p
= XMARKBIT (obj
);
4424 case Lisp_Misc_Buffer_Local_Value
:
4425 case Lisp_Misc_Some_Buffer_Local_Value
:
4426 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4429 case Lisp_Misc_Intfwd
:
4430 case Lisp_Misc_Boolfwd
:
4431 case Lisp_Misc_Objfwd
:
4432 case Lisp_Misc_Buffer_Objfwd
:
4433 case Lisp_Misc_Kboard_Objfwd
:
4437 case Lisp_Misc_Overlay
:
4438 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4448 struct Lisp_String
*s
= XSTRING (obj
);
4449 survives_p
= STRING_MARKED_P (s
);
4453 case Lisp_Vectorlike
:
4454 if (GC_BUFFERP (obj
))
4455 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4456 else if (GC_SUBRP (obj
))
4459 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4463 survives_p
= XMARKBIT (XCAR (obj
));
4467 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4474 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4479 /* Sweep: find all structures not marked, and free them. */
4484 /* Remove or mark entries in weak hash tables.
4485 This must be done before any object is unmarked. */
4486 sweep_weak_hash_tables ();
4490 /* Put all unmarked conses on free list */
4492 register struct cons_block
*cblk
;
4493 struct cons_block
**cprev
= &cons_block
;
4494 register int lim
= cons_block_index
;
4495 register int num_free
= 0, num_used
= 0;
4499 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4503 for (i
= 0; i
< lim
; i
++)
4504 if (!XMARKBIT (cblk
->conses
[i
].car
))
4507 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4508 cons_free_list
= &cblk
->conses
[i
];
4510 cons_free_list
->car
= Vdead
;
4516 XUNMARK (cblk
->conses
[i
].car
);
4518 lim
= CONS_BLOCK_SIZE
;
4519 /* If this block contains only free conses and we have already
4520 seen more than two blocks worth of free conses then deallocate
4522 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4524 *cprev
= cblk
->next
;
4525 /* Unhook from the free list. */
4526 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4532 num_free
+= this_free
;
4533 cprev
= &cblk
->next
;
4536 total_conses
= num_used
;
4537 total_free_conses
= num_free
;
4540 /* Put all unmarked floats on free list */
4542 register struct float_block
*fblk
;
4543 struct float_block
**fprev
= &float_block
;
4544 register int lim
= float_block_index
;
4545 register int num_free
= 0, num_used
= 0;
4547 float_free_list
= 0;
4549 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4553 for (i
= 0; i
< lim
; i
++)
4554 if (!XMARKBIT (fblk
->floats
[i
].type
))
4557 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4558 float_free_list
= &fblk
->floats
[i
];
4560 float_free_list
->type
= Vdead
;
4566 XUNMARK (fblk
->floats
[i
].type
);
4568 lim
= FLOAT_BLOCK_SIZE
;
4569 /* If this block contains only free floats and we have already
4570 seen more than two blocks worth of free floats then deallocate
4572 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4574 *fprev
= fblk
->next
;
4575 /* Unhook from the free list. */
4576 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4582 num_free
+= this_free
;
4583 fprev
= &fblk
->next
;
4586 total_floats
= num_used
;
4587 total_free_floats
= num_free
;
4590 /* Put all unmarked intervals on free list */
4592 register struct interval_block
*iblk
;
4593 struct interval_block
**iprev
= &interval_block
;
4594 register int lim
= interval_block_index
;
4595 register int num_free
= 0, num_used
= 0;
4597 interval_free_list
= 0;
4599 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4604 for (i
= 0; i
< lim
; i
++)
4606 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4608 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4609 interval_free_list
= &iblk
->intervals
[i
];
4615 XUNMARK (iblk
->intervals
[i
].plist
);
4618 lim
= INTERVAL_BLOCK_SIZE
;
4619 /* If this block contains only free intervals and we have already
4620 seen more than two blocks worth of free intervals then
4621 deallocate this block. */
4622 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4624 *iprev
= iblk
->next
;
4625 /* Unhook from the free list. */
4626 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4628 n_interval_blocks
--;
4632 num_free
+= this_free
;
4633 iprev
= &iblk
->next
;
4636 total_intervals
= num_used
;
4637 total_free_intervals
= num_free
;
4640 /* Put all unmarked symbols on free list */
4642 register struct symbol_block
*sblk
;
4643 struct symbol_block
**sprev
= &symbol_block
;
4644 register int lim
= symbol_block_index
;
4645 register int num_free
= 0, num_used
= 0;
4647 symbol_free_list
= 0;
4649 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4653 for (i
= 0; i
< lim
; i
++)
4654 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4656 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4657 symbol_free_list
= &sblk
->symbols
[i
];
4659 symbol_free_list
->function
= Vdead
;
4666 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4667 UNMARK_STRING (sblk
->symbols
[i
].name
);
4668 XUNMARK (sblk
->symbols
[i
].plist
);
4670 lim
= SYMBOL_BLOCK_SIZE
;
4671 /* If this block contains only free symbols and we have already
4672 seen more than two blocks worth of free symbols then deallocate
4674 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4676 *sprev
= sblk
->next
;
4677 /* Unhook from the free list. */
4678 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4684 num_free
+= this_free
;
4685 sprev
= &sblk
->next
;
4688 total_symbols
= num_used
;
4689 total_free_symbols
= num_free
;
4692 /* Put all unmarked misc's on free list.
4693 For a marker, first unchain it from the buffer it points into. */
4695 register struct marker_block
*mblk
;
4696 struct marker_block
**mprev
= &marker_block
;
4697 register int lim
= marker_block_index
;
4698 register int num_free
= 0, num_used
= 0;
4700 marker_free_list
= 0;
4702 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4706 EMACS_INT already_free
= -1;
4708 for (i
= 0; i
< lim
; i
++)
4710 Lisp_Object
*markword
;
4711 switch (mblk
->markers
[i
].u_marker
.type
)
4713 case Lisp_Misc_Marker
:
4714 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4716 case Lisp_Misc_Buffer_Local_Value
:
4717 case Lisp_Misc_Some_Buffer_Local_Value
:
4718 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4720 case Lisp_Misc_Overlay
:
4721 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4723 case Lisp_Misc_Free
:
4724 /* If the object was already free, keep it
4725 on the free list. */
4726 markword
= (Lisp_Object
*) &already_free
;
4732 if (markword
&& !XMARKBIT (*markword
))
4735 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4737 /* tem1 avoids Sun compiler bug */
4738 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4739 XSETMARKER (tem
, tem1
);
4740 unchain_marker (tem
);
4742 /* Set the type of the freed object to Lisp_Misc_Free.
4743 We could leave the type alone, since nobody checks it,
4744 but this might catch bugs faster. */
4745 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4746 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4747 marker_free_list
= &mblk
->markers
[i
];
4754 XUNMARK (*markword
);
4757 lim
= MARKER_BLOCK_SIZE
;
4758 /* If this block contains only free markers and we have already
4759 seen more than two blocks worth of free markers then deallocate
4761 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4763 *mprev
= mblk
->next
;
4764 /* Unhook from the free list. */
4765 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4771 num_free
+= this_free
;
4772 mprev
= &mblk
->next
;
4776 total_markers
= num_used
;
4777 total_free_markers
= num_free
;
4780 /* Free all unmarked buffers */
4782 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4785 if (!XMARKBIT (buffer
->name
))
4788 prev
->next
= buffer
->next
;
4790 all_buffers
= buffer
->next
;
4791 next
= buffer
->next
;
4797 XUNMARK (buffer
->name
);
4798 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4799 prev
= buffer
, buffer
= buffer
->next
;
4803 /* Free all unmarked vectors */
4805 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4806 total_vector_size
= 0;
4809 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4812 prev
->next
= vector
->next
;
4814 all_vectors
= vector
->next
;
4815 next
= vector
->next
;
4823 vector
->size
&= ~ARRAY_MARK_FLAG
;
4824 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4825 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4827 total_vector_size
+= vector
->size
;
4828 prev
= vector
, vector
= vector
->next
;
4836 /* Debugging aids. */
4838 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4839 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4840 This may be helpful in debugging Emacs's memory usage.\n\
4841 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4846 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4851 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4852 "Return a list of counters that measure how much consing there has been.\n\
4853 Each of these counters increments for a certain kind of object.\n\
4854 The counters wrap around from the largest positive integer to zero.\n\
4855 Garbage collection does not decrease them.\n\
4856 The elements of the value are as follows:\n\
4857 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4858 All are in units of 1 = one object consed\n\
4859 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4861 MISCS include overlays, markers, and some internal types.\n\
4862 Frames, windows, buffers, and subprocesses count as vectors\n\
4863 (but the contents of a buffer's text do not count here).")
4866 Lisp_Object consed
[8];
4869 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4871 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4873 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4875 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4877 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4879 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4881 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4883 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4885 return Flist (8, consed
);
4888 int suppress_checking
;
4890 die (msg
, file
, line
)
4895 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
4900 /* Initialization */
4905 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
4909 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
4912 pure_size
= PURESIZE
;
4915 ignore_warnings
= 1;
4916 #ifdef DOUG_LEA_MALLOC
4917 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
4918 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
4919 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
4929 malloc_hysteresis
= 32;
4931 malloc_hysteresis
= 0;
4934 spare_memory
= (char *) malloc (SPARE_MEMORY
);
4936 ignore_warnings
= 0;
4938 byte_stack_list
= 0;
4940 consing_since_gc
= 0;
4941 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
4942 #ifdef VIRT_ADDR_VARIES
4943 malloc_sbrk_unused
= 1<<22; /* A large number */
4944 malloc_sbrk_used
= 100000; /* as reasonable as any number */
4945 #endif /* VIRT_ADDR_VARIES */
4952 byte_stack_list
= 0;
4954 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4955 setjmp_tested_p
= longjmps_done
= 0;
4963 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
4964 "*Number of bytes of consing between garbage collections.\n\
4965 Garbage collection can happen automatically once this many bytes have been\n\
4966 allocated since the last garbage collection. All data types count.\n\n\
4967 Garbage collection happens automatically only when `eval' is called.\n\n\
4968 By binding this temporarily to a large number, you can effectively\n\
4969 prevent garbage collection during a part of the program.");
4971 DEFVAR_INT ("pure-bytes-used", &pureptr
,
4972 "Number of bytes of sharable Lisp data allocated so far.");
4974 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
4975 "Number of cons cells that have been consed so far.");
4977 DEFVAR_INT ("floats-consed", &floats_consed
,
4978 "Number of floats that have been consed so far.");
4980 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
4981 "Number of vector cells that have been consed so far.");
4983 DEFVAR_INT ("symbols-consed", &symbols_consed
,
4984 "Number of symbols that have been consed so far.");
4986 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
4987 "Number of string characters that have been consed so far.");
4989 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
4990 "Number of miscellaneous objects that have been consed so far.");
4992 DEFVAR_INT ("intervals-consed", &intervals_consed
,
4993 "Number of intervals that have been consed so far.");
4995 DEFVAR_INT ("strings-consed", &strings_consed
,
4996 "Number of strings that have been consed so far.");
4998 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
4999 "Non-nil means loading Lisp code in order to dump an executable.\n\
5000 This means that certain objects should be allocated in shared (pure) space.");
5002 DEFVAR_INT ("undo-limit", &undo_limit
,
5003 "Keep no more undo information once it exceeds this size.\n\
5004 This limit is applied when garbage collection happens.\n\
5005 The size is counted as the number of bytes occupied,\n\
5006 which includes both saved text and other data.");
5009 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5010 "Don't keep more than this much size of undo information.\n\
5011 A command which pushes past this size is itself forgotten.\n\
5012 This limit is applied when garbage collection happens.\n\
5013 The size is counted as the number of bytes occupied,\n\
5014 which includes both saved text and other data.");
5015 undo_strong_limit
= 30000;
5017 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5018 "Non-nil means display messages at start and end of garbage collection.");
5019 garbage_collection_messages
= 0;
5021 /* We build this in advance because if we wait until we need it, we might
5022 not be able to allocate the memory to hold it. */
5024 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
5025 staticpro (&memory_signal_data
);
5027 staticpro (&Qgc_cons_threshold
);
5028 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5030 staticpro (&Qchar_table_extra_slots
);
5031 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5036 defsubr (&Smake_byte_code
);
5037 defsubr (&Smake_list
);
5038 defsubr (&Smake_vector
);
5039 defsubr (&Smake_char_table
);
5040 defsubr (&Smake_string
);
5041 defsubr (&Smake_bool_vector
);
5042 defsubr (&Smake_symbol
);
5043 defsubr (&Smake_marker
);
5044 defsubr (&Spurecopy
);
5045 defsubr (&Sgarbage_collect
);
5046 defsubr (&Smemory_limit
);
5047 defsubr (&Smemory_use_counts
);
5049 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5050 defsubr (&Sgc_status
);