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 redundantly recorded in sdata structures so that it can
31 be compared to the sizes recorded in Lisp strings. */
33 #define GC_CHECK_STRING_BYTES 1
35 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
36 memory. Can do this only if using gmalloc.c. */
38 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
39 #undef GC_MALLOC_CHECK
42 /* This file is part of the core Lisp implementation, and thus must
43 deal with the real data structures. If the Lisp implementation is
44 replaced, this file likely will not be used. */
46 #undef HIDE_LISP_IMPLEMENTATION
48 #include "intervals.h"
54 #include "blockinput.h"
56 #include "syssignal.h"
62 extern POINTER_TYPE
*sbrk ();
65 #ifdef DOUG_LEA_MALLOC
68 /* malloc.h #defines this as size_t, at least in glibc2. */
69 #ifndef __malloc_size_t
70 #define __malloc_size_t int
73 /* Specify maximum number of areas to mmap. It would be nice to use a
74 value that explicitly means "no limit". */
76 #define MMAP_MAX_AREAS 100000000
78 #else /* not DOUG_LEA_MALLOC */
80 /* The following come from gmalloc.c. */
82 #define __malloc_size_t size_t
83 extern __malloc_size_t _bytes_used
;
84 extern __malloc_size_t __malloc_extra_blocks
;
86 #endif /* not DOUG_LEA_MALLOC */
88 #define max(A,B) ((A) > (B) ? (A) : (B))
89 #define min(A,B) ((A) < (B) ? (A) : (B))
91 /* Macro to verify that storage intended for Lisp objects is not
92 out of range to fit in the space for a pointer.
93 ADDRESS is the start of the block, and SIZE
94 is the amount of space within which objects can start. */
96 #define VALIDATE_LISP_STORAGE(address, size) \
100 XSETCONS (val, (char *) address + size); \
101 if ((char *) XCONS (val) != (char *) address + size) \
108 /* Value of _bytes_used, when spare_memory was freed. */
110 static __malloc_size_t bytes_used_when_full
;
112 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
113 to a struct Lisp_String. */
115 #define MARK_STRING(S) ((S)->size |= MARKBIT)
116 #define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
117 #define STRING_MARKED_P(S) ((S)->size & MARKBIT)
119 /* Value is the number of bytes/chars of S, a pointer to a struct
120 Lisp_String. This must be used instead of STRING_BYTES (S) or
121 S->size during GC, because S->size contains the mark bit for
124 #define GC_STRING_BYTES(S) (STRING_BYTES (S) & ~MARKBIT)
125 #define GC_STRING_CHARS(S) ((S)->size & ~MARKBIT)
127 /* Number of bytes of consing done since the last gc. */
129 int consing_since_gc
;
131 /* Count the amount of consing of various sorts of space. */
133 int cons_cells_consed
;
135 int vector_cells_consed
;
137 int string_chars_consed
;
138 int misc_objects_consed
;
139 int intervals_consed
;
142 /* Number of bytes of consing since GC before another GC should be done. */
144 int gc_cons_threshold
;
146 /* Nonzero during GC. */
150 /* Nonzero means display messages at beginning and end of GC. */
152 int garbage_collection_messages
;
154 #ifndef VIRT_ADDR_VARIES
156 #endif /* VIRT_ADDR_VARIES */
157 int malloc_sbrk_used
;
159 #ifndef VIRT_ADDR_VARIES
161 #endif /* VIRT_ADDR_VARIES */
162 int malloc_sbrk_unused
;
164 /* Two limits controlling how much undo information to keep. */
167 int undo_strong_limit
;
169 /* Number of live and free conses etc. */
171 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
172 static int total_free_conses
, total_free_markers
, total_free_symbols
;
173 static int total_free_floats
, total_floats
;
175 /* Points to memory space allocated as "spare", to be freed if we run
178 static char *spare_memory
;
180 /* Amount of spare memory to keep in reserve. */
182 #define SPARE_MEMORY (1 << 14)
184 /* Number of extra blocks malloc should get when it needs more core. */
186 static int malloc_hysteresis
;
188 /* Non-nil means defun should do purecopy on the function definition. */
190 Lisp_Object Vpurify_flag
;
194 /* Force it into data space! */
196 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,};
197 #define PUREBEG (char *) pure
199 #else /* not HAVE_SHM */
201 #define pure PURE_SEG_BITS /* Use shared memory segment */
202 #define PUREBEG (char *)PURE_SEG_BITS
204 /* This variable is used only by the XPNTR macro when HAVE_SHM is
205 defined. If we used the PURESIZE macro directly there, that would
206 make most of Emacs dependent on puresize.h, which we don't want -
207 you should be able to change that without too much recompilation.
208 So map_in_data initializes pure_size, and the dependencies work
213 #endif /* not HAVE_SHM */
215 /* Value is non-zero if P points into pure space. */
217 #define PURE_POINTER_P(P) \
218 (((PNTR_COMPARISON_TYPE) (P) \
219 < (PNTR_COMPARISON_TYPE) ((char *) pure + PURESIZE)) \
220 && ((PNTR_COMPARISON_TYPE) (P) \
221 >= (PNTR_COMPARISON_TYPE) pure))
223 /* Index in pure at which next pure object will be allocated.. */
227 /* If nonzero, this is a warning delivered by malloc and not yet
230 char *pending_malloc_warning
;
232 /* Pre-computed signal argument for use when memory is exhausted. */
234 Lisp_Object memory_signal_data
;
236 /* Maximum amount of C stack to save when a GC happens. */
238 #ifndef MAX_SAVE_STACK
239 #define MAX_SAVE_STACK 16000
242 /* Buffer in which we save a copy of the C stack at each GC. */
247 /* Non-zero means ignore malloc warnings. Set during initialization.
248 Currently not used. */
252 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
254 static void mark_buffer
P_ ((Lisp_Object
));
255 static void mark_kboards
P_ ((void));
256 static void gc_sweep
P_ ((void));
257 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
258 static void mark_face_cache
P_ ((struct face_cache
*));
260 #ifdef HAVE_WINDOW_SYSTEM
261 static void mark_image
P_ ((struct image
*));
262 static void mark_image_cache
P_ ((struct frame
*));
263 #endif /* HAVE_WINDOW_SYSTEM */
265 static struct Lisp_String
*allocate_string
P_ ((void));
266 static void compact_small_strings
P_ ((void));
267 static void free_large_strings
P_ ((void));
268 static void sweep_strings
P_ ((void));
270 extern int message_enable_multibyte
;
272 /* When scanning the C stack for live Lisp objects, Emacs keeps track
273 of what memory allocated via lisp_malloc is intended for what
274 purpose. This enumeration specifies the type of memory. */
288 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
290 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
291 #include <stdio.h> /* For fprintf. */
294 /* A unique object in pure space used to make some Lisp objects
295 on free lists recognizable in O(1). */
299 #ifdef GC_MALLOC_CHECK
301 enum mem_type allocated_mem_type
;
302 int dont_register_blocks
;
304 #endif /* GC_MALLOC_CHECK */
306 /* A node in the red-black tree describing allocated memory containing
307 Lisp data. Each such block is recorded with its start and end
308 address when it is allocated, and removed from the tree when it
311 A red-black tree is a balanced binary tree with the following
314 1. Every node is either red or black.
315 2. Every leaf is black.
316 3. If a node is red, then both of its children are black.
317 4. Every simple path from a node to a descendant leaf contains
318 the same number of black nodes.
319 5. The root is always black.
321 When nodes are inserted into the tree, or deleted from the tree,
322 the tree is "fixed" so that these properties are always true.
324 A red-black tree with N internal nodes has height at most 2
325 log(N+1). Searches, insertions and deletions are done in O(log N).
326 Please see a text book about data structures for a detailed
327 description of red-black trees. Any book worth its salt should
332 struct mem_node
*left
, *right
, *parent
;
334 /* Start and end of allocated region. */
338 enum {MEM_BLACK
, MEM_RED
} color
;
344 /* Base address of stack. Set in main. */
346 Lisp_Object
*stack_base
;
348 /* Root of the tree describing allocated Lisp memory. */
350 static struct mem_node
*mem_root
;
352 /* Sentinel node of the tree. */
354 static struct mem_node mem_z
;
355 #define MEM_NIL &mem_z
357 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
358 static void lisp_free
P_ ((POINTER_TYPE
*));
359 static void mark_stack
P_ ((void));
360 static void init_stack
P_ ((Lisp_Object
*));
361 static int live_vector_p
P_ ((struct mem_node
*, void *));
362 static int live_buffer_p
P_ ((struct mem_node
*, void *));
363 static int live_string_p
P_ ((struct mem_node
*, void *));
364 static int live_cons_p
P_ ((struct mem_node
*, void *));
365 static int live_symbol_p
P_ ((struct mem_node
*, void *));
366 static int live_float_p
P_ ((struct mem_node
*, void *));
367 static int live_misc_p
P_ ((struct mem_node
*, void *));
368 static void mark_maybe_object
P_ ((Lisp_Object
));
369 static void mark_memory
P_ ((void *, void *));
370 static void mem_init
P_ ((void));
371 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
372 static void mem_insert_fixup
P_ ((struct mem_node
*));
373 static void mem_rotate_left
P_ ((struct mem_node
*));
374 static void mem_rotate_right
P_ ((struct mem_node
*));
375 static void mem_delete
P_ ((struct mem_node
*));
376 static void mem_delete_fixup
P_ ((struct mem_node
*));
377 static INLINE
struct mem_node
*mem_find
P_ ((void *));
379 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
380 static void check_gcpros
P_ ((void));
383 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
385 /* Recording what needs to be marked for gc. */
387 struct gcpro
*gcprolist
;
389 /* Addresses of staticpro'd variables. */
391 #define NSTATICS 1024
392 Lisp_Object
*staticvec
[NSTATICS
] = {0};
394 /* Index of next unused slot in staticvec. */
398 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
401 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
402 ALIGNMENT must be a power of 2. */
404 #define ALIGN(SZ, ALIGNMENT) \
405 (((SZ) + (ALIGNMENT) - 1) & ~((ALIGNMENT) - 1))
408 /************************************************************************
410 ************************************************************************/
412 /* Write STR to Vstandard_output plus some advice on how to free some
413 memory. Called when memory gets low. */
416 malloc_warning_1 (str
)
419 Fprinc (str
, Vstandard_output
);
420 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
421 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
422 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
427 /* Function malloc calls this if it finds we are near exhausting
434 pending_malloc_warning
= str
;
438 /* Display a malloc warning in buffer *Danger*. */
441 display_malloc_warning ()
443 register Lisp_Object val
;
445 val
= build_string (pending_malloc_warning
);
446 pending_malloc_warning
= 0;
447 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
451 #ifdef DOUG_LEA_MALLOC
452 # define BYTES_USED (mallinfo ().arena)
454 # define BYTES_USED _bytes_used
458 /* Called if malloc returns zero. */
463 #ifndef SYSTEM_MALLOC
464 bytes_used_when_full
= BYTES_USED
;
467 /* The first time we get here, free the spare memory. */
474 /* This used to call error, but if we've run out of memory, we could
475 get infinite recursion trying to build the string. */
477 Fsignal (Qnil
, memory_signal_data
);
481 /* Called if we can't allocate relocatable space for a buffer. */
484 buffer_memory_full ()
486 /* If buffers use the relocating allocator, no need to free
487 spare_memory, because we may have plenty of malloc space left
488 that we could get, and if we don't, the malloc that fails will
489 itself cause spare_memory to be freed. If buffers don't use the
490 relocating allocator, treat this like any other failing
497 /* This used to call error, but if we've run out of memory, we could
498 get infinite recursion trying to build the string. */
500 Fsignal (Qerror
, memory_signal_data
);
504 /* Like malloc but check for no memory and block interrupt input.. */
510 register POINTER_TYPE
*val
;
513 val
= (POINTER_TYPE
*) malloc (size
);
522 /* Like realloc but check for no memory and block interrupt input.. */
525 xrealloc (block
, size
)
529 register POINTER_TYPE
*val
;
532 /* We must call malloc explicitly when BLOCK is 0, since some
533 reallocs don't do this. */
535 val
= (POINTER_TYPE
*) malloc (size
);
537 val
= (POINTER_TYPE
*) realloc (block
, size
);
540 if (!val
&& size
) memory_full ();
545 /* Like free but block interrupt input.. */
557 /* Like strdup, but uses xmalloc. */
563 size_t len
= strlen (s
) + 1;
564 char *p
= (char *) xmalloc (len
);
570 /* Like malloc but used for allocating Lisp data. NBYTES is the
571 number of bytes to allocate, TYPE describes the intended use of the
572 allcated memory block (for strings, for conses, ...). */
574 static POINTER_TYPE
*
575 lisp_malloc (nbytes
, type
)
583 #ifdef GC_MALLOC_CHECK
584 allocated_mem_type
= type
;
587 val
= (void *) malloc (nbytes
);
589 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
590 if (val
&& type
!= MEM_TYPE_NON_LISP
)
591 mem_insert (val
, (char *) val
+ nbytes
, type
);
601 /* Return a new buffer structure allocated from the heap with
602 a call to lisp_malloc. */
607 return (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
612 /* Free BLOCK. This must be called to free memory allocated with a
613 call to lisp_malloc. */
621 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
622 mem_delete (mem_find (block
));
628 /* Arranging to disable input signals while we're in malloc.
630 This only works with GNU malloc. To help out systems which can't
631 use GNU malloc, all the calls to malloc, realloc, and free
632 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
633 pairs; unfortunately, we have no idea what C library functions
634 might call malloc, so we can't really protect them unless you're
635 using GNU malloc. Fortunately, most of the major operating can use
638 #ifndef SYSTEM_MALLOC
639 #ifndef DOUG_LEA_MALLOC
640 extern void * (*__malloc_hook
) P_ ((size_t));
641 extern void * (*__realloc_hook
) P_ ((void *, size_t));
642 extern void (*__free_hook
) P_ ((void *));
643 /* Else declared in malloc.h, perhaps with an extra arg. */
644 #endif /* DOUG_LEA_MALLOC */
645 static void * (*old_malloc_hook
) ();
646 static void * (*old_realloc_hook
) ();
647 static void (*old_free_hook
) ();
649 /* This function is used as the hook for free to call. */
652 emacs_blocked_free (ptr
)
657 #ifdef GC_MALLOC_CHECK
662 if (m
== MEM_NIL
|| m
->start
!= ptr
)
665 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
670 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
674 #endif /* GC_MALLOC_CHECK */
676 __free_hook
= old_free_hook
;
679 /* If we released our reserve (due to running out of memory),
680 and we have a fair amount free once again,
681 try to set aside another reserve in case we run out once more. */
682 if (spare_memory
== 0
683 /* Verify there is enough space that even with the malloc
684 hysteresis this call won't run out again.
685 The code here is correct as long as SPARE_MEMORY
686 is substantially larger than the block size malloc uses. */
687 && (bytes_used_when_full
688 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
689 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
691 __free_hook
= emacs_blocked_free
;
696 /* If we released our reserve (due to running out of memory),
697 and we have a fair amount free once again,
698 try to set aside another reserve in case we run out once more.
700 This is called when a relocatable block is freed in ralloc.c. */
703 refill_memory_reserve ()
705 if (spare_memory
== 0)
706 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
710 /* This function is the malloc hook that Emacs uses. */
713 emacs_blocked_malloc (size
)
719 __malloc_hook
= old_malloc_hook
;
720 #ifdef DOUG_LEA_MALLOC
721 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
723 __malloc_extra_blocks
= malloc_hysteresis
;
726 value
= (void *) malloc (size
);
728 #ifdef GC_MALLOC_CHECK
730 struct mem_node
*m
= mem_find (value
);
733 fprintf (stderr
, "Malloc returned %p which is already in use\n",
735 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
736 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
741 if (!dont_register_blocks
)
743 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
744 allocated_mem_type
= MEM_TYPE_NON_LISP
;
747 #endif /* GC_MALLOC_CHECK */
749 __malloc_hook
= emacs_blocked_malloc
;
752 /* fprintf (stderr, "%p malloc\n", value); */
757 /* This function is the realloc hook that Emacs uses. */
760 emacs_blocked_realloc (ptr
, size
)
767 __realloc_hook
= old_realloc_hook
;
769 #ifdef GC_MALLOC_CHECK
772 struct mem_node
*m
= mem_find (ptr
);
773 if (m
== MEM_NIL
|| m
->start
!= ptr
)
776 "Realloc of %p which wasn't allocated with malloc\n",
784 /* fprintf (stderr, "%p -> realloc\n", ptr); */
786 /* Prevent malloc from registering blocks. */
787 dont_register_blocks
= 1;
788 #endif /* GC_MALLOC_CHECK */
790 value
= (void *) realloc (ptr
, size
);
792 #ifdef GC_MALLOC_CHECK
793 dont_register_blocks
= 0;
796 struct mem_node
*m
= mem_find (value
);
799 fprintf (stderr
, "Realloc returns memory that is already in use\n");
803 /* Can't handle zero size regions in the red-black tree. */
804 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
807 /* fprintf (stderr, "%p <- realloc\n", value); */
808 #endif /* GC_MALLOC_CHECK */
810 __realloc_hook
= emacs_blocked_realloc
;
817 /* Called from main to set up malloc to use our hooks. */
820 uninterrupt_malloc ()
822 if (__free_hook
!= emacs_blocked_free
)
823 old_free_hook
= __free_hook
;
824 __free_hook
= emacs_blocked_free
;
826 if (__malloc_hook
!= emacs_blocked_malloc
)
827 old_malloc_hook
= __malloc_hook
;
828 __malloc_hook
= emacs_blocked_malloc
;
830 if (__realloc_hook
!= emacs_blocked_realloc
)
831 old_realloc_hook
= __realloc_hook
;
832 __realloc_hook
= emacs_blocked_realloc
;
835 #endif /* not SYSTEM_MALLOC */
839 /***********************************************************************
841 ***********************************************************************/
843 /* Number of intervals allocated in an interval_block structure.
844 The 1020 is 1024 minus malloc overhead. */
846 #define INTERVAL_BLOCK_SIZE \
847 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
849 /* Intervals are allocated in chunks in form of an interval_block
852 struct interval_block
854 struct interval_block
*next
;
855 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
858 /* Current interval block. Its `next' pointer points to older
861 struct interval_block
*interval_block
;
863 /* Index in interval_block above of the next unused interval
866 static int interval_block_index
;
868 /* Number of free and live intervals. */
870 static int total_free_intervals
, total_intervals
;
872 /* List of free intervals. */
874 INTERVAL interval_free_list
;
876 /* Total number of interval blocks now in use. */
878 int n_interval_blocks
;
881 /* Initialize interval allocation. */
887 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
889 interval_block
->next
= 0;
890 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
891 interval_block_index
= 0;
892 interval_free_list
= 0;
893 n_interval_blocks
= 1;
897 /* Return a new interval. */
904 if (interval_free_list
)
906 val
= interval_free_list
;
907 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
911 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
913 register struct interval_block
*newi
;
915 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
918 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
919 newi
->next
= interval_block
;
920 interval_block
= newi
;
921 interval_block_index
= 0;
924 val
= &interval_block
->intervals
[interval_block_index
++];
926 consing_since_gc
+= sizeof (struct interval
);
928 RESET_INTERVAL (val
);
933 /* Mark Lisp objects in interval I. */
936 mark_interval (i
, dummy
)
940 if (XMARKBIT (i
->plist
))
942 mark_object (&i
->plist
);
947 /* Mark the interval tree rooted in TREE. Don't call this directly;
948 use the macro MARK_INTERVAL_TREE instead. */
951 mark_interval_tree (tree
)
952 register INTERVAL tree
;
954 /* No need to test if this tree has been marked already; this
955 function is always called through the MARK_INTERVAL_TREE macro,
956 which takes care of that. */
958 /* XMARK expands to an assignment; the LHS of an assignment can't be
960 XMARK (tree
->up
.obj
);
962 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
966 /* Mark the interval tree rooted in I. */
968 #define MARK_INTERVAL_TREE(i) \
970 if (!NULL_INTERVAL_P (i) \
971 && ! XMARKBIT (i->up.obj)) \
972 mark_interval_tree (i); \
976 /* The oddity in the call to XUNMARK is necessary because XUNMARK
977 expands to an assignment to its argument, and most C compilers
978 don't support casts on the left operand of `='. */
980 #define UNMARK_BALANCE_INTERVALS(i) \
982 if (! NULL_INTERVAL_P (i)) \
984 XUNMARK ((i)->up.obj); \
985 (i) = balance_intervals (i); \
990 /* Number support. If NO_UNION_TYPE isn't in effect, we
991 can't create number objects in macros. */
999 obj
.s
.type
= Lisp_Int
;
1004 /***********************************************************************
1006 ***********************************************************************/
1008 /* Lisp_Strings are allocated in string_block structures. When a new
1009 string_block is allocated, all the Lisp_Strings it contains are
1010 added to a free-list stiing_free_list. When a new Lisp_String is
1011 needed, it is taken from that list. During the sweep phase of GC,
1012 string_blocks that are entirely free are freed, except two which
1015 String data is allocated from sblock structures. Strings larger
1016 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1017 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1019 Sblocks consist internally of sdata structures, one for each
1020 Lisp_String. The sdata structure points to the Lisp_String it
1021 belongs to. The Lisp_String points back to the `u.data' member of
1022 its sdata structure.
1024 When a Lisp_String is freed during GC, it is put back on
1025 string_free_list, and its `data' member and its sdata's `string'
1026 pointer is set to null. The size of the string is recorded in the
1027 `u.nbytes' member of the sdata. So, sdata structures that are no
1028 longer used, can be easily recognized, and it's easy to compact the
1029 sblocks of small strings which we do in compact_small_strings. */
1031 /* Size in bytes of an sblock structure used for small strings. This
1032 is 8192 minus malloc overhead. */
1034 #define SBLOCK_SIZE 8188
1036 /* Strings larger than this are considered large strings. String data
1037 for large strings is allocated from individual sblocks. */
1039 #define LARGE_STRING_BYTES 1024
1041 /* Structure describing string memory sub-allocated from an sblock.
1042 This is where the contents of Lisp strings are stored. */
1046 /* Back-pointer to the string this sdata belongs to. If null, this
1047 structure is free, and the NBYTES member of the union below
1048 contains the string's byte size (the same value that STRING_BYTES
1049 would return if STRING were non-null). If non-null, STRING_BYTES
1050 (STRING) is the size of the data, and DATA contains the string's
1052 struct Lisp_String
*string
;
1054 #ifdef GC_CHECK_STRING_BYTES
1057 unsigned char data
[1];
1059 #define SDATA_NBYTES(S) (S)->nbytes
1060 #define SDATA_DATA(S) (S)->data
1062 #else /* not GC_CHECK_STRING_BYTES */
1066 /* When STRING in non-null. */
1067 unsigned char data
[1];
1069 /* When STRING is null. */
1074 #define SDATA_NBYTES(S) (S)->u.nbytes
1075 #define SDATA_DATA(S) (S)->u.data
1077 #endif /* not GC_CHECK_STRING_BYTES */
1081 /* Structure describing a block of memory which is sub-allocated to
1082 obtain string data memory for strings. Blocks for small strings
1083 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1084 as large as needed. */
1089 struct sblock
*next
;
1091 /* Pointer to the next free sdata block. This points past the end
1092 of the sblock if there isn't any space left in this block. */
1093 struct sdata
*next_free
;
1095 /* Start of data. */
1096 struct sdata first_data
;
1099 /* Number of Lisp strings in a string_block structure. The 1020 is
1100 1024 minus malloc overhead. */
1102 #define STRINGS_IN_STRING_BLOCK \
1103 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1105 /* Structure describing a block from which Lisp_String structures
1110 struct string_block
*next
;
1111 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
1114 /* Head and tail of the list of sblock structures holding Lisp string
1115 data. We always allocate from current_sblock. The NEXT pointers
1116 in the sblock structures go from oldest_sblock to current_sblock. */
1118 static struct sblock
*oldest_sblock
, *current_sblock
;
1120 /* List of sblocks for large strings. */
1122 static struct sblock
*large_sblocks
;
1124 /* List of string_block structures, and how many there are. */
1126 static struct string_block
*string_blocks
;
1127 static int n_string_blocks
;
1129 /* Free-list of Lisp_Strings. */
1131 static struct Lisp_String
*string_free_list
;
1133 /* Number of live and free Lisp_Strings. */
1135 static int total_strings
, total_free_strings
;
1137 /* Number of bytes used by live strings. */
1139 static int total_string_size
;
1141 /* Given a pointer to a Lisp_String S which is on the free-list
1142 string_free_list, return a pointer to its successor in the
1145 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1147 /* Return a pointer to the sdata structure belonging to Lisp string S.
1148 S must be live, i.e. S->data must not be null. S->data is actually
1149 a pointer to the `u.data' member of its sdata structure; the
1150 structure starts at a constant offset in front of that. */
1152 #ifdef GC_CHECK_STRING_BYTES
1154 #define SDATA_OF_STRING(S) \
1155 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1156 - sizeof (EMACS_INT)))
1158 #else /* not GC_CHECK_STRING_BYTES */
1160 #define SDATA_OF_STRING(S) \
1161 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1163 #endif /* not GC_CHECK_STRING_BYTES */
1165 /* Value is the size of an sdata structure large enough to hold NBYTES
1166 bytes of string data. The value returned includes a terminating
1167 NUL byte, the size of the sdata structure, and padding. */
1169 #ifdef GC_CHECK_STRING_BYTES
1171 #define SDATA_SIZE(NBYTES) \
1172 ((sizeof (struct Lisp_String *) \
1174 + sizeof (EMACS_INT) \
1175 + sizeof (EMACS_INT) - 1) \
1176 & ~(sizeof (EMACS_INT) - 1))
1178 #else /* not GC_CHECK_STRING_BYTES */
1180 #define SDATA_SIZE(NBYTES) \
1181 ((sizeof (struct Lisp_String *) \
1183 + sizeof (EMACS_INT) - 1) \
1184 & ~(sizeof (EMACS_INT) - 1))
1186 #endif /* not GC_CHECK_STRING_BYTES */
1188 /* Initialize string allocation. Called from init_alloc_once. */
1193 total_strings
= total_free_strings
= total_string_size
= 0;
1194 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1195 string_blocks
= NULL
;
1196 n_string_blocks
= 0;
1197 string_free_list
= NULL
;
1201 #ifdef GC_CHECK_STRING_BYTES
1203 /* Check validity of all live Lisp strings' string_bytes member.
1204 Used for hunting a bug. */
1206 static int check_string_bytes_count
;
1209 check_string_bytes ()
1213 for (b
= large_sblocks
; b
; b
= b
->next
)
1215 struct Lisp_String
*s
= b
->first_data
.string
;
1216 if (s
&& GC_STRING_BYTES (s
) != SDATA_NBYTES (SDATA_OF_STRING (s
)))
1220 for (b
= oldest_sblock
; b
; b
= b
->next
)
1222 struct sdata
*from
, *end
, *from_end
;
1226 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1228 /* Compute the next FROM here because copying below may
1229 overwrite data we need to compute it. */
1232 /* Check that the string size recorded in the string is the
1233 same as the one recorded in the sdata structure. */
1235 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1239 nbytes
= GC_STRING_BYTES (from
->string
);
1241 nbytes
= SDATA_NBYTES (from
);
1243 nbytes
= SDATA_SIZE (nbytes
);
1244 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1249 #endif /* GC_CHECK_STRING_BYTES */
1252 /* Return a new Lisp_String. */
1254 static struct Lisp_String
*
1257 struct Lisp_String
*s
;
1259 /* If the free-list is empty, allocate a new string_block, and
1260 add all the Lisp_Strings in it to the free-list. */
1261 if (string_free_list
== NULL
)
1263 struct string_block
*b
;
1266 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1267 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
1268 bzero (b
, sizeof *b
);
1269 b
->next
= string_blocks
;
1273 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
1276 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1277 string_free_list
= s
;
1280 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
1283 /* Pop a Lisp_String off the free-list. */
1284 s
= string_free_list
;
1285 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1287 /* Probably not strictly necessary, but play it safe. */
1288 bzero (s
, sizeof *s
);
1290 --total_free_strings
;
1293 consing_since_gc
+= sizeof *s
;
1295 #ifdef GC_CHECK_STRING_BYTES
1296 if (!noninteractive
&& ++check_string_bytes_count
== 50)
1298 check_string_bytes_count
= 0;
1299 check_string_bytes ();
1307 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1308 plus a NUL byte at the end. Allocate an sdata structure for S, and
1309 set S->data to its `u.data' member. Store a NUL byte at the end of
1310 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1311 S->data if it was initially non-null. */
1314 allocate_string_data (s
, nchars
, nbytes
)
1315 struct Lisp_String
*s
;
1318 struct sdata
*data
, *old_data
;
1320 int needed
, old_nbytes
;
1322 /* Determine the number of bytes needed to store NBYTES bytes
1324 needed
= SDATA_SIZE (nbytes
);
1326 if (nbytes
> LARGE_STRING_BYTES
)
1328 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1330 #ifdef DOUG_LEA_MALLOC
1331 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1332 because mapped region contents are not preserved in
1334 mallopt (M_MMAP_MAX
, 0);
1337 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1339 #ifdef DOUG_LEA_MALLOC
1340 /* Back to a reasonable maximum of mmap'ed areas. */
1341 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1344 b
->next_free
= &b
->first_data
;
1345 b
->first_data
.string
= NULL
;
1346 b
->next
= large_sblocks
;
1349 else if (current_sblock
== NULL
1350 || (((char *) current_sblock
+ SBLOCK_SIZE
1351 - (char *) current_sblock
->next_free
)
1354 /* Not enough room in the current sblock. */
1355 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1356 b
->next_free
= &b
->first_data
;
1357 b
->first_data
.string
= NULL
;
1361 current_sblock
->next
= b
;
1369 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1370 old_nbytes
= GC_STRING_BYTES (s
);
1372 data
= b
->next_free
;
1374 s
->data
= SDATA_DATA (data
);
1375 #ifdef GC_CHECK_STRING_BYTES
1376 SDATA_NBYTES (data
) = nbytes
;
1379 s
->size_byte
= nbytes
;
1380 s
->data
[nbytes
] = '\0';
1381 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1383 /* If S had already data assigned, mark that as free by setting its
1384 string back-pointer to null, and recording the size of the data
1388 SDATA_NBYTES (old_data
) = old_nbytes
;
1389 old_data
->string
= NULL
;
1392 consing_since_gc
+= needed
;
1396 /* Sweep and compact strings. */
1401 struct string_block
*b
, *next
;
1402 struct string_block
*live_blocks
= NULL
;
1404 string_free_list
= NULL
;
1405 total_strings
= total_free_strings
= 0;
1406 total_string_size
= 0;
1408 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1409 for (b
= string_blocks
; b
; b
= next
)
1412 struct Lisp_String
*free_list_before
= string_free_list
;
1416 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1418 struct Lisp_String
*s
= b
->strings
+ i
;
1422 /* String was not on free-list before. */
1423 if (STRING_MARKED_P (s
))
1425 /* String is live; unmark it and its intervals. */
1428 if (!NULL_INTERVAL_P (s
->intervals
))
1429 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1432 total_string_size
+= STRING_BYTES (s
);
1436 /* String is dead. Put it on the free-list. */
1437 struct sdata
*data
= SDATA_OF_STRING (s
);
1439 /* Save the size of S in its sdata so that we know
1440 how large that is. Reset the sdata's string
1441 back-pointer so that we know it's free. */
1442 #ifdef GC_CHECK_STRING_BYTES
1443 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1446 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1448 data
->string
= NULL
;
1450 /* Reset the strings's `data' member so that we
1454 /* Put the string on the free-list. */
1455 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1456 string_free_list
= s
;
1462 /* S was on the free-list before. Put it there again. */
1463 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1464 string_free_list
= s
;
1469 /* Free blocks that contain free Lisp_Strings only, except
1470 the first two of them. */
1471 if (nfree
== STRINGS_IN_STRING_BLOCK
1472 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1476 string_free_list
= free_list_before
;
1480 total_free_strings
+= nfree
;
1481 b
->next
= live_blocks
;
1486 string_blocks
= live_blocks
;
1487 free_large_strings ();
1488 compact_small_strings ();
1492 /* Free dead large strings. */
1495 free_large_strings ()
1497 struct sblock
*b
, *next
;
1498 struct sblock
*live_blocks
= NULL
;
1500 for (b
= large_sblocks
; b
; b
= next
)
1504 if (b
->first_data
.string
== NULL
)
1508 b
->next
= live_blocks
;
1513 large_sblocks
= live_blocks
;
1517 /* Compact data of small strings. Free sblocks that don't contain
1518 data of live strings after compaction. */
1521 compact_small_strings ()
1523 struct sblock
*b
, *tb
, *next
;
1524 struct sdata
*from
, *to
, *end
, *tb_end
;
1525 struct sdata
*to_end
, *from_end
;
1527 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1528 to, and TB_END is the end of TB. */
1530 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1531 to
= &tb
->first_data
;
1533 /* Step through the blocks from the oldest to the youngest. We
1534 expect that old blocks will stabilize over time, so that less
1535 copying will happen this way. */
1536 for (b
= oldest_sblock
; b
; b
= b
->next
)
1539 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1541 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1543 /* Compute the next FROM here because copying below may
1544 overwrite data we need to compute it. */
1547 #ifdef GC_CHECK_STRING_BYTES
1548 /* Check that the string size recorded in the string is the
1549 same as the one recorded in the sdata structure. */
1551 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1553 #endif /* GC_CHECK_STRING_BYTES */
1556 nbytes
= GC_STRING_BYTES (from
->string
);
1558 nbytes
= SDATA_NBYTES (from
);
1560 nbytes
= SDATA_SIZE (nbytes
);
1561 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1563 /* FROM->string non-null means it's alive. Copy its data. */
1566 /* If TB is full, proceed with the next sblock. */
1567 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1568 if (to_end
> tb_end
)
1572 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1573 to
= &tb
->first_data
;
1574 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1577 /* Copy, and update the string's `data' pointer. */
1580 xassert (tb
!= b
|| to
<= from
);
1581 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1582 to
->string
->data
= SDATA_DATA (to
);
1585 /* Advance past the sdata we copied to. */
1591 /* The rest of the sblocks following TB don't contain live data, so
1592 we can free them. */
1593 for (b
= tb
->next
; b
; b
= next
)
1601 current_sblock
= tb
;
1605 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1606 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1607 Both LENGTH and INIT must be numbers.")
1609 Lisp_Object length
, init
;
1611 register Lisp_Object val
;
1612 register unsigned char *p
, *end
;
1615 CHECK_NATNUM (length
, 0);
1616 CHECK_NUMBER (init
, 1);
1619 if (SINGLE_BYTE_CHAR_P (c
))
1621 nbytes
= XINT (length
);
1622 val
= make_uninit_string (nbytes
);
1623 p
= XSTRING (val
)->data
;
1624 end
= p
+ XSTRING (val
)->size
;
1630 unsigned char str
[4];
1631 int len
= CHAR_STRING (c
, str
);
1633 nbytes
= len
* XINT (length
);
1634 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1635 p
= XSTRING (val
)->data
;
1639 bcopy (str
, p
, len
);
1649 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1650 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1651 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1653 Lisp_Object length
, init
;
1655 register Lisp_Object val
;
1656 struct Lisp_Bool_Vector
*p
;
1658 int length_in_chars
, length_in_elts
, bits_per_value
;
1660 CHECK_NATNUM (length
, 0);
1662 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1664 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1665 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1667 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1668 slot `size' of the struct Lisp_Bool_Vector. */
1669 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1670 p
= XBOOL_VECTOR (val
);
1672 /* Get rid of any bits that would cause confusion. */
1674 XSETBOOL_VECTOR (val
, p
);
1675 p
->size
= XFASTINT (length
);
1677 real_init
= (NILP (init
) ? 0 : -1);
1678 for (i
= 0; i
< length_in_chars
; i
++)
1679 p
->data
[i
] = real_init
;
1681 /* Clear the extraneous bits in the last byte. */
1682 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1683 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1684 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1690 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1691 of characters from the contents. This string may be unibyte or
1692 multibyte, depending on the contents. */
1695 make_string (contents
, nbytes
)
1699 register Lisp_Object val
;
1700 int nchars
, multibyte_nbytes
;
1702 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1703 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1704 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1705 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1706 /* CONTENTS contains no multibyte sequences or contains an invalid
1707 multibyte sequence. We must make unibyte string. */
1708 SET_STRING_BYTES (XSTRING (val
), -1);
1713 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1716 make_unibyte_string (contents
, length
)
1720 register Lisp_Object val
;
1721 val
= make_uninit_string (length
);
1722 bcopy (contents
, XSTRING (val
)->data
, length
);
1723 SET_STRING_BYTES (XSTRING (val
), -1);
1728 /* Make a multibyte string from NCHARS characters occupying NBYTES
1729 bytes at CONTENTS. */
1732 make_multibyte_string (contents
, nchars
, nbytes
)
1736 register Lisp_Object val
;
1737 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1738 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1743 /* Make a string from NCHARS characters occupying NBYTES bytes at
1744 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1747 make_string_from_bytes (contents
, nchars
, nbytes
)
1751 register Lisp_Object val
;
1752 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1753 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1754 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1755 SET_STRING_BYTES (XSTRING (val
), -1);
1760 /* Make a string from NCHARS characters occupying NBYTES bytes at
1761 CONTENTS. The argument MULTIBYTE controls whether to label the
1762 string as multibyte. */
1765 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1770 register Lisp_Object val
;
1771 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1772 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1774 SET_STRING_BYTES (XSTRING (val
), -1);
1779 /* Make a string from the data at STR, treating it as multibyte if the
1786 return make_string (str
, strlen (str
));
1790 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1791 occupying LENGTH bytes. */
1794 make_uninit_string (length
)
1798 val
= make_uninit_multibyte_string (length
, length
);
1799 SET_STRING_BYTES (XSTRING (val
), -1);
1804 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1805 which occupy NBYTES bytes. */
1808 make_uninit_multibyte_string (nchars
, nbytes
)
1812 struct Lisp_String
*s
;
1817 s
= allocate_string ();
1818 allocate_string_data (s
, nchars
, nbytes
);
1819 XSETSTRING (string
, s
);
1820 string_chars_consed
+= nbytes
;
1826 /***********************************************************************
1828 ***********************************************************************/
1830 /* We store float cells inside of float_blocks, allocating a new
1831 float_block with malloc whenever necessary. Float cells reclaimed
1832 by GC are put on a free list to be reallocated before allocating
1833 any new float cells from the latest float_block.
1835 Each float_block is just under 1020 bytes long, since malloc really
1836 allocates in units of powers of two and uses 4 bytes for its own
1839 #define FLOAT_BLOCK_SIZE \
1840 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1844 struct float_block
*next
;
1845 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1848 /* Current float_block. */
1850 struct float_block
*float_block
;
1852 /* Index of first unused Lisp_Float in the current float_block. */
1854 int float_block_index
;
1856 /* Total number of float blocks now in use. */
1860 /* Free-list of Lisp_Floats. */
1862 struct Lisp_Float
*float_free_list
;
1865 /* Initialze float allocation. */
1870 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1872 float_block
->next
= 0;
1873 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1874 float_block_index
= 0;
1875 float_free_list
= 0;
1880 /* Explicitly free a float cell by putting it on the free-list. */
1884 struct Lisp_Float
*ptr
;
1886 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1890 float_free_list
= ptr
;
1894 /* Return a new float object with value FLOAT_VALUE. */
1897 make_float (float_value
)
1900 register Lisp_Object val
;
1902 if (float_free_list
)
1904 /* We use the data field for chaining the free list
1905 so that we won't use the same field that has the mark bit. */
1906 XSETFLOAT (val
, float_free_list
);
1907 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1911 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1913 register struct float_block
*new;
1915 new = (struct float_block
*) lisp_malloc (sizeof *new,
1917 VALIDATE_LISP_STORAGE (new, sizeof *new);
1918 new->next
= float_block
;
1920 float_block_index
= 0;
1923 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1926 XFLOAT_DATA (val
) = float_value
;
1927 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1928 consing_since_gc
+= sizeof (struct Lisp_Float
);
1935 /***********************************************************************
1937 ***********************************************************************/
1939 /* We store cons cells inside of cons_blocks, allocating a new
1940 cons_block with malloc whenever necessary. Cons cells reclaimed by
1941 GC are put on a free list to be reallocated before allocating
1942 any new cons cells from the latest cons_block.
1944 Each cons_block is just under 1020 bytes long,
1945 since malloc really allocates in units of powers of two
1946 and uses 4 bytes for its own overhead. */
1948 #define CONS_BLOCK_SIZE \
1949 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1953 struct cons_block
*next
;
1954 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1957 /* Current cons_block. */
1959 struct cons_block
*cons_block
;
1961 /* Index of first unused Lisp_Cons in the current block. */
1963 int cons_block_index
;
1965 /* Free-list of Lisp_Cons structures. */
1967 struct Lisp_Cons
*cons_free_list
;
1969 /* Total number of cons blocks now in use. */
1974 /* Initialize cons allocation. */
1979 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1981 cons_block
->next
= 0;
1982 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1983 cons_block_index
= 0;
1989 /* Explicitly free a cons cell by putting it on the free-list. */
1993 struct Lisp_Cons
*ptr
;
1995 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
1999 cons_free_list
= ptr
;
2003 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2004 "Create a new cons, give it CAR and CDR as components, and return it.")
2006 Lisp_Object car
, cdr
;
2008 register Lisp_Object val
;
2012 /* We use the cdr for chaining the free list
2013 so that we won't use the same field that has the mark bit. */
2014 XSETCONS (val
, cons_free_list
);
2015 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2019 if (cons_block_index
== CONS_BLOCK_SIZE
)
2021 register struct cons_block
*new;
2022 new = (struct cons_block
*) lisp_malloc (sizeof *new,
2024 VALIDATE_LISP_STORAGE (new, sizeof *new);
2025 new->next
= cons_block
;
2027 cons_block_index
= 0;
2030 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
2035 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2036 cons_cells_consed
++;
2041 /* Make a list of 2, 3, 4 or 5 specified objects. */
2045 Lisp_Object arg1
, arg2
;
2047 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2052 list3 (arg1
, arg2
, arg3
)
2053 Lisp_Object arg1
, arg2
, arg3
;
2055 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2060 list4 (arg1
, arg2
, arg3
, arg4
)
2061 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2063 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2068 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2069 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2071 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2072 Fcons (arg5
, Qnil
)))));
2076 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2077 "Return a newly created list with specified arguments as elements.\n\
2078 Any number of arguments, even zero arguments, are allowed.")
2081 register Lisp_Object
*args
;
2083 register Lisp_Object val
;
2089 val
= Fcons (args
[nargs
], val
);
2095 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2096 "Return a newly created list of length LENGTH, with each element being INIT.")
2098 register Lisp_Object length
, init
;
2100 register Lisp_Object val
;
2103 CHECK_NATNUM (length
, 0);
2104 size
= XFASTINT (length
);
2108 val
= Fcons (init
, val
);
2114 /***********************************************************************
2116 ***********************************************************************/
2118 /* Singly-linked list of all vectors. */
2120 struct Lisp_Vector
*all_vectors
;
2122 /* Total number of vector-like objects now in use. */
2127 /* Value is a pointer to a newly allocated Lisp_Vector structure
2128 with room for LEN Lisp_Objects. */
2130 struct Lisp_Vector
*
2131 allocate_vectorlike (len
)
2134 struct Lisp_Vector
*p
;
2137 #ifdef DOUG_LEA_MALLOC
2138 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2139 because mapped region contents are not preserved in
2141 mallopt (M_MMAP_MAX
, 0);
2144 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2145 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
2147 #ifdef DOUG_LEA_MALLOC
2148 /* Back to a reasonable maximum of mmap'ed areas. */
2149 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2152 VALIDATE_LISP_STORAGE (p
, 0);
2153 consing_since_gc
+= nbytes
;
2154 vector_cells_consed
+= len
;
2156 p
->next
= all_vectors
;
2163 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2164 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
2165 See also the function `vector'.")
2167 register Lisp_Object length
, init
;
2170 register EMACS_INT sizei
;
2172 register struct Lisp_Vector
*p
;
2174 CHECK_NATNUM (length
, 0);
2175 sizei
= XFASTINT (length
);
2177 p
= allocate_vectorlike (sizei
);
2179 for (index
= 0; index
< sizei
; index
++)
2180 p
->contents
[index
] = init
;
2182 XSETVECTOR (vector
, p
);
2187 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2188 "Return a newly created char-table, with purpose PURPOSE.\n\
2189 Each element is initialized to INIT, which defaults to nil.\n\
2190 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
2191 The property's value should be an integer between 0 and 10.")
2193 register Lisp_Object purpose
, init
;
2197 CHECK_SYMBOL (purpose
, 1);
2198 n
= Fget (purpose
, Qchar_table_extra_slots
);
2199 CHECK_NUMBER (n
, 0);
2200 if (XINT (n
) < 0 || XINT (n
) > 10)
2201 args_out_of_range (n
, Qnil
);
2202 /* Add 2 to the size for the defalt and parent slots. */
2203 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2205 XCHAR_TABLE (vector
)->top
= Qt
;
2206 XCHAR_TABLE (vector
)->parent
= Qnil
;
2207 XCHAR_TABLE (vector
)->purpose
= purpose
;
2208 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2213 /* Return a newly created sub char table with default value DEFALT.
2214 Since a sub char table does not appear as a top level Emacs Lisp
2215 object, we don't need a Lisp interface to make it. */
2218 make_sub_char_table (defalt
)
2222 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2223 XCHAR_TABLE (vector
)->top
= Qnil
;
2224 XCHAR_TABLE (vector
)->defalt
= defalt
;
2225 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2230 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2231 "Return a newly created vector with specified arguments as elements.\n\
2232 Any number of arguments, even zero arguments, are allowed.")
2237 register Lisp_Object len
, val
;
2239 register struct Lisp_Vector
*p
;
2241 XSETFASTINT (len
, nargs
);
2242 val
= Fmake_vector (len
, Qnil
);
2244 for (index
= 0; index
< nargs
; index
++)
2245 p
->contents
[index
] = args
[index
];
2250 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2251 "Create a byte-code object with specified arguments as elements.\n\
2252 The arguments should be the arglist, bytecode-string, constant vector,\n\
2253 stack size, (optional) doc string, and (optional) interactive spec.\n\
2254 The first four arguments are required; at most six have any\n\
2260 register Lisp_Object len
, val
;
2262 register struct Lisp_Vector
*p
;
2264 XSETFASTINT (len
, nargs
);
2265 if (!NILP (Vpurify_flag
))
2266 val
= make_pure_vector ((EMACS_INT
) nargs
);
2268 val
= Fmake_vector (len
, Qnil
);
2270 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2271 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2272 earlier because they produced a raw 8-bit string for byte-code
2273 and now such a byte-code string is loaded as multibyte while
2274 raw 8-bit characters converted to multibyte form. Thus, now we
2275 must convert them back to the original unibyte form. */
2276 args
[1] = Fstring_as_unibyte (args
[1]);
2279 for (index
= 0; index
< nargs
; index
++)
2281 if (!NILP (Vpurify_flag
))
2282 args
[index
] = Fpurecopy (args
[index
]);
2283 p
->contents
[index
] = args
[index
];
2285 XSETCOMPILED (val
, p
);
2291 /***********************************************************************
2293 ***********************************************************************/
2295 /* Each symbol_block is just under 1020 bytes long, since malloc
2296 really allocates in units of powers of two and uses 4 bytes for its
2299 #define SYMBOL_BLOCK_SIZE \
2300 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2304 struct symbol_block
*next
;
2305 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2308 /* Current symbol block and index of first unused Lisp_Symbol
2311 struct symbol_block
*symbol_block
;
2312 int symbol_block_index
;
2314 /* List of free symbols. */
2316 struct Lisp_Symbol
*symbol_free_list
;
2318 /* Total number of symbol blocks now in use. */
2320 int n_symbol_blocks
;
2323 /* Initialize symbol allocation. */
2328 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
2330 symbol_block
->next
= 0;
2331 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
2332 symbol_block_index
= 0;
2333 symbol_free_list
= 0;
2334 n_symbol_blocks
= 1;
2338 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2339 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2340 Its value and function definition are void, and its property list is nil.")
2344 register Lisp_Object val
;
2345 register struct Lisp_Symbol
*p
;
2347 CHECK_STRING (name
, 0);
2349 if (symbol_free_list
)
2351 XSETSYMBOL (val
, symbol_free_list
);
2352 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2356 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2358 struct symbol_block
*new;
2359 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2361 VALIDATE_LISP_STORAGE (new, sizeof *new);
2362 new->next
= symbol_block
;
2364 symbol_block_index
= 0;
2367 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2371 p
->name
= XSTRING (name
);
2374 p
->value
= Qunbound
;
2375 p
->function
= Qunbound
;
2377 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2384 /***********************************************************************
2385 Marker (Misc) Allocation
2386 ***********************************************************************/
2388 /* Allocation of markers and other objects that share that structure.
2389 Works like allocation of conses. */
2391 #define MARKER_BLOCK_SIZE \
2392 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2396 struct marker_block
*next
;
2397 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2400 struct marker_block
*marker_block
;
2401 int marker_block_index
;
2403 union Lisp_Misc
*marker_free_list
;
2405 /* Total number of marker blocks now in use. */
2407 int n_marker_blocks
;
2412 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2414 marker_block
->next
= 0;
2415 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2416 marker_block_index
= 0;
2417 marker_free_list
= 0;
2418 n_marker_blocks
= 1;
2421 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2428 if (marker_free_list
)
2430 XSETMISC (val
, marker_free_list
);
2431 marker_free_list
= marker_free_list
->u_free
.chain
;
2435 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2437 struct marker_block
*new;
2438 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2440 VALIDATE_LISP_STORAGE (new, sizeof *new);
2441 new->next
= marker_block
;
2443 marker_block_index
= 0;
2446 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2449 consing_since_gc
+= sizeof (union Lisp_Misc
);
2450 misc_objects_consed
++;
2454 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2455 "Return a newly allocated marker which does not point at any place.")
2458 register Lisp_Object val
;
2459 register struct Lisp_Marker
*p
;
2461 val
= allocate_misc ();
2462 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2468 p
->insertion_type
= 0;
2472 /* Put MARKER back on the free list after using it temporarily. */
2475 free_marker (marker
)
2478 unchain_marker (marker
);
2480 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2481 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2482 marker_free_list
= XMISC (marker
);
2484 total_free_markers
++;
2488 /* Return a newly created vector or string with specified arguments as
2489 elements. If all the arguments are characters that can fit
2490 in a string of events, make a string; otherwise, make a vector.
2492 Any number of arguments, even zero arguments, are allowed. */
2495 make_event_array (nargs
, args
)
2501 for (i
= 0; i
< nargs
; i
++)
2502 /* The things that fit in a string
2503 are characters that are in 0...127,
2504 after discarding the meta bit and all the bits above it. */
2505 if (!INTEGERP (args
[i
])
2506 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2507 return Fvector (nargs
, args
);
2509 /* Since the loop exited, we know that all the things in it are
2510 characters, so we can make a string. */
2514 result
= Fmake_string (make_number (nargs
), make_number (0));
2515 for (i
= 0; i
< nargs
; i
++)
2517 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2518 /* Move the meta bit to the right place for a string char. */
2519 if (XINT (args
[i
]) & CHAR_META
)
2520 XSTRING (result
)->data
[i
] |= 0x80;
2529 /************************************************************************
2531 ************************************************************************/
2533 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
2535 /* Initialize this part of alloc.c. */
2540 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2541 mem_z
.parent
= NULL
;
2542 mem_z
.color
= MEM_BLACK
;
2543 mem_z
.start
= mem_z
.end
= NULL
;
2548 /* Value is a pointer to the mem_node containing START. Value is
2549 MEM_NIL if there is no node in the tree containing START. */
2551 static INLINE
struct mem_node
*
2557 /* Make the search always successful to speed up the loop below. */
2558 mem_z
.start
= start
;
2559 mem_z
.end
= (char *) start
+ 1;
2562 while (start
< p
->start
|| start
>= p
->end
)
2563 p
= start
< p
->start
? p
->left
: p
->right
;
2568 /* Insert a new node into the tree for a block of memory with start
2569 address START, end address END, and type TYPE. Value is a
2570 pointer to the node that was inserted. */
2572 static struct mem_node
*
2573 mem_insert (start
, end
, type
)
2577 struct mem_node
*c
, *parent
, *x
;
2579 /* See where in the tree a node for START belongs. In this
2580 particular application, it shouldn't happen that a node is already
2581 present. For debugging purposes, let's check that. */
2585 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2587 while (c
!= MEM_NIL
)
2589 if (start
>= c
->start
&& start
< c
->end
)
2592 c
= start
< c
->start
? c
->left
: c
->right
;
2595 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2597 while (c
!= MEM_NIL
)
2600 c
= start
< c
->start
? c
->left
: c
->right
;
2603 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2605 /* Create a new node. */
2606 #ifdef GC_MALLOC_CHECK
2607 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
2611 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2617 x
->left
= x
->right
= MEM_NIL
;
2620 /* Insert it as child of PARENT or install it as root. */
2623 if (start
< parent
->start
)
2631 /* Re-establish red-black tree properties. */
2632 mem_insert_fixup (x
);
2638 /* Re-establish the red-black properties of the tree, and thereby
2639 balance the tree, after node X has been inserted; X is always red. */
2642 mem_insert_fixup (x
)
2645 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2647 /* X is red and its parent is red. This is a violation of
2648 red-black tree property #3. */
2650 if (x
->parent
== x
->parent
->parent
->left
)
2652 /* We're on the left side of our grandparent, and Y is our
2654 struct mem_node
*y
= x
->parent
->parent
->right
;
2656 if (y
->color
== MEM_RED
)
2658 /* Uncle and parent are red but should be black because
2659 X is red. Change the colors accordingly and proceed
2660 with the grandparent. */
2661 x
->parent
->color
= MEM_BLACK
;
2662 y
->color
= MEM_BLACK
;
2663 x
->parent
->parent
->color
= MEM_RED
;
2664 x
= x
->parent
->parent
;
2668 /* Parent and uncle have different colors; parent is
2669 red, uncle is black. */
2670 if (x
== x
->parent
->right
)
2673 mem_rotate_left (x
);
2676 x
->parent
->color
= MEM_BLACK
;
2677 x
->parent
->parent
->color
= MEM_RED
;
2678 mem_rotate_right (x
->parent
->parent
);
2683 /* This is the symmetrical case of above. */
2684 struct mem_node
*y
= x
->parent
->parent
->left
;
2686 if (y
->color
== MEM_RED
)
2688 x
->parent
->color
= MEM_BLACK
;
2689 y
->color
= MEM_BLACK
;
2690 x
->parent
->parent
->color
= MEM_RED
;
2691 x
= x
->parent
->parent
;
2695 if (x
== x
->parent
->left
)
2698 mem_rotate_right (x
);
2701 x
->parent
->color
= MEM_BLACK
;
2702 x
->parent
->parent
->color
= MEM_RED
;
2703 mem_rotate_left (x
->parent
->parent
);
2708 /* The root may have been changed to red due to the algorithm. Set
2709 it to black so that property #5 is satisfied. */
2710 mem_root
->color
= MEM_BLACK
;
2726 /* Turn y's left sub-tree into x's right sub-tree. */
2729 if (y
->left
!= MEM_NIL
)
2730 y
->left
->parent
= x
;
2732 /* Y's parent was x's parent. */
2734 y
->parent
= x
->parent
;
2736 /* Get the parent to point to y instead of x. */
2739 if (x
== x
->parent
->left
)
2740 x
->parent
->left
= y
;
2742 x
->parent
->right
= y
;
2747 /* Put x on y's left. */
2761 mem_rotate_right (x
)
2764 struct mem_node
*y
= x
->left
;
2767 if (y
->right
!= MEM_NIL
)
2768 y
->right
->parent
= x
;
2771 y
->parent
= x
->parent
;
2774 if (x
== x
->parent
->right
)
2775 x
->parent
->right
= y
;
2777 x
->parent
->left
= y
;
2788 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2794 struct mem_node
*x
, *y
;
2796 if (!z
|| z
== MEM_NIL
)
2799 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2804 while (y
->left
!= MEM_NIL
)
2808 if (y
->left
!= MEM_NIL
)
2813 x
->parent
= y
->parent
;
2816 if (y
== y
->parent
->left
)
2817 y
->parent
->left
= x
;
2819 y
->parent
->right
= x
;
2826 z
->start
= y
->start
;
2831 if (y
->color
== MEM_BLACK
)
2832 mem_delete_fixup (x
);
2834 #ifdef GC_MALLOC_CHECK
2842 /* Re-establish the red-black properties of the tree, after a
2846 mem_delete_fixup (x
)
2849 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2851 if (x
== x
->parent
->left
)
2853 struct mem_node
*w
= x
->parent
->right
;
2855 if (w
->color
== MEM_RED
)
2857 w
->color
= MEM_BLACK
;
2858 x
->parent
->color
= MEM_RED
;
2859 mem_rotate_left (x
->parent
);
2860 w
= x
->parent
->right
;
2863 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2870 if (w
->right
->color
== MEM_BLACK
)
2872 w
->left
->color
= MEM_BLACK
;
2874 mem_rotate_right (w
);
2875 w
= x
->parent
->right
;
2877 w
->color
= x
->parent
->color
;
2878 x
->parent
->color
= MEM_BLACK
;
2879 w
->right
->color
= MEM_BLACK
;
2880 mem_rotate_left (x
->parent
);
2886 struct mem_node
*w
= x
->parent
->left
;
2888 if (w
->color
== MEM_RED
)
2890 w
->color
= MEM_BLACK
;
2891 x
->parent
->color
= MEM_RED
;
2892 mem_rotate_right (x
->parent
);
2893 w
= x
->parent
->left
;
2896 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2903 if (w
->left
->color
== MEM_BLACK
)
2905 w
->right
->color
= MEM_BLACK
;
2907 mem_rotate_left (w
);
2908 w
= x
->parent
->left
;
2911 w
->color
= x
->parent
->color
;
2912 x
->parent
->color
= MEM_BLACK
;
2913 w
->left
->color
= MEM_BLACK
;
2914 mem_rotate_right (x
->parent
);
2920 x
->color
= MEM_BLACK
;
2924 /* Value is non-zero if P is a pointer to a live Lisp string on
2925 the heap. M is a pointer to the mem_block for P. */
2928 live_string_p (m
, p
)
2932 if (m
->type
== MEM_TYPE_STRING
)
2934 struct string_block
*b
= (struct string_block
*) m
->start
;
2935 int offset
= (char *) p
- (char *) &b
->strings
[0];
2937 /* P must point to the start of a Lisp_String structure, and it
2938 must not be on the free-list. */
2939 return (offset
% sizeof b
->strings
[0] == 0
2940 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2947 /* Value is non-zero if P is a pointer to a live Lisp cons on
2948 the heap. M is a pointer to the mem_block for P. */
2955 if (m
->type
== MEM_TYPE_CONS
)
2957 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2958 int offset
= (char *) p
- (char *) &b
->conses
[0];
2960 /* P must point to the start of a Lisp_Cons, not be
2961 one of the unused cells in the current cons block,
2962 and not be on the free-list. */
2963 return (offset
% sizeof b
->conses
[0] == 0
2965 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2966 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2973 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2974 the heap. M is a pointer to the mem_block for P. */
2977 live_symbol_p (m
, p
)
2981 if (m
->type
== MEM_TYPE_SYMBOL
)
2983 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2984 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2986 /* P must point to the start of a Lisp_Symbol, not be
2987 one of the unused cells in the current symbol block,
2988 and not be on the free-list. */
2989 return (offset
% sizeof b
->symbols
[0] == 0
2990 && (b
!= symbol_block
2991 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2992 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
2999 /* Value is non-zero if P is a pointer to a live Lisp float on
3000 the heap. M is a pointer to the mem_block for P. */
3007 if (m
->type
== MEM_TYPE_FLOAT
)
3009 struct float_block
*b
= (struct float_block
*) m
->start
;
3010 int offset
= (char *) p
- (char *) &b
->floats
[0];
3012 /* P must point to the start of a Lisp_Float, not be
3013 one of the unused cells in the current float block,
3014 and not be on the free-list. */
3015 return (offset
% sizeof b
->floats
[0] == 0
3016 && (b
!= float_block
3017 || offset
/ sizeof b
->floats
[0] < float_block_index
)
3018 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
3025 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3026 the heap. M is a pointer to the mem_block for P. */
3033 if (m
->type
== MEM_TYPE_MISC
)
3035 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3036 int offset
= (char *) p
- (char *) &b
->markers
[0];
3038 /* P must point to the start of a Lisp_Misc, not be
3039 one of the unused cells in the current misc block,
3040 and not be on the free-list. */
3041 return (offset
% sizeof b
->markers
[0] == 0
3042 && (b
!= marker_block
3043 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3044 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3051 /* Value is non-zero if P is a pointer to a live vector-like object.
3052 M is a pointer to the mem_block for P. */
3055 live_vector_p (m
, p
)
3059 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
3063 /* Value is non-zero of P is a pointer to a live buffer. M is a
3064 pointer to the mem_block for P. */
3067 live_buffer_p (m
, p
)
3071 /* P must point to the start of the block, and the buffer
3072 must not have been killed. */
3073 return (m
->type
== MEM_TYPE_BUFFER
3075 && !NILP (((struct buffer
*) p
)->name
));
3078 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3082 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3084 /* Array of objects that are kept alive because the C stack contains
3085 a pattern that looks like a reference to them . */
3087 #define MAX_ZOMBIES 10
3088 static Lisp_Object zombies
[MAX_ZOMBIES
];
3090 /* Number of zombie objects. */
3092 static int nzombies
;
3094 /* Number of garbage collections. */
3098 /* Average percentage of zombies per collection. */
3100 static double avg_zombies
;
3102 /* Max. number of live and zombie objects. */
3104 static int max_live
, max_zombies
;
3106 /* Average number of live objects per GC. */
3108 static double avg_live
;
3110 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3111 "Show information about live and zombie objects.")
3114 Lisp_Object args
[7];
3115 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
3116 args
[1] = make_number (ngcs
);
3117 args
[2] = make_float (avg_live
);
3118 args
[3] = make_float (avg_zombies
);
3119 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3120 args
[5] = make_number (max_live
);
3121 args
[6] = make_number (max_zombies
);
3122 return Fmessage (7, args
);
3125 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3128 /* Mark OBJ if we can prove it's a Lisp_Object. */
3131 mark_maybe_object (obj
)
3134 void *po
= (void *) XPNTR (obj
);
3135 struct mem_node
*m
= mem_find (po
);
3141 switch (XGCTYPE (obj
))
3144 mark_p
= (live_string_p (m
, po
)
3145 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3149 mark_p
= (live_cons_p (m
, po
)
3150 && !XMARKBIT (XCONS (obj
)->car
));
3154 mark_p
= (live_symbol_p (m
, po
)
3155 && !XMARKBIT (XSYMBOL (obj
)->plist
));
3159 mark_p
= (live_float_p (m
, po
)
3160 && !XMARKBIT (XFLOAT (obj
)->type
));
3163 case Lisp_Vectorlike
:
3164 /* Note: can't check GC_BUFFERP before we know it's a
3165 buffer because checking that dereferences the pointer
3166 PO which might point anywhere. */
3167 if (live_vector_p (m
, po
))
3168 mark_p
= (!GC_SUBRP (obj
)
3169 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
3170 else if (live_buffer_p (m
, po
))
3171 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
3175 if (live_misc_p (m
, po
))
3177 switch (XMISCTYPE (obj
))
3179 case Lisp_Misc_Marker
:
3180 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
3183 case Lisp_Misc_Buffer_Local_Value
:
3184 case Lisp_Misc_Some_Buffer_Local_Value
:
3185 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
3188 case Lisp_Misc_Overlay
:
3189 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
3196 case Lisp_Type_Limit
:
3202 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3203 if (nzombies
< MAX_ZOMBIES
)
3204 zombies
[nzombies
] = *p
;
3212 /* Mark Lisp objects in the address range START..END. */
3215 mark_memory (start
, end
)
3220 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3224 /* Make START the pointer to the start of the memory region,
3225 if it isn't already. */
3233 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3234 mark_maybe_object (*p
);
3238 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3240 static int setjmp_tested_p
, longjmps_done
;
3242 #define SETJMP_WILL_LIKELY_WORK "\
3244 Emacs garbage collector has been changed to use conservative stack\n\
3245 marking. Emacs has determined that the method it uses to do the\n\
3246 marking will likely work on your system, but this isn't sure.\n\
3248 If you are a system-programmer, or can get the help of a local wizard\n\
3249 who is, please take a look at the function mark_stack in alloc.c, and\n\
3250 verify that the methods used are appropriate for your system.\n\
3252 Please mail the result to <gerd@gnu.org>.\n\
3255 #define SETJMP_WILL_NOT_WORK "\
3257 Emacs garbage collector has been changed to use conservative stack\n\
3258 marking. Emacs has determined that the default method it uses to do the\n\
3259 marking will not work on your system. We will need a system-dependent\n\
3260 solution for your system.\n\
3262 Please take a look at the function mark_stack in alloc.c, and\n\
3263 try to find a way to make it work on your system.\n\
3264 Please mail the result to <gerd@gnu.org>.\n\
3268 /* Perform a quick check if it looks like setjmp saves registers in a
3269 jmp_buf. Print a message to stderr saying so. When this test
3270 succeeds, this is _not_ a proof that setjmp is sufficient for
3271 conservative stack marking. Only the sources or a disassembly
3282 /* Arrange for X to be put in a register. */
3288 if (longjmps_done
== 1)
3290 /* Came here after the longjmp at the end of the function.
3292 If x == 1, the longjmp has restored the register to its
3293 value before the setjmp, and we can hope that setjmp
3294 saves all such registers in the jmp_buf, although that
3297 For other values of X, either something really strange is
3298 taking place, or the setjmp just didn't save the register. */
3301 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3304 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3311 if (longjmps_done
== 1)
3315 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3318 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3320 /* Abort if anything GCPRO'd doesn't survive the GC. */
3328 for (p
= gcprolist
; p
; p
= p
->next
)
3329 for (i
= 0; i
< p
->nvars
; ++i
)
3330 if (!survives_gc_p (p
->var
[i
]))
3334 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3341 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3342 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3344 fprintf (stderr
, " %d = ", i
);
3345 debug_print (zombies
[i
]);
3349 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3352 /* Mark live Lisp objects on the C stack.
3354 There are several system-dependent problems to consider when
3355 porting this to new architectures:
3359 We have to mark Lisp objects in CPU registers that can hold local
3360 variables or are used to pass parameters.
3362 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3363 something that either saves relevant registers on the stack, or
3364 calls mark_maybe_object passing it each register's contents.
3366 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3367 implementation assumes that calling setjmp saves registers we need
3368 to see in a jmp_buf which itself lies on the stack. This doesn't
3369 have to be true! It must be verified for each system, possibly
3370 by taking a look at the source code of setjmp.
3374 Architectures differ in the way their processor stack is organized.
3375 For example, the stack might look like this
3378 | Lisp_Object | size = 4
3380 | something else | size = 2
3382 | Lisp_Object | size = 4
3386 In such a case, not every Lisp_Object will be aligned equally. To
3387 find all Lisp_Object on the stack it won't be sufficient to walk
3388 the stack in steps of 4 bytes. Instead, two passes will be
3389 necessary, one starting at the start of the stack, and a second
3390 pass starting at the start of the stack + 2. Likewise, if the
3391 minimal alignment of Lisp_Objects on the stack is 1, four passes
3392 would be necessary, each one starting with one byte more offset
3393 from the stack start.
3395 The current code assumes by default that Lisp_Objects are aligned
3396 equally on the stack. */
3402 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3405 /* This trick flushes the register windows so that all the state of
3406 the process is contained in the stack. */
3411 /* Save registers that we need to see on the stack. We need to see
3412 registers used to hold register variables and registers used to
3414 #ifdef GC_SAVE_REGISTERS_ON_STACK
3415 GC_SAVE_REGISTERS_ON_STACK (end
);
3416 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3418 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3419 setjmp will definitely work, test it
3420 and print a message with the result
3422 if (!setjmp_tested_p
)
3424 setjmp_tested_p
= 1;
3427 #endif /* GC_SETJMP_WORKS */
3430 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3431 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3433 /* This assumes that the stack is a contiguous region in memory. If
3434 that's not the case, something has to be done here to iterate
3435 over the stack segments. */
3436 #if GC_LISP_OBJECT_ALIGNMENT == 1
3437 mark_memory (stack_base
, end
);
3438 mark_memory ((char *) stack_base
+ 1, end
);
3439 mark_memory ((char *) stack_base
+ 2, end
);
3440 mark_memory ((char *) stack_base
+ 3, end
);
3441 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3442 mark_memory (stack_base
, end
);
3443 mark_memory ((char *) stack_base
+ 2, end
);
3445 mark_memory (stack_base
, end
);
3448 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3454 #endif /* GC_MARK_STACK != 0 */
3458 /***********************************************************************
3459 Pure Storage Management
3460 ***********************************************************************/
3462 /* Allocate room for SIZE bytes from pure Lisp storage and return a
3463 pointer to it. TYPE is the Lisp type for which the memory is
3464 allocated. TYPE < 0 means it's not used for a Lisp object.
3466 If store_pure_type_info is set and TYPE is >= 0, the type of
3467 the allocated object is recorded in pure_types. */
3469 static POINTER_TYPE
*
3470 pure_alloc (size
, type
)
3475 POINTER_TYPE
*result
;
3476 char *beg
= PUREBEG
;
3478 /* Give Lisp_Floats an extra alignment. */
3479 if (type
== Lisp_Float
)
3482 #if defined __GNUC__ && __GNUC__ >= 2
3483 alignment
= __alignof (struct Lisp_Float
);
3485 alignment
= sizeof (struct Lisp_Float
);
3487 pure_bytes_used
= ALIGN (pure_bytes_used
, alignment
);
3490 nbytes
= ALIGN (size
, sizeof (EMACS_INT
));
3491 if (pure_bytes_used
+ nbytes
> PURESIZE
)
3492 error ("Pure Lisp storage exhausted");
3494 result
= (POINTER_TYPE
*) (beg
+ pure_bytes_used
);
3495 pure_bytes_used
+= nbytes
;
3500 /* Return a string allocated in pure space. DATA is a buffer holding
3501 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3502 non-zero means make the result string multibyte.
3504 Must get an error if pure storage is full, since if it cannot hold
3505 a large string it may be able to hold conses that point to that
3506 string; then the string is not protected from gc. */
3509 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3515 struct Lisp_String
*s
;
3517 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
3518 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
3520 s
->size_byte
= multibyte
? nbytes
: -1;
3521 bcopy (data
, s
->data
, nbytes
);
3522 s
->data
[nbytes
] = '\0';
3523 s
->intervals
= NULL_INTERVAL
;
3524 XSETSTRING (string
, s
);
3529 /* Return a cons allocated from pure space. Give it pure copies
3530 of CAR as car and CDR as cdr. */
3533 pure_cons (car
, cdr
)
3534 Lisp_Object car
, cdr
;
3536 register Lisp_Object
new;
3537 struct Lisp_Cons
*p
;
3539 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
3541 XCAR (new) = Fpurecopy (car
);
3542 XCDR (new) = Fpurecopy (cdr
);
3547 /* Value is a float object with value NUM allocated from pure space. */
3550 make_pure_float (num
)
3553 register Lisp_Object
new;
3554 struct Lisp_Float
*p
;
3556 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
3558 XFLOAT_DATA (new) = num
;
3563 /* Return a vector with room for LEN Lisp_Objects allocated from
3567 make_pure_vector (len
)
3571 struct Lisp_Vector
*p
;
3572 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
3574 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
3575 XSETVECTOR (new, p
);
3576 XVECTOR (new)->size
= len
;
3581 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3582 "Make a copy of OBJECT in pure storage.\n\
3583 Recursively copies contents of vectors and cons cells.\n\
3584 Does not copy symbols. Copies strings without text properties.")
3586 register Lisp_Object obj
;
3588 if (NILP (Vpurify_flag
))
3591 if (PURE_POINTER_P (XPNTR (obj
)))
3595 return pure_cons (XCAR (obj
), XCDR (obj
));
3596 else if (FLOATP (obj
))
3597 return make_pure_float (XFLOAT_DATA (obj
));
3598 else if (STRINGP (obj
))
3599 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3600 STRING_BYTES (XSTRING (obj
)),
3601 STRING_MULTIBYTE (obj
));
3602 else if (COMPILEDP (obj
) || VECTORP (obj
))
3604 register struct Lisp_Vector
*vec
;
3605 register int i
, size
;
3607 size
= XVECTOR (obj
)->size
;
3608 if (size
& PSEUDOVECTOR_FLAG
)
3609 size
&= PSEUDOVECTOR_SIZE_MASK
;
3610 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3611 for (i
= 0; i
< size
; i
++)
3612 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3613 if (COMPILEDP (obj
))
3614 XSETCOMPILED (obj
, vec
);
3616 XSETVECTOR (obj
, vec
);
3619 else if (MARKERP (obj
))
3620 error ("Attempt to copy a marker to pure storage");
3627 /***********************************************************************
3629 ***********************************************************************/
3631 /* Put an entry in staticvec, pointing at the variable with address
3635 staticpro (varaddress
)
3636 Lisp_Object
*varaddress
;
3638 staticvec
[staticidx
++] = varaddress
;
3639 if (staticidx
>= NSTATICS
)
3647 struct catchtag
*next
;
3652 struct backtrace
*next
;
3653 Lisp_Object
*function
;
3654 Lisp_Object
*args
; /* Points to vector of args. */
3655 int nargs
; /* Length of vector. */
3656 /* If nargs is UNEVALLED, args points to slot holding list of
3663 /***********************************************************************
3665 ***********************************************************************/
3667 /* Temporarily prevent garbage collection. */
3670 inhibit_garbage_collection ()
3672 int count
= specpdl_ptr
- specpdl
;
3674 int nbits
= min (VALBITS
, BITS_PER_INT
);
3676 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3678 specbind (Qgc_cons_threshold
, number
);
3684 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3685 "Reclaim storage for Lisp objects no longer needed.\n\
3686 Returns info on amount of space in use:\n\
3687 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3688 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3689 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3690 (USED-STRINGS . FREE-STRINGS))\n\
3691 Garbage collection happens automatically if you cons more than\n\
3692 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3695 register struct gcpro
*tail
;
3696 register struct specbinding
*bind
;
3697 struct catchtag
*catch;
3698 struct handler
*handler
;
3699 register struct backtrace
*backlist
;
3700 char stack_top_variable
;
3703 Lisp_Object total
[7];
3705 /* In case user calls debug_print during GC,
3706 don't let that cause a recursive GC. */
3707 consing_since_gc
= 0;
3709 /* Save what's currently displayed in the echo area. */
3710 message_p
= push_message ();
3712 /* Save a copy of the contents of the stack, for debugging. */
3713 #if MAX_SAVE_STACK > 0
3714 if (NILP (Vpurify_flag
))
3716 i
= &stack_top_variable
- stack_bottom
;
3718 if (i
< MAX_SAVE_STACK
)
3720 if (stack_copy
== 0)
3721 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3722 else if (stack_copy_size
< i
)
3723 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3726 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3727 bcopy (stack_bottom
, stack_copy
, i
);
3729 bcopy (&stack_top_variable
, stack_copy
, i
);
3733 #endif /* MAX_SAVE_STACK > 0 */
3735 if (garbage_collection_messages
)
3736 message1_nolog ("Garbage collecting...");
3740 shrink_regexp_cache ();
3742 /* Don't keep undo information around forever. */
3744 register struct buffer
*nextb
= all_buffers
;
3748 /* If a buffer's undo list is Qt, that means that undo is
3749 turned off in that buffer. Calling truncate_undo_list on
3750 Qt tends to return NULL, which effectively turns undo back on.
3751 So don't call truncate_undo_list if undo_list is Qt. */
3752 if (! EQ (nextb
->undo_list
, Qt
))
3754 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3756 nextb
= nextb
->next
;
3762 /* clear_marks (); */
3764 /* Mark all the special slots that serve as the roots of accessibility.
3766 Usually the special slots to mark are contained in particular structures.
3767 Then we know no slot is marked twice because the structures don't overlap.
3768 In some cases, the structures point to the slots to be marked.
3769 For these, we use MARKBIT to avoid double marking of the slot. */
3771 for (i
= 0; i
< staticidx
; i
++)
3772 mark_object (staticvec
[i
]);
3774 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3775 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3778 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3779 for (i
= 0; i
< tail
->nvars
; i
++)
3780 if (!XMARKBIT (tail
->var
[i
]))
3782 /* Explicit casting prevents compiler warning about
3783 discarding the `volatile' qualifier. */
3784 mark_object ((Lisp_Object
*)&tail
->var
[i
]);
3785 XMARK (tail
->var
[i
]);
3790 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3792 mark_object (&bind
->symbol
);
3793 mark_object (&bind
->old_value
);
3795 for (catch = catchlist
; catch; catch = catch->next
)
3797 mark_object (&catch->tag
);
3798 mark_object (&catch->val
);
3800 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3802 mark_object (&handler
->handler
);
3803 mark_object (&handler
->var
);
3805 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3807 if (!XMARKBIT (*backlist
->function
))
3809 mark_object (backlist
->function
);
3810 XMARK (*backlist
->function
);
3812 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3815 i
= backlist
->nargs
- 1;
3817 if (!XMARKBIT (backlist
->args
[i
]))
3819 mark_object (&backlist
->args
[i
]);
3820 XMARK (backlist
->args
[i
]);
3825 /* Look thru every buffer's undo list
3826 for elements that update markers that were not marked,
3829 register struct buffer
*nextb
= all_buffers
;
3833 /* If a buffer's undo list is Qt, that means that undo is
3834 turned off in that buffer. Calling truncate_undo_list on
3835 Qt tends to return NULL, which effectively turns undo back on.
3836 So don't call truncate_undo_list if undo_list is Qt. */
3837 if (! EQ (nextb
->undo_list
, Qt
))
3839 Lisp_Object tail
, prev
;
3840 tail
= nextb
->undo_list
;
3842 while (CONSP (tail
))
3844 if (GC_CONSP (XCAR (tail
))
3845 && GC_MARKERP (XCAR (XCAR (tail
)))
3846 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3849 nextb
->undo_list
= tail
= XCDR (tail
);
3851 tail
= XCDR (prev
) = XCDR (tail
);
3861 nextb
= nextb
->next
;
3865 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3871 /* Clear the mark bits that we set in certain root slots. */
3873 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3874 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3875 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3876 for (i
= 0; i
< tail
->nvars
; i
++)
3877 XUNMARK (tail
->var
[i
]);
3880 unmark_byte_stack ();
3881 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3883 XUNMARK (*backlist
->function
);
3884 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3887 i
= backlist
->nargs
- 1;
3889 XUNMARK (backlist
->args
[i
]);
3891 XUNMARK (buffer_defaults
.name
);
3892 XUNMARK (buffer_local_symbols
.name
);
3894 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3900 /* clear_marks (); */
3903 consing_since_gc
= 0;
3904 if (gc_cons_threshold
< 10000)
3905 gc_cons_threshold
= 10000;
3907 if (garbage_collection_messages
)
3909 if (message_p
|| minibuf_level
> 0)
3912 message1_nolog ("Garbage collecting...done");
3917 total
[0] = Fcons (make_number (total_conses
),
3918 make_number (total_free_conses
));
3919 total
[1] = Fcons (make_number (total_symbols
),
3920 make_number (total_free_symbols
));
3921 total
[2] = Fcons (make_number (total_markers
),
3922 make_number (total_free_markers
));
3923 total
[3] = Fcons (make_number (total_string_size
),
3924 make_number (total_vector_size
));
3925 total
[4] = Fcons (make_number (total_floats
),
3926 make_number (total_free_floats
));
3927 total
[5] = Fcons (make_number (total_intervals
),
3928 make_number (total_free_intervals
));
3929 total
[6] = Fcons (make_number (total_strings
),
3930 make_number (total_free_strings
));
3932 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3934 /* Compute average percentage of zombies. */
3937 for (i
= 0; i
< 7; ++i
)
3938 nlive
+= XFASTINT (XCAR (total
[i
]));
3940 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3941 max_live
= max (nlive
, max_live
);
3942 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3943 max_zombies
= max (nzombies
, max_zombies
);
3948 return Flist (7, total
);
3952 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3953 only interesting objects referenced from glyphs are strings. */
3956 mark_glyph_matrix (matrix
)
3957 struct glyph_matrix
*matrix
;
3959 struct glyph_row
*row
= matrix
->rows
;
3960 struct glyph_row
*end
= row
+ matrix
->nrows
;
3962 for (; row
< end
; ++row
)
3966 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3968 struct glyph
*glyph
= row
->glyphs
[area
];
3969 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3971 for (; glyph
< end_glyph
; ++glyph
)
3972 if (GC_STRINGP (glyph
->object
)
3973 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3974 mark_object (&glyph
->object
);
3980 /* Mark Lisp faces in the face cache C. */
3984 struct face_cache
*c
;
3989 for (i
= 0; i
< c
->used
; ++i
)
3991 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3995 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3996 mark_object (&face
->lface
[j
]);
4003 #ifdef HAVE_WINDOW_SYSTEM
4005 /* Mark Lisp objects in image IMG. */
4011 mark_object (&img
->spec
);
4013 if (!NILP (img
->data
.lisp_val
))
4014 mark_object (&img
->data
.lisp_val
);
4018 /* Mark Lisp objects in image cache of frame F. It's done this way so
4019 that we don't have to include xterm.h here. */
4022 mark_image_cache (f
)
4025 forall_images_in_image_cache (f
, mark_image
);
4028 #endif /* HAVE_X_WINDOWS */
4032 /* Mark reference to a Lisp_Object.
4033 If the object referred to has not been seen yet, recursively mark
4034 all the references contained in it. */
4036 #define LAST_MARKED_SIZE 500
4037 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
4038 int last_marked_index
;
4041 mark_object (argptr
)
4042 Lisp_Object
*argptr
;
4044 Lisp_Object
*objptr
= argptr
;
4045 register Lisp_Object obj
;
4046 #ifdef GC_CHECK_MARKED_OBJECTS
4056 if (PURE_POINTER_P (XPNTR (obj
)))
4059 last_marked
[last_marked_index
++] = objptr
;
4060 if (last_marked_index
== LAST_MARKED_SIZE
)
4061 last_marked_index
= 0;
4063 /* Perform some sanity checks on the objects marked here. Abort if
4064 we encounter an object we know is bogus. This increases GC time
4065 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4066 #ifdef GC_CHECK_MARKED_OBJECTS
4068 po
= (void *) XPNTR (obj
);
4070 /* Check that the object pointed to by PO is known to be a Lisp
4071 structure allocated from the heap. */
4072 #define CHECK_ALLOCATED() \
4074 m = mem_find (po); \
4079 /* Check that the object pointed to by PO is live, using predicate
4081 #define CHECK_LIVE(LIVEP) \
4083 if (!LIVEP (m, po)) \
4087 /* Check both of the above conditions. */
4088 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4090 CHECK_ALLOCATED (); \
4091 CHECK_LIVE (LIVEP); \
4094 #else /* not GC_CHECK_MARKED_OBJECTS */
4096 #define CHECK_ALLOCATED() (void) 0
4097 #define CHECK_LIVE(LIVEP) (void) 0
4098 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4100 #endif /* not GC_CHECK_MARKED_OBJECTS */
4102 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4106 register struct Lisp_String
*ptr
= XSTRING (obj
);
4107 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4108 MARK_INTERVAL_TREE (ptr
->intervals
);
4110 #ifdef GC_CHECK_STRING_BYTES
4112 /* Check that the string size recorded in the string is the
4113 same as the one recorded in the sdata structure. */
4114 struct sdata
*p
= SDATA_OF_STRING (ptr
);
4115 if (GC_STRING_BYTES (ptr
) != SDATA_NBYTES (p
))
4118 #endif /* GC_CHECK_STRING_BYTES */
4122 case Lisp_Vectorlike
:
4123 #ifdef GC_CHECK_MARKED_OBJECTS
4125 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4126 && po
!= &buffer_defaults
4127 && po
!= &buffer_local_symbols
)
4129 #endif /* GC_CHECK_MARKED_OBJECTS */
4131 if (GC_BUFFERP (obj
))
4133 if (!XMARKBIT (XBUFFER (obj
)->name
))
4135 #ifdef GC_CHECK_MARKED_OBJECTS
4136 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4139 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4144 #endif /* GC_CHECK_MARKED_OBJECTS */
4148 else if (GC_SUBRP (obj
))
4150 else if (GC_COMPILEDP (obj
))
4151 /* We could treat this just like a vector, but it is better to
4152 save the COMPILED_CONSTANTS element for last and avoid
4155 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4156 register EMACS_INT size
= ptr
->size
;
4159 if (size
& ARRAY_MARK_FLAG
)
4160 break; /* Already marked */
4162 CHECK_LIVE (live_vector_p
);
4163 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4164 size
&= PSEUDOVECTOR_SIZE_MASK
;
4165 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4167 if (i
!= COMPILED_CONSTANTS
)
4168 mark_object (&ptr
->contents
[i
]);
4170 /* This cast should be unnecessary, but some Mips compiler complains
4171 (MIPS-ABI + SysVR4, DC/OSx, etc). */
4172 objptr
= (Lisp_Object
*) &ptr
->contents
[COMPILED_CONSTANTS
];
4175 else if (GC_FRAMEP (obj
))
4177 register struct frame
*ptr
= XFRAME (obj
);
4178 register EMACS_INT size
= ptr
->size
;
4180 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4181 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4183 CHECK_LIVE (live_vector_p
);
4184 mark_object (&ptr
->name
);
4185 mark_object (&ptr
->icon_name
);
4186 mark_object (&ptr
->title
);
4187 mark_object (&ptr
->focus_frame
);
4188 mark_object (&ptr
->selected_window
);
4189 mark_object (&ptr
->minibuffer_window
);
4190 mark_object (&ptr
->param_alist
);
4191 mark_object (&ptr
->scroll_bars
);
4192 mark_object (&ptr
->condemned_scroll_bars
);
4193 mark_object (&ptr
->menu_bar_items
);
4194 mark_object (&ptr
->face_alist
);
4195 mark_object (&ptr
->menu_bar_vector
);
4196 mark_object (&ptr
->buffer_predicate
);
4197 mark_object (&ptr
->buffer_list
);
4198 mark_object (&ptr
->menu_bar_window
);
4199 mark_object (&ptr
->tool_bar_window
);
4200 mark_face_cache (ptr
->face_cache
);
4201 #ifdef HAVE_WINDOW_SYSTEM
4202 mark_image_cache (ptr
);
4203 mark_object (&ptr
->desired_tool_bar_items
);
4204 mark_object (&ptr
->current_tool_bar_items
);
4205 mark_object (&ptr
->desired_tool_bar_string
);
4206 mark_object (&ptr
->current_tool_bar_string
);
4207 #endif /* HAVE_WINDOW_SYSTEM */
4209 else if (GC_BOOL_VECTOR_P (obj
))
4211 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4213 if (ptr
->size
& ARRAY_MARK_FLAG
)
4214 break; /* Already marked */
4215 CHECK_LIVE (live_vector_p
);
4216 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4218 else if (GC_WINDOWP (obj
))
4220 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4221 struct window
*w
= XWINDOW (obj
);
4222 register EMACS_INT size
= ptr
->size
;
4225 /* Stop if already marked. */
4226 if (size
& ARRAY_MARK_FLAG
)
4230 CHECK_LIVE (live_vector_p
);
4231 ptr
->size
|= ARRAY_MARK_FLAG
;
4233 /* There is no Lisp data above The member CURRENT_MATRIX in
4234 struct WINDOW. Stop marking when that slot is reached. */
4236 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4238 mark_object (&ptr
->contents
[i
]);
4240 /* Mark glyphs for leaf windows. Marking window matrices is
4241 sufficient because frame matrices use the same glyph
4243 if (NILP (w
->hchild
)
4245 && w
->current_matrix
)
4247 mark_glyph_matrix (w
->current_matrix
);
4248 mark_glyph_matrix (w
->desired_matrix
);
4251 else if (GC_HASH_TABLE_P (obj
))
4253 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4254 EMACS_INT size
= h
->size
;
4256 /* Stop if already marked. */
4257 if (size
& ARRAY_MARK_FLAG
)
4261 CHECK_LIVE (live_vector_p
);
4262 h
->size
|= ARRAY_MARK_FLAG
;
4264 /* Mark contents. */
4265 mark_object (&h
->test
);
4266 mark_object (&h
->weak
);
4267 mark_object (&h
->rehash_size
);
4268 mark_object (&h
->rehash_threshold
);
4269 mark_object (&h
->hash
);
4270 mark_object (&h
->next
);
4271 mark_object (&h
->index
);
4272 mark_object (&h
->user_hash_function
);
4273 mark_object (&h
->user_cmp_function
);
4275 /* If hash table is not weak, mark all keys and values.
4276 For weak tables, mark only the vector. */
4277 if (GC_NILP (h
->weak
))
4278 mark_object (&h
->key_and_value
);
4280 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
4285 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4286 register EMACS_INT size
= ptr
->size
;
4289 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4290 CHECK_LIVE (live_vector_p
);
4291 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4292 if (size
& PSEUDOVECTOR_FLAG
)
4293 size
&= PSEUDOVECTOR_SIZE_MASK
;
4295 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4296 mark_object (&ptr
->contents
[i
]);
4302 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4303 struct Lisp_Symbol
*ptrx
;
4305 if (XMARKBIT (ptr
->plist
)) break;
4306 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4308 mark_object ((Lisp_Object
*) &ptr
->value
);
4309 mark_object (&ptr
->function
);
4310 mark_object (&ptr
->plist
);
4312 if (!PURE_POINTER_P (ptr
->name
))
4313 MARK_STRING (ptr
->name
);
4314 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
4316 /* Note that we do not mark the obarray of the symbol.
4317 It is safe not to do so because nothing accesses that
4318 slot except to check whether it is nil. */
4322 /* For the benefit of the last_marked log. */
4323 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4324 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4325 XSETSYMBOL (obj
, ptrx
);
4326 /* We can't goto loop here because *objptr doesn't contain an
4327 actual Lisp_Object with valid datatype field. */
4334 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4335 switch (XMISCTYPE (obj
))
4337 case Lisp_Misc_Marker
:
4338 XMARK (XMARKER (obj
)->chain
);
4339 /* DO NOT mark thru the marker's chain.
4340 The buffer's markers chain does not preserve markers from gc;
4341 instead, markers are removed from the chain when freed by gc. */
4344 case Lisp_Misc_Buffer_Local_Value
:
4345 case Lisp_Misc_Some_Buffer_Local_Value
:
4347 register struct Lisp_Buffer_Local_Value
*ptr
4348 = XBUFFER_LOCAL_VALUE (obj
);
4349 if (XMARKBIT (ptr
->realvalue
)) break;
4350 XMARK (ptr
->realvalue
);
4351 /* If the cdr is nil, avoid recursion for the car. */
4352 if (EQ (ptr
->cdr
, Qnil
))
4354 objptr
= &ptr
->realvalue
;
4357 mark_object (&ptr
->realvalue
);
4358 mark_object (&ptr
->buffer
);
4359 mark_object (&ptr
->frame
);
4364 case Lisp_Misc_Intfwd
:
4365 case Lisp_Misc_Boolfwd
:
4366 case Lisp_Misc_Objfwd
:
4367 case Lisp_Misc_Buffer_Objfwd
:
4368 case Lisp_Misc_Kboard_Objfwd
:
4369 /* Don't bother with Lisp_Buffer_Objfwd,
4370 since all markable slots in current buffer marked anyway. */
4371 /* Don't need to do Lisp_Objfwd, since the places they point
4372 are protected with staticpro. */
4375 case Lisp_Misc_Overlay
:
4377 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4378 if (!XMARKBIT (ptr
->plist
))
4381 mark_object (&ptr
->start
);
4382 mark_object (&ptr
->end
);
4383 objptr
= &ptr
->plist
;
4396 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4397 if (XMARKBIT (ptr
->car
)) break;
4398 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
4400 /* If the cdr is nil, avoid recursion for the car. */
4401 if (EQ (ptr
->cdr
, Qnil
))
4406 mark_object (&ptr
->car
);
4412 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
4413 XMARK (XFLOAT (obj
)->type
);
4424 #undef CHECK_ALLOCATED
4425 #undef CHECK_ALLOCATED_AND_LIVE
4428 /* Mark the pointers in a buffer structure. */
4434 register struct buffer
*buffer
= XBUFFER (buf
);
4435 register Lisp_Object
*ptr
;
4436 Lisp_Object base_buffer
;
4438 /* This is the buffer's markbit */
4439 mark_object (&buffer
->name
);
4440 XMARK (buffer
->name
);
4442 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4444 if (CONSP (buffer
->undo_list
))
4447 tail
= buffer
->undo_list
;
4449 while (CONSP (tail
))
4451 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4453 if (XMARKBIT (ptr
->car
))
4456 if (GC_CONSP (ptr
->car
)
4457 && ! XMARKBIT (XCAR (ptr
->car
))
4458 && GC_MARKERP (XCAR (ptr
->car
)))
4460 XMARK (XCAR (ptr
->car
));
4461 mark_object (&XCDR (ptr
->car
));
4464 mark_object (&ptr
->car
);
4466 if (CONSP (ptr
->cdr
))
4472 mark_object (&XCDR (tail
));
4475 mark_object (&buffer
->undo_list
);
4477 for (ptr
= &buffer
->name
+ 1;
4478 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4482 /* If this is an indirect buffer, mark its base buffer. */
4483 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4485 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4486 mark_buffer (base_buffer
);
4491 /* Mark the pointers in the kboard objects. */
4498 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4500 if (kb
->kbd_macro_buffer
)
4501 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4503 mark_object (&kb
->Voverriding_terminal_local_map
);
4504 mark_object (&kb
->Vlast_command
);
4505 mark_object (&kb
->Vreal_last_command
);
4506 mark_object (&kb
->Vprefix_arg
);
4507 mark_object (&kb
->Vlast_prefix_arg
);
4508 mark_object (&kb
->kbd_queue
);
4509 mark_object (&kb
->defining_kbd_macro
);
4510 mark_object (&kb
->Vlast_kbd_macro
);
4511 mark_object (&kb
->Vsystem_key_alist
);
4512 mark_object (&kb
->system_key_syms
);
4513 mark_object (&kb
->Vdefault_minibuffer_frame
);
4518 /* Value is non-zero if OBJ will survive the current GC because it's
4519 either marked or does not need to be marked to survive. */
4527 switch (XGCTYPE (obj
))
4534 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4538 switch (XMISCTYPE (obj
))
4540 case Lisp_Misc_Marker
:
4541 survives_p
= XMARKBIT (obj
);
4544 case Lisp_Misc_Buffer_Local_Value
:
4545 case Lisp_Misc_Some_Buffer_Local_Value
:
4546 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4549 case Lisp_Misc_Intfwd
:
4550 case Lisp_Misc_Boolfwd
:
4551 case Lisp_Misc_Objfwd
:
4552 case Lisp_Misc_Buffer_Objfwd
:
4553 case Lisp_Misc_Kboard_Objfwd
:
4557 case Lisp_Misc_Overlay
:
4558 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4568 struct Lisp_String
*s
= XSTRING (obj
);
4569 survives_p
= STRING_MARKED_P (s
);
4573 case Lisp_Vectorlike
:
4574 if (GC_BUFFERP (obj
))
4575 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4576 else if (GC_SUBRP (obj
))
4579 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4583 survives_p
= XMARKBIT (XCAR (obj
));
4587 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4594 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4599 /* Sweep: find all structures not marked, and free them. */
4604 /* Remove or mark entries in weak hash tables.
4605 This must be done before any object is unmarked. */
4606 sweep_weak_hash_tables ();
4610 /* Put all unmarked conses on free list */
4612 register struct cons_block
*cblk
;
4613 struct cons_block
**cprev
= &cons_block
;
4614 register int lim
= cons_block_index
;
4615 register int num_free
= 0, num_used
= 0;
4619 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4623 for (i
= 0; i
< lim
; i
++)
4624 if (!XMARKBIT (cblk
->conses
[i
].car
))
4627 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4628 cons_free_list
= &cblk
->conses
[i
];
4630 cons_free_list
->car
= Vdead
;
4636 XUNMARK (cblk
->conses
[i
].car
);
4638 lim
= CONS_BLOCK_SIZE
;
4639 /* If this block contains only free conses and we have already
4640 seen more than two blocks worth of free conses then deallocate
4642 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4644 *cprev
= cblk
->next
;
4645 /* Unhook from the free list. */
4646 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4652 num_free
+= this_free
;
4653 cprev
= &cblk
->next
;
4656 total_conses
= num_used
;
4657 total_free_conses
= num_free
;
4660 /* Put all unmarked floats on free list */
4662 register struct float_block
*fblk
;
4663 struct float_block
**fprev
= &float_block
;
4664 register int lim
= float_block_index
;
4665 register int num_free
= 0, num_used
= 0;
4667 float_free_list
= 0;
4669 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4673 for (i
= 0; i
< lim
; i
++)
4674 if (!XMARKBIT (fblk
->floats
[i
].type
))
4677 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4678 float_free_list
= &fblk
->floats
[i
];
4680 float_free_list
->type
= Vdead
;
4686 XUNMARK (fblk
->floats
[i
].type
);
4688 lim
= FLOAT_BLOCK_SIZE
;
4689 /* If this block contains only free floats and we have already
4690 seen more than two blocks worth of free floats then deallocate
4692 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4694 *fprev
= fblk
->next
;
4695 /* Unhook from the free list. */
4696 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4702 num_free
+= this_free
;
4703 fprev
= &fblk
->next
;
4706 total_floats
= num_used
;
4707 total_free_floats
= num_free
;
4710 /* Put all unmarked intervals on free list */
4712 register struct interval_block
*iblk
;
4713 struct interval_block
**iprev
= &interval_block
;
4714 register int lim
= interval_block_index
;
4715 register int num_free
= 0, num_used
= 0;
4717 interval_free_list
= 0;
4719 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4724 for (i
= 0; i
< lim
; i
++)
4726 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4728 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4729 interval_free_list
= &iblk
->intervals
[i
];
4735 XUNMARK (iblk
->intervals
[i
].plist
);
4738 lim
= INTERVAL_BLOCK_SIZE
;
4739 /* If this block contains only free intervals and we have already
4740 seen more than two blocks worth of free intervals then
4741 deallocate this block. */
4742 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4744 *iprev
= iblk
->next
;
4745 /* Unhook from the free list. */
4746 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4748 n_interval_blocks
--;
4752 num_free
+= this_free
;
4753 iprev
= &iblk
->next
;
4756 total_intervals
= num_used
;
4757 total_free_intervals
= num_free
;
4760 /* Put all unmarked symbols on free list */
4762 register struct symbol_block
*sblk
;
4763 struct symbol_block
**sprev
= &symbol_block
;
4764 register int lim
= symbol_block_index
;
4765 register int num_free
= 0, num_used
= 0;
4767 symbol_free_list
= 0;
4769 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4773 for (i
= 0; i
< lim
; i
++)
4774 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4776 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4777 symbol_free_list
= &sblk
->symbols
[i
];
4779 symbol_free_list
->function
= Vdead
;
4786 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4787 UNMARK_STRING (sblk
->symbols
[i
].name
);
4788 XUNMARK (sblk
->symbols
[i
].plist
);
4790 lim
= SYMBOL_BLOCK_SIZE
;
4791 /* If this block contains only free symbols and we have already
4792 seen more than two blocks worth of free symbols then deallocate
4794 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4796 *sprev
= sblk
->next
;
4797 /* Unhook from the free list. */
4798 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4804 num_free
+= this_free
;
4805 sprev
= &sblk
->next
;
4808 total_symbols
= num_used
;
4809 total_free_symbols
= num_free
;
4812 /* Put all unmarked misc's on free list.
4813 For a marker, first unchain it from the buffer it points into. */
4815 register struct marker_block
*mblk
;
4816 struct marker_block
**mprev
= &marker_block
;
4817 register int lim
= marker_block_index
;
4818 register int num_free
= 0, num_used
= 0;
4820 marker_free_list
= 0;
4822 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4826 EMACS_INT already_free
= -1;
4828 for (i
= 0; i
< lim
; i
++)
4830 Lisp_Object
*markword
;
4831 switch (mblk
->markers
[i
].u_marker
.type
)
4833 case Lisp_Misc_Marker
:
4834 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4836 case Lisp_Misc_Buffer_Local_Value
:
4837 case Lisp_Misc_Some_Buffer_Local_Value
:
4838 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4840 case Lisp_Misc_Overlay
:
4841 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4843 case Lisp_Misc_Free
:
4844 /* If the object was already free, keep it
4845 on the free list. */
4846 markword
= (Lisp_Object
*) &already_free
;
4852 if (markword
&& !XMARKBIT (*markword
))
4855 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4857 /* tem1 avoids Sun compiler bug */
4858 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4859 XSETMARKER (tem
, tem1
);
4860 unchain_marker (tem
);
4862 /* Set the type of the freed object to Lisp_Misc_Free.
4863 We could leave the type alone, since nobody checks it,
4864 but this might catch bugs faster. */
4865 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4866 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4867 marker_free_list
= &mblk
->markers
[i
];
4874 XUNMARK (*markword
);
4877 lim
= MARKER_BLOCK_SIZE
;
4878 /* If this block contains only free markers and we have already
4879 seen more than two blocks worth of free markers then deallocate
4881 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4883 *mprev
= mblk
->next
;
4884 /* Unhook from the free list. */
4885 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4891 num_free
+= this_free
;
4892 mprev
= &mblk
->next
;
4896 total_markers
= num_used
;
4897 total_free_markers
= num_free
;
4900 /* Free all unmarked buffers */
4902 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4905 if (!XMARKBIT (buffer
->name
))
4908 prev
->next
= buffer
->next
;
4910 all_buffers
= buffer
->next
;
4911 next
= buffer
->next
;
4917 XUNMARK (buffer
->name
);
4918 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4919 prev
= buffer
, buffer
= buffer
->next
;
4923 /* Free all unmarked vectors */
4925 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4926 total_vector_size
= 0;
4929 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4932 prev
->next
= vector
->next
;
4934 all_vectors
= vector
->next
;
4935 next
= vector
->next
;
4943 vector
->size
&= ~ARRAY_MARK_FLAG
;
4944 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4945 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4947 total_vector_size
+= vector
->size
;
4948 prev
= vector
, vector
= vector
->next
;
4956 /* Debugging aids. */
4958 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4959 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4960 This may be helpful in debugging Emacs's memory usage.\n\
4961 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4966 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4971 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4972 "Return a list of counters that measure how much consing there has been.\n\
4973 Each of these counters increments for a certain kind of object.\n\
4974 The counters wrap around from the largest positive integer to zero.\n\
4975 Garbage collection does not decrease them.\n\
4976 The elements of the value are as follows:\n\
4977 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4978 All are in units of 1 = one object consed\n\
4979 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4981 MISCS include overlays, markers, and some internal types.\n\
4982 Frames, windows, buffers, and subprocesses count as vectors\n\
4983 (but the contents of a buffer's text do not count here).")
4986 Lisp_Object consed
[8];
4989 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4991 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4993 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4995 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4997 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4999 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5001 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5003 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5005 return Flist (8, consed
);
5008 int suppress_checking
;
5010 die (msg
, file
, line
)
5015 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5020 /* Initialization */
5025 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5026 pure_bytes_used
= 0;
5027 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5029 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5032 pure_size
= PURESIZE
;
5035 ignore_warnings
= 1;
5036 #ifdef DOUG_LEA_MALLOC
5037 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5038 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5039 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5049 malloc_hysteresis
= 32;
5051 malloc_hysteresis
= 0;
5054 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5056 ignore_warnings
= 0;
5058 byte_stack_list
= 0;
5060 consing_since_gc
= 0;
5061 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5062 #ifdef VIRT_ADDR_VARIES
5063 malloc_sbrk_unused
= 1<<22; /* A large number */
5064 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5065 #endif /* VIRT_ADDR_VARIES */
5072 byte_stack_list
= 0;
5074 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5075 setjmp_tested_p
= longjmps_done
= 0;
5083 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5084 "*Number of bytes of consing between garbage collections.\n\
5085 Garbage collection can happen automatically once this many bytes have been\n\
5086 allocated since the last garbage collection. All data types count.\n\n\
5087 Garbage collection happens automatically only when `eval' is called.\n\n\
5088 By binding this temporarily to a large number, you can effectively\n\
5089 prevent garbage collection during a part of the program.");
5091 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5092 "Number of bytes of sharable Lisp data allocated so far.");
5094 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5095 "Number of cons cells that have been consed so far.");
5097 DEFVAR_INT ("floats-consed", &floats_consed
,
5098 "Number of floats that have been consed so far.");
5100 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5101 "Number of vector cells that have been consed so far.");
5103 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5104 "Number of symbols that have been consed so far.");
5106 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5107 "Number of string characters that have been consed so far.");
5109 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5110 "Number of miscellaneous objects that have been consed so far.");
5112 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5113 "Number of intervals that have been consed so far.");
5115 DEFVAR_INT ("strings-consed", &strings_consed
,
5116 "Number of strings that have been consed so far.");
5118 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5119 "Non-nil means loading Lisp code in order to dump an executable.\n\
5120 This means that certain objects should be allocated in shared (pure) space.");
5122 DEFVAR_INT ("undo-limit", &undo_limit
,
5123 "Keep no more undo information once it exceeds this size.\n\
5124 This limit is applied when garbage collection happens.\n\
5125 The size is counted as the number of bytes occupied,\n\
5126 which includes both saved text and other data.");
5129 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5130 "Don't keep more than this much size of undo information.\n\
5131 A command which pushes past this size is itself forgotten.\n\
5132 This limit is applied when garbage collection happens.\n\
5133 The size is counted as the number of bytes occupied,\n\
5134 which includes both saved text and other data.");
5135 undo_strong_limit
= 30000;
5137 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5138 "Non-nil means display messages at start and end of garbage collection.");
5139 garbage_collection_messages
= 0;
5141 /* We build this in advance because if we wait until we need it, we might
5142 not be able to allocate the memory to hold it. */
5144 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
5145 staticpro (&memory_signal_data
);
5147 staticpro (&Qgc_cons_threshold
);
5148 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5150 staticpro (&Qchar_table_extra_slots
);
5151 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5156 defsubr (&Smake_byte_code
);
5157 defsubr (&Smake_list
);
5158 defsubr (&Smake_vector
);
5159 defsubr (&Smake_char_table
);
5160 defsubr (&Smake_string
);
5161 defsubr (&Smake_bool_vector
);
5162 defsubr (&Smake_symbol
);
5163 defsubr (&Smake_marker
);
5164 defsubr (&Spurecopy
);
5165 defsubr (&Sgarbage_collect
);
5166 defsubr (&Smemory_limit
);
5167 defsubr (&Smemory_use_counts
);
5169 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5170 defsubr (&Sgc_status
);