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
663 if (m
== MEM_NIL
|| m
->start
!= ptr
)
666 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
671 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
675 #endif /* GC_MALLOC_CHECK */
677 __free_hook
= old_free_hook
;
680 /* If we released our reserve (due to running out of memory),
681 and we have a fair amount free once again,
682 try to set aside another reserve in case we run out once more. */
683 if (spare_memory
== 0
684 /* Verify there is enough space that even with the malloc
685 hysteresis this call won't run out again.
686 The code here is correct as long as SPARE_MEMORY
687 is substantially larger than the block size malloc uses. */
688 && (bytes_used_when_full
689 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
690 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
692 __free_hook
= emacs_blocked_free
;
697 /* If we released our reserve (due to running out of memory),
698 and we have a fair amount free once again,
699 try to set aside another reserve in case we run out once more.
701 This is called when a relocatable block is freed in ralloc.c. */
704 refill_memory_reserve ()
706 if (spare_memory
== 0)
707 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
711 /* This function is the malloc hook that Emacs uses. */
714 emacs_blocked_malloc (size
)
720 __malloc_hook
= old_malloc_hook
;
721 #ifdef DOUG_LEA_MALLOC
722 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
724 __malloc_extra_blocks
= malloc_hysteresis
;
727 value
= (void *) malloc (size
);
729 #ifdef GC_MALLOC_CHECK
731 struct mem_node
*m
= mem_find (value
);
734 fprintf (stderr
, "Malloc returned %p which is already in use\n",
736 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
737 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
742 if (!dont_register_blocks
)
744 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
745 allocated_mem_type
= MEM_TYPE_NON_LISP
;
748 #endif /* GC_MALLOC_CHECK */
750 __malloc_hook
= emacs_blocked_malloc
;
753 /* fprintf (stderr, "%p malloc\n", value); */
758 /* This function is the realloc hook that Emacs uses. */
761 emacs_blocked_realloc (ptr
, size
)
768 __realloc_hook
= old_realloc_hook
;
770 #ifdef GC_MALLOC_CHECK
773 struct mem_node
*m
= mem_find (ptr
);
774 if (m
== MEM_NIL
|| m
->start
!= ptr
)
777 "Realloc of %p which wasn't allocated with malloc\n",
785 /* fprintf (stderr, "%p -> realloc\n", ptr); */
787 /* Prevent malloc from registering blocks. */
788 dont_register_blocks
= 1;
789 #endif /* GC_MALLOC_CHECK */
791 value
= (void *) realloc (ptr
, size
);
793 #ifdef GC_MALLOC_CHECK
794 dont_register_blocks
= 0;
797 struct mem_node
*m
= mem_find (value
);
800 fprintf (stderr
, "Realloc returns memory that is already in use\n");
804 /* Can't handle zero size regions in the red-black tree. */
805 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
808 /* fprintf (stderr, "%p <- realloc\n", value); */
809 #endif /* GC_MALLOC_CHECK */
811 __realloc_hook
= emacs_blocked_realloc
;
818 /* Called from main to set up malloc to use our hooks. */
821 uninterrupt_malloc ()
823 if (__free_hook
!= emacs_blocked_free
)
824 old_free_hook
= __free_hook
;
825 __free_hook
= emacs_blocked_free
;
827 if (__malloc_hook
!= emacs_blocked_malloc
)
828 old_malloc_hook
= __malloc_hook
;
829 __malloc_hook
= emacs_blocked_malloc
;
831 if (__realloc_hook
!= emacs_blocked_realloc
)
832 old_realloc_hook
= __realloc_hook
;
833 __realloc_hook
= emacs_blocked_realloc
;
836 #endif /* not SYSTEM_MALLOC */
840 /***********************************************************************
842 ***********************************************************************/
844 /* Number of intervals allocated in an interval_block structure.
845 The 1020 is 1024 minus malloc overhead. */
847 #define INTERVAL_BLOCK_SIZE \
848 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
850 /* Intervals are allocated in chunks in form of an interval_block
853 struct interval_block
855 struct interval_block
*next
;
856 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
859 /* Current interval block. Its `next' pointer points to older
862 struct interval_block
*interval_block
;
864 /* Index in interval_block above of the next unused interval
867 static int interval_block_index
;
869 /* Number of free and live intervals. */
871 static int total_free_intervals
, total_intervals
;
873 /* List of free intervals. */
875 INTERVAL interval_free_list
;
877 /* Total number of interval blocks now in use. */
879 int n_interval_blocks
;
882 /* Initialize interval allocation. */
888 = (struct interval_block
*) lisp_malloc (sizeof *interval_block
,
890 interval_block
->next
= 0;
891 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
892 interval_block_index
= 0;
893 interval_free_list
= 0;
894 n_interval_blocks
= 1;
898 /* Return a new interval. */
905 if (interval_free_list
)
907 val
= interval_free_list
;
908 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
912 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
914 register struct interval_block
*newi
;
916 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
919 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
920 newi
->next
= interval_block
;
921 interval_block
= newi
;
922 interval_block_index
= 0;
925 val
= &interval_block
->intervals
[interval_block_index
++];
927 consing_since_gc
+= sizeof (struct interval
);
929 RESET_INTERVAL (val
);
934 /* Mark Lisp objects in interval I. */
937 mark_interval (i
, dummy
)
941 if (XMARKBIT (i
->plist
))
943 mark_object (&i
->plist
);
948 /* Mark the interval tree rooted in TREE. Don't call this directly;
949 use the macro MARK_INTERVAL_TREE instead. */
952 mark_interval_tree (tree
)
953 register INTERVAL tree
;
955 /* No need to test if this tree has been marked already; this
956 function is always called through the MARK_INTERVAL_TREE macro,
957 which takes care of that. */
959 /* XMARK expands to an assignment; the LHS of an assignment can't be
961 XMARK (tree
->up
.obj
);
963 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
967 /* Mark the interval tree rooted in I. */
969 #define MARK_INTERVAL_TREE(i) \
971 if (!NULL_INTERVAL_P (i) \
972 && ! XMARKBIT (i->up.obj)) \
973 mark_interval_tree (i); \
977 /* The oddity in the call to XUNMARK is necessary because XUNMARK
978 expands to an assignment to its argument, and most C compilers
979 don't support casts on the left operand of `='. */
981 #define UNMARK_BALANCE_INTERVALS(i) \
983 if (! NULL_INTERVAL_P (i)) \
985 XUNMARK ((i)->up.obj); \
986 (i) = balance_intervals (i); \
991 /* Number support. If NO_UNION_TYPE isn't in effect, we
992 can't create number objects in macros. */
1000 obj
.s
.type
= Lisp_Int
;
1005 /***********************************************************************
1007 ***********************************************************************/
1009 /* Lisp_Strings are allocated in string_block structures. When a new
1010 string_block is allocated, all the Lisp_Strings it contains are
1011 added to a free-list stiing_free_list. When a new Lisp_String is
1012 needed, it is taken from that list. During the sweep phase of GC,
1013 string_blocks that are entirely free are freed, except two which
1016 String data is allocated from sblock structures. Strings larger
1017 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1018 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1020 Sblocks consist internally of sdata structures, one for each
1021 Lisp_String. The sdata structure points to the Lisp_String it
1022 belongs to. The Lisp_String points back to the `u.data' member of
1023 its sdata structure.
1025 When a Lisp_String is freed during GC, it is put back on
1026 string_free_list, and its `data' member and its sdata's `string'
1027 pointer is set to null. The size of the string is recorded in the
1028 `u.nbytes' member of the sdata. So, sdata structures that are no
1029 longer used, can be easily recognized, and it's easy to compact the
1030 sblocks of small strings which we do in compact_small_strings. */
1032 /* Size in bytes of an sblock structure used for small strings. This
1033 is 8192 minus malloc overhead. */
1035 #define SBLOCK_SIZE 8188
1037 /* Strings larger than this are considered large strings. String data
1038 for large strings is allocated from individual sblocks. */
1040 #define LARGE_STRING_BYTES 1024
1042 /* Structure describing string memory sub-allocated from an sblock.
1043 This is where the contents of Lisp strings are stored. */
1047 /* Back-pointer to the string this sdata belongs to. If null, this
1048 structure is free, and the NBYTES member of the union below
1049 contains the string's byte size (the same value that STRING_BYTES
1050 would return if STRING were non-null). If non-null, STRING_BYTES
1051 (STRING) is the size of the data, and DATA contains the string's
1053 struct Lisp_String
*string
;
1055 #ifdef GC_CHECK_STRING_BYTES
1058 unsigned char data
[1];
1060 #define SDATA_NBYTES(S) (S)->nbytes
1061 #define SDATA_DATA(S) (S)->data
1063 #else /* not GC_CHECK_STRING_BYTES */
1067 /* When STRING in non-null. */
1068 unsigned char data
[1];
1070 /* When STRING is null. */
1075 #define SDATA_NBYTES(S) (S)->u.nbytes
1076 #define SDATA_DATA(S) (S)->u.data
1078 #endif /* not GC_CHECK_STRING_BYTES */
1082 /* Structure describing a block of memory which is sub-allocated to
1083 obtain string data memory for strings. Blocks for small strings
1084 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1085 as large as needed. */
1090 struct sblock
*next
;
1092 /* Pointer to the next free sdata block. This points past the end
1093 of the sblock if there isn't any space left in this block. */
1094 struct sdata
*next_free
;
1096 /* Start of data. */
1097 struct sdata first_data
;
1100 /* Number of Lisp strings in a string_block structure. The 1020 is
1101 1024 minus malloc overhead. */
1103 #define STRINGS_IN_STRING_BLOCK \
1104 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1106 /* Structure describing a block from which Lisp_String structures
1111 struct string_block
*next
;
1112 struct Lisp_String strings
[STRINGS_IN_STRING_BLOCK
];
1115 /* Head and tail of the list of sblock structures holding Lisp string
1116 data. We always allocate from current_sblock. The NEXT pointers
1117 in the sblock structures go from oldest_sblock to current_sblock. */
1119 static struct sblock
*oldest_sblock
, *current_sblock
;
1121 /* List of sblocks for large strings. */
1123 static struct sblock
*large_sblocks
;
1125 /* List of string_block structures, and how many there are. */
1127 static struct string_block
*string_blocks
;
1128 static int n_string_blocks
;
1130 /* Free-list of Lisp_Strings. */
1132 static struct Lisp_String
*string_free_list
;
1134 /* Number of live and free Lisp_Strings. */
1136 static int total_strings
, total_free_strings
;
1138 /* Number of bytes used by live strings. */
1140 static int total_string_size
;
1142 /* Given a pointer to a Lisp_String S which is on the free-list
1143 string_free_list, return a pointer to its successor in the
1146 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1148 /* Return a pointer to the sdata structure belonging to Lisp string S.
1149 S must be live, i.e. S->data must not be null. S->data is actually
1150 a pointer to the `u.data' member of its sdata structure; the
1151 structure starts at a constant offset in front of that. */
1153 #ifdef GC_CHECK_STRING_BYTES
1155 #define SDATA_OF_STRING(S) \
1156 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1157 - sizeof (EMACS_INT)))
1159 #else /* not GC_CHECK_STRING_BYTES */
1161 #define SDATA_OF_STRING(S) \
1162 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1164 #endif /* not GC_CHECK_STRING_BYTES */
1166 /* Value is the size of an sdata structure large enough to hold NBYTES
1167 bytes of string data. The value returned includes a terminating
1168 NUL byte, the size of the sdata structure, and padding. */
1170 #ifdef GC_CHECK_STRING_BYTES
1172 #define SDATA_SIZE(NBYTES) \
1173 ((sizeof (struct Lisp_String *) \
1175 + sizeof (EMACS_INT) \
1176 + sizeof (EMACS_INT) - 1) \
1177 & ~(sizeof (EMACS_INT) - 1))
1179 #else /* not GC_CHECK_STRING_BYTES */
1181 #define SDATA_SIZE(NBYTES) \
1182 ((sizeof (struct Lisp_String *) \
1184 + sizeof (EMACS_INT) - 1) \
1185 & ~(sizeof (EMACS_INT) - 1))
1187 #endif /* not GC_CHECK_STRING_BYTES */
1189 /* Initialize string allocation. Called from init_alloc_once. */
1194 total_strings
= total_free_strings
= total_string_size
= 0;
1195 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1196 string_blocks
= NULL
;
1197 n_string_blocks
= 0;
1198 string_free_list
= NULL
;
1202 #ifdef GC_CHECK_STRING_BYTES
1204 /* Check validity of all live Lisp strings' string_bytes member.
1205 Used for hunting a bug. */
1207 static int check_string_bytes_count
;
1210 check_string_bytes ()
1214 for (b
= large_sblocks
; b
; b
= b
->next
)
1216 struct Lisp_String
*s
= b
->first_data
.string
;
1217 if (s
&& GC_STRING_BYTES (s
) != SDATA_NBYTES (SDATA_OF_STRING (s
)))
1221 for (b
= oldest_sblock
; b
; b
= b
->next
)
1223 struct sdata
*from
, *end
, *from_end
;
1227 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1229 /* Compute the next FROM here because copying below may
1230 overwrite data we need to compute it. */
1233 /* Check that the string size recorded in the string is the
1234 same as the one recorded in the sdata structure. */
1236 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1240 nbytes
= GC_STRING_BYTES (from
->string
);
1242 nbytes
= SDATA_NBYTES (from
);
1244 nbytes
= SDATA_SIZE (nbytes
);
1245 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1250 #endif /* GC_CHECK_STRING_BYTES */
1253 /* Return a new Lisp_String. */
1255 static struct Lisp_String
*
1258 struct Lisp_String
*s
;
1260 /* If the free-list is empty, allocate a new string_block, and
1261 add all the Lisp_Strings in it to the free-list. */
1262 if (string_free_list
== NULL
)
1264 struct string_block
*b
;
1267 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1268 VALIDATE_LISP_STORAGE (b
, sizeof *b
);
1269 bzero (b
, sizeof *b
);
1270 b
->next
= string_blocks
;
1274 for (i
= STRINGS_IN_STRING_BLOCK
- 1; i
>= 0; --i
)
1277 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1278 string_free_list
= s
;
1281 total_free_strings
+= STRINGS_IN_STRING_BLOCK
;
1284 /* Pop a Lisp_String off the free-list. */
1285 s
= string_free_list
;
1286 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1288 /* Probably not strictly necessary, but play it safe. */
1289 bzero (s
, sizeof *s
);
1291 --total_free_strings
;
1294 consing_since_gc
+= sizeof *s
;
1296 #ifdef GC_CHECK_STRING_BYTES
1297 if (!noninteractive
&& ++check_string_bytes_count
== 50)
1299 check_string_bytes_count
= 0;
1300 check_string_bytes ();
1308 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1309 plus a NUL byte at the end. Allocate an sdata structure for S, and
1310 set S->data to its `u.data' member. Store a NUL byte at the end of
1311 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1312 S->data if it was initially non-null. */
1315 allocate_string_data (s
, nchars
, nbytes
)
1316 struct Lisp_String
*s
;
1319 struct sdata
*data
, *old_data
;
1321 int needed
, old_nbytes
;
1323 /* Determine the number of bytes needed to store NBYTES bytes
1325 needed
= SDATA_SIZE (nbytes
);
1327 if (nbytes
> LARGE_STRING_BYTES
)
1329 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1331 #ifdef DOUG_LEA_MALLOC
1332 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1333 because mapped region contents are not preserved in
1335 mallopt (M_MMAP_MAX
, 0);
1338 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1340 #ifdef DOUG_LEA_MALLOC
1341 /* Back to a reasonable maximum of mmap'ed areas. */
1342 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1345 b
->next_free
= &b
->first_data
;
1346 b
->first_data
.string
= NULL
;
1347 b
->next
= large_sblocks
;
1350 else if (current_sblock
== NULL
1351 || (((char *) current_sblock
+ SBLOCK_SIZE
1352 - (char *) current_sblock
->next_free
)
1355 /* Not enough room in the current sblock. */
1356 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1357 b
->next_free
= &b
->first_data
;
1358 b
->first_data
.string
= NULL
;
1362 current_sblock
->next
= b
;
1370 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1371 old_nbytes
= GC_STRING_BYTES (s
);
1373 data
= b
->next_free
;
1375 s
->data
= SDATA_DATA (data
);
1376 #ifdef GC_CHECK_STRING_BYTES
1377 SDATA_NBYTES (data
) = nbytes
;
1380 s
->size_byte
= nbytes
;
1381 s
->data
[nbytes
] = '\0';
1382 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1384 /* If S had already data assigned, mark that as free by setting its
1385 string back-pointer to null, and recording the size of the data
1389 SDATA_NBYTES (old_data
) = old_nbytes
;
1390 old_data
->string
= NULL
;
1393 consing_since_gc
+= needed
;
1397 /* Sweep and compact strings. */
1402 struct string_block
*b
, *next
;
1403 struct string_block
*live_blocks
= NULL
;
1405 string_free_list
= NULL
;
1406 total_strings
= total_free_strings
= 0;
1407 total_string_size
= 0;
1409 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1410 for (b
= string_blocks
; b
; b
= next
)
1413 struct Lisp_String
*free_list_before
= string_free_list
;
1417 for (i
= 0; i
< STRINGS_IN_STRING_BLOCK
; ++i
)
1419 struct Lisp_String
*s
= b
->strings
+ i
;
1423 /* String was not on free-list before. */
1424 if (STRING_MARKED_P (s
))
1426 /* String is live; unmark it and its intervals. */
1429 if (!NULL_INTERVAL_P (s
->intervals
))
1430 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1433 total_string_size
+= STRING_BYTES (s
);
1437 /* String is dead. Put it on the free-list. */
1438 struct sdata
*data
= SDATA_OF_STRING (s
);
1440 /* Save the size of S in its sdata so that we know
1441 how large that is. Reset the sdata's string
1442 back-pointer so that we know it's free. */
1443 #ifdef GC_CHECK_STRING_BYTES
1444 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1447 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1449 data
->string
= NULL
;
1451 /* Reset the strings's `data' member so that we
1455 /* Put the string on the free-list. */
1456 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1457 string_free_list
= s
;
1463 /* S was on the free-list before. Put it there again. */
1464 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1465 string_free_list
= s
;
1470 /* Free blocks that contain free Lisp_Strings only, except
1471 the first two of them. */
1472 if (nfree
== STRINGS_IN_STRING_BLOCK
1473 && total_free_strings
> STRINGS_IN_STRING_BLOCK
)
1477 string_free_list
= free_list_before
;
1481 total_free_strings
+= nfree
;
1482 b
->next
= live_blocks
;
1487 string_blocks
= live_blocks
;
1488 free_large_strings ();
1489 compact_small_strings ();
1493 /* Free dead large strings. */
1496 free_large_strings ()
1498 struct sblock
*b
, *next
;
1499 struct sblock
*live_blocks
= NULL
;
1501 for (b
= large_sblocks
; b
; b
= next
)
1505 if (b
->first_data
.string
== NULL
)
1509 b
->next
= live_blocks
;
1514 large_sblocks
= live_blocks
;
1518 /* Compact data of small strings. Free sblocks that don't contain
1519 data of live strings after compaction. */
1522 compact_small_strings ()
1524 struct sblock
*b
, *tb
, *next
;
1525 struct sdata
*from
, *to
, *end
, *tb_end
;
1526 struct sdata
*to_end
, *from_end
;
1528 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1529 to, and TB_END is the end of TB. */
1531 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1532 to
= &tb
->first_data
;
1534 /* Step through the blocks from the oldest to the youngest. We
1535 expect that old blocks will stabilize over time, so that less
1536 copying will happen this way. */
1537 for (b
= oldest_sblock
; b
; b
= b
->next
)
1540 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1542 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1544 /* Compute the next FROM here because copying below may
1545 overwrite data we need to compute it. */
1548 #ifdef GC_CHECK_STRING_BYTES
1549 /* Check that the string size recorded in the string is the
1550 same as the one recorded in the sdata structure. */
1552 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1554 #endif /* GC_CHECK_STRING_BYTES */
1557 nbytes
= GC_STRING_BYTES (from
->string
);
1559 nbytes
= SDATA_NBYTES (from
);
1561 nbytes
= SDATA_SIZE (nbytes
);
1562 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1564 /* FROM->string non-null means it's alive. Copy its data. */
1567 /* If TB is full, proceed with the next sblock. */
1568 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1569 if (to_end
> tb_end
)
1573 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1574 to
= &tb
->first_data
;
1575 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1578 /* Copy, and update the string's `data' pointer. */
1581 xassert (tb
!= b
|| to
<= from
);
1582 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1583 to
->string
->data
= SDATA_DATA (to
);
1586 /* Advance past the sdata we copied to. */
1592 /* The rest of the sblocks following TB don't contain live data, so
1593 we can free them. */
1594 for (b
= tb
->next
; b
; b
= next
)
1602 current_sblock
= tb
;
1606 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1607 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1608 Both LENGTH and INIT must be numbers.")
1610 Lisp_Object length
, init
;
1612 register Lisp_Object val
;
1613 register unsigned char *p
, *end
;
1616 CHECK_NATNUM (length
, 0);
1617 CHECK_NUMBER (init
, 1);
1620 if (SINGLE_BYTE_CHAR_P (c
))
1622 nbytes
= XINT (length
);
1623 val
= make_uninit_string (nbytes
);
1624 p
= XSTRING (val
)->data
;
1625 end
= p
+ XSTRING (val
)->size
;
1631 unsigned char str
[4];
1632 int len
= CHAR_STRING (c
, str
);
1634 nbytes
= len
* XINT (length
);
1635 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1636 p
= XSTRING (val
)->data
;
1640 bcopy (str
, p
, len
);
1650 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1651 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1652 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1654 Lisp_Object length
, init
;
1656 register Lisp_Object val
;
1657 struct Lisp_Bool_Vector
*p
;
1659 int length_in_chars
, length_in_elts
, bits_per_value
;
1661 CHECK_NATNUM (length
, 0);
1663 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1665 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1666 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1668 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1669 slot `size' of the struct Lisp_Bool_Vector. */
1670 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1671 p
= XBOOL_VECTOR (val
);
1673 /* Get rid of any bits that would cause confusion. */
1675 XSETBOOL_VECTOR (val
, p
);
1676 p
->size
= XFASTINT (length
);
1678 real_init
= (NILP (init
) ? 0 : -1);
1679 for (i
= 0; i
< length_in_chars
; i
++)
1680 p
->data
[i
] = real_init
;
1682 /* Clear the extraneous bits in the last byte. */
1683 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1684 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1685 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1691 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1692 of characters from the contents. This string may be unibyte or
1693 multibyte, depending on the contents. */
1696 make_string (contents
, nbytes
)
1700 register Lisp_Object val
;
1701 int nchars
, multibyte_nbytes
;
1703 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1704 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1705 /* CONTENTS contains no multibyte sequences or contains an invalid
1706 multibyte sequence. We must make unibyte string. */
1707 val
= make_unibyte_string (contents
, nbytes
);
1709 val
= make_multibyte_string (contents
, nchars
, nbytes
);
1714 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
1717 make_unibyte_string (contents
, length
)
1721 register Lisp_Object val
;
1722 val
= make_uninit_string (length
);
1723 bcopy (contents
, XSTRING (val
)->data
, length
);
1724 SET_STRING_BYTES (XSTRING (val
), -1);
1729 /* Make a multibyte string from NCHARS characters occupying NBYTES
1730 bytes at CONTENTS. */
1733 make_multibyte_string (contents
, nchars
, nbytes
)
1737 register Lisp_Object val
;
1738 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1739 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1744 /* Make a string from NCHARS characters occupying NBYTES bytes at
1745 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
1748 make_string_from_bytes (contents
, nchars
, nbytes
)
1752 register Lisp_Object val
;
1753 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1754 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1755 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1756 SET_STRING_BYTES (XSTRING (val
), -1);
1761 /* Make a string from NCHARS characters occupying NBYTES bytes at
1762 CONTENTS. The argument MULTIBYTE controls whether to label the
1763 string as multibyte. */
1766 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1771 register Lisp_Object val
;
1772 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1773 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1775 SET_STRING_BYTES (XSTRING (val
), -1);
1780 /* Make a string from the data at STR, treating it as multibyte if the
1787 return make_string (str
, strlen (str
));
1791 /* Return an unibyte Lisp_String set up to hold LENGTH characters
1792 occupying LENGTH bytes. */
1795 make_uninit_string (length
)
1799 val
= make_uninit_multibyte_string (length
, length
);
1800 SET_STRING_BYTES (XSTRING (val
), -1);
1805 /* Return a multibyte Lisp_String set up to hold NCHARS characters
1806 which occupy NBYTES bytes. */
1809 make_uninit_multibyte_string (nchars
, nbytes
)
1813 struct Lisp_String
*s
;
1818 s
= allocate_string ();
1819 allocate_string_data (s
, nchars
, nbytes
);
1820 XSETSTRING (string
, s
);
1821 string_chars_consed
+= nbytes
;
1827 /***********************************************************************
1829 ***********************************************************************/
1831 /* We store float cells inside of float_blocks, allocating a new
1832 float_block with malloc whenever necessary. Float cells reclaimed
1833 by GC are put on a free list to be reallocated before allocating
1834 any new float cells from the latest float_block.
1836 Each float_block is just under 1020 bytes long, since malloc really
1837 allocates in units of powers of two and uses 4 bytes for its own
1840 #define FLOAT_BLOCK_SIZE \
1841 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
1845 struct float_block
*next
;
1846 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
1849 /* Current float_block. */
1851 struct float_block
*float_block
;
1853 /* Index of first unused Lisp_Float in the current float_block. */
1855 int float_block_index
;
1857 /* Total number of float blocks now in use. */
1861 /* Free-list of Lisp_Floats. */
1863 struct Lisp_Float
*float_free_list
;
1866 /* Initialze float allocation. */
1871 float_block
= (struct float_block
*) lisp_malloc (sizeof *float_block
,
1873 float_block
->next
= 0;
1874 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
1875 float_block_index
= 0;
1876 float_free_list
= 0;
1881 /* Explicitly free a float cell by putting it on the free-list. */
1885 struct Lisp_Float
*ptr
;
1887 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
1891 float_free_list
= ptr
;
1895 /* Return a new float object with value FLOAT_VALUE. */
1898 make_float (float_value
)
1901 register Lisp_Object val
;
1903 if (float_free_list
)
1905 /* We use the data field for chaining the free list
1906 so that we won't use the same field that has the mark bit. */
1907 XSETFLOAT (val
, float_free_list
);
1908 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
1912 if (float_block_index
== FLOAT_BLOCK_SIZE
)
1914 register struct float_block
*new;
1916 new = (struct float_block
*) lisp_malloc (sizeof *new,
1918 VALIDATE_LISP_STORAGE (new, sizeof *new);
1919 new->next
= float_block
;
1921 float_block_index
= 0;
1924 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
1927 XFLOAT_DATA (val
) = float_value
;
1928 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
1929 consing_since_gc
+= sizeof (struct Lisp_Float
);
1936 /***********************************************************************
1938 ***********************************************************************/
1940 /* We store cons cells inside of cons_blocks, allocating a new
1941 cons_block with malloc whenever necessary. Cons cells reclaimed by
1942 GC are put on a free list to be reallocated before allocating
1943 any new cons cells from the latest cons_block.
1945 Each cons_block is just under 1020 bytes long,
1946 since malloc really allocates in units of powers of two
1947 and uses 4 bytes for its own overhead. */
1949 #define CONS_BLOCK_SIZE \
1950 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
1954 struct cons_block
*next
;
1955 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
1958 /* Current cons_block. */
1960 struct cons_block
*cons_block
;
1962 /* Index of first unused Lisp_Cons in the current block. */
1964 int cons_block_index
;
1966 /* Free-list of Lisp_Cons structures. */
1968 struct Lisp_Cons
*cons_free_list
;
1970 /* Total number of cons blocks now in use. */
1975 /* Initialize cons allocation. */
1980 cons_block
= (struct cons_block
*) lisp_malloc (sizeof *cons_block
,
1982 cons_block
->next
= 0;
1983 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
1984 cons_block_index
= 0;
1990 /* Explicitly free a cons cell by putting it on the free-list. */
1994 struct Lisp_Cons
*ptr
;
1996 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2000 cons_free_list
= ptr
;
2004 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2005 "Create a new cons, give it CAR and CDR as components, and return it.")
2007 Lisp_Object car
, cdr
;
2009 register Lisp_Object val
;
2013 /* We use the cdr for chaining the free list
2014 so that we won't use the same field that has the mark bit. */
2015 XSETCONS (val
, cons_free_list
);
2016 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2020 if (cons_block_index
== CONS_BLOCK_SIZE
)
2022 register struct cons_block
*new;
2023 new = (struct cons_block
*) lisp_malloc (sizeof *new,
2025 VALIDATE_LISP_STORAGE (new, sizeof *new);
2026 new->next
= cons_block
;
2028 cons_block_index
= 0;
2031 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
2036 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2037 cons_cells_consed
++;
2042 /* Make a list of 2, 3, 4 or 5 specified objects. */
2046 Lisp_Object arg1
, arg2
;
2048 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2053 list3 (arg1
, arg2
, arg3
)
2054 Lisp_Object arg1
, arg2
, arg3
;
2056 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2061 list4 (arg1
, arg2
, arg3
, arg4
)
2062 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2064 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2069 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2070 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2072 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2073 Fcons (arg5
, Qnil
)))));
2077 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2078 "Return a newly created list with specified arguments as elements.\n\
2079 Any number of arguments, even zero arguments, are allowed.")
2082 register Lisp_Object
*args
;
2084 register Lisp_Object val
;
2090 val
= Fcons (args
[nargs
], val
);
2096 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2097 "Return a newly created list of length LENGTH, with each element being INIT.")
2099 register Lisp_Object length
, init
;
2101 register Lisp_Object val
;
2104 CHECK_NATNUM (length
, 0);
2105 size
= XFASTINT (length
);
2109 val
= Fcons (init
, val
);
2115 /***********************************************************************
2117 ***********************************************************************/
2119 /* Singly-linked list of all vectors. */
2121 struct Lisp_Vector
*all_vectors
;
2123 /* Total number of vector-like objects now in use. */
2128 /* Value is a pointer to a newly allocated Lisp_Vector structure
2129 with room for LEN Lisp_Objects. */
2131 struct Lisp_Vector
*
2132 allocate_vectorlike (len
)
2135 struct Lisp_Vector
*p
;
2138 #ifdef DOUG_LEA_MALLOC
2139 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2140 because mapped region contents are not preserved in
2142 mallopt (M_MMAP_MAX
, 0);
2145 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2146 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTOR
);
2148 #ifdef DOUG_LEA_MALLOC
2149 /* Back to a reasonable maximum of mmap'ed areas. */
2150 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2153 VALIDATE_LISP_STORAGE (p
, 0);
2154 consing_since_gc
+= nbytes
;
2155 vector_cells_consed
+= len
;
2157 p
->next
= all_vectors
;
2164 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2165 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
2166 See also the function `vector'.")
2168 register Lisp_Object length
, init
;
2171 register EMACS_INT sizei
;
2173 register struct Lisp_Vector
*p
;
2175 CHECK_NATNUM (length
, 0);
2176 sizei
= XFASTINT (length
);
2178 p
= allocate_vectorlike (sizei
);
2180 for (index
= 0; index
< sizei
; index
++)
2181 p
->contents
[index
] = init
;
2183 XSETVECTOR (vector
, p
);
2188 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2189 "Return a newly created char-table, with purpose PURPOSE.\n\
2190 Each element is initialized to INIT, which defaults to nil.\n\
2191 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
2192 The property's value should be an integer between 0 and 10.")
2194 register Lisp_Object purpose
, init
;
2198 CHECK_SYMBOL (purpose
, 1);
2199 n
= Fget (purpose
, Qchar_table_extra_slots
);
2200 CHECK_NUMBER (n
, 0);
2201 if (XINT (n
) < 0 || XINT (n
) > 10)
2202 args_out_of_range (n
, Qnil
);
2203 /* Add 2 to the size for the defalt and parent slots. */
2204 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2206 XCHAR_TABLE (vector
)->top
= Qt
;
2207 XCHAR_TABLE (vector
)->parent
= Qnil
;
2208 XCHAR_TABLE (vector
)->purpose
= purpose
;
2209 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2214 /* Return a newly created sub char table with default value DEFALT.
2215 Since a sub char table does not appear as a top level Emacs Lisp
2216 object, we don't need a Lisp interface to make it. */
2219 make_sub_char_table (defalt
)
2223 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2224 XCHAR_TABLE (vector
)->top
= Qnil
;
2225 XCHAR_TABLE (vector
)->defalt
= defalt
;
2226 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2231 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2232 "Return a newly created vector with specified arguments as elements.\n\
2233 Any number of arguments, even zero arguments, are allowed.")
2238 register Lisp_Object len
, val
;
2240 register struct Lisp_Vector
*p
;
2242 XSETFASTINT (len
, nargs
);
2243 val
= Fmake_vector (len
, Qnil
);
2245 for (index
= 0; index
< nargs
; index
++)
2246 p
->contents
[index
] = args
[index
];
2251 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2252 "Create a byte-code object with specified arguments as elements.\n\
2253 The arguments should be the arglist, bytecode-string, constant vector,\n\
2254 stack size, (optional) doc string, and (optional) interactive spec.\n\
2255 The first four arguments are required; at most six have any\n\
2261 register Lisp_Object len
, val
;
2263 register struct Lisp_Vector
*p
;
2265 XSETFASTINT (len
, nargs
);
2266 if (!NILP (Vpurify_flag
))
2267 val
= make_pure_vector ((EMACS_INT
) nargs
);
2269 val
= Fmake_vector (len
, Qnil
);
2271 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2272 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2273 earlier because they produced a raw 8-bit string for byte-code
2274 and now such a byte-code string is loaded as multibyte while
2275 raw 8-bit characters converted to multibyte form. Thus, now we
2276 must convert them back to the original unibyte form. */
2277 args
[1] = Fstring_as_unibyte (args
[1]);
2280 for (index
= 0; index
< nargs
; index
++)
2282 if (!NILP (Vpurify_flag
))
2283 args
[index
] = Fpurecopy (args
[index
]);
2284 p
->contents
[index
] = args
[index
];
2286 XSETCOMPILED (val
, p
);
2292 /***********************************************************************
2294 ***********************************************************************/
2296 /* Each symbol_block is just under 1020 bytes long, since malloc
2297 really allocates in units of powers of two and uses 4 bytes for its
2300 #define SYMBOL_BLOCK_SIZE \
2301 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2305 struct symbol_block
*next
;
2306 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2309 /* Current symbol block and index of first unused Lisp_Symbol
2312 struct symbol_block
*symbol_block
;
2313 int symbol_block_index
;
2315 /* List of free symbols. */
2317 struct Lisp_Symbol
*symbol_free_list
;
2319 /* Total number of symbol blocks now in use. */
2321 int n_symbol_blocks
;
2324 /* Initialize symbol allocation. */
2329 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof *symbol_block
,
2331 symbol_block
->next
= 0;
2332 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
2333 symbol_block_index
= 0;
2334 symbol_free_list
= 0;
2335 n_symbol_blocks
= 1;
2339 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2340 "Return a newly allocated uninterned symbol whose name is NAME.\n\
2341 Its value and function definition are void, and its property list is nil.")
2345 register Lisp_Object val
;
2346 register struct Lisp_Symbol
*p
;
2348 CHECK_STRING (name
, 0);
2350 if (symbol_free_list
)
2352 XSETSYMBOL (val
, symbol_free_list
);
2353 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2357 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2359 struct symbol_block
*new;
2360 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2362 VALIDATE_LISP_STORAGE (new, sizeof *new);
2363 new->next
= symbol_block
;
2365 symbol_block_index
= 0;
2368 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2372 p
->name
= XSTRING (name
);
2375 p
->value
= Qunbound
;
2376 p
->function
= Qunbound
;
2378 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2385 /***********************************************************************
2386 Marker (Misc) Allocation
2387 ***********************************************************************/
2389 /* Allocation of markers and other objects that share that structure.
2390 Works like allocation of conses. */
2392 #define MARKER_BLOCK_SIZE \
2393 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2397 struct marker_block
*next
;
2398 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2401 struct marker_block
*marker_block
;
2402 int marker_block_index
;
2404 union Lisp_Misc
*marker_free_list
;
2406 /* Total number of marker blocks now in use. */
2408 int n_marker_blocks
;
2413 marker_block
= (struct marker_block
*) lisp_malloc (sizeof *marker_block
,
2415 marker_block
->next
= 0;
2416 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
2417 marker_block_index
= 0;
2418 marker_free_list
= 0;
2419 n_marker_blocks
= 1;
2422 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2429 if (marker_free_list
)
2431 XSETMISC (val
, marker_free_list
);
2432 marker_free_list
= marker_free_list
->u_free
.chain
;
2436 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2438 struct marker_block
*new;
2439 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2441 VALIDATE_LISP_STORAGE (new, sizeof *new);
2442 new->next
= marker_block
;
2444 marker_block_index
= 0;
2447 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2450 consing_since_gc
+= sizeof (union Lisp_Misc
);
2451 misc_objects_consed
++;
2455 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2456 "Return a newly allocated marker which does not point at any place.")
2459 register Lisp_Object val
;
2460 register struct Lisp_Marker
*p
;
2462 val
= allocate_misc ();
2463 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2469 p
->insertion_type
= 0;
2473 /* Put MARKER back on the free list after using it temporarily. */
2476 free_marker (marker
)
2479 unchain_marker (marker
);
2481 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2482 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2483 marker_free_list
= XMISC (marker
);
2485 total_free_markers
++;
2489 /* Return a newly created vector or string with specified arguments as
2490 elements. If all the arguments are characters that can fit
2491 in a string of events, make a string; otherwise, make a vector.
2493 Any number of arguments, even zero arguments, are allowed. */
2496 make_event_array (nargs
, args
)
2502 for (i
= 0; i
< nargs
; i
++)
2503 /* The things that fit in a string
2504 are characters that are in 0...127,
2505 after discarding the meta bit and all the bits above it. */
2506 if (!INTEGERP (args
[i
])
2507 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2508 return Fvector (nargs
, args
);
2510 /* Since the loop exited, we know that all the things in it are
2511 characters, so we can make a string. */
2515 result
= Fmake_string (make_number (nargs
), make_number (0));
2516 for (i
= 0; i
< nargs
; i
++)
2518 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
2519 /* Move the meta bit to the right place for a string char. */
2520 if (XINT (args
[i
]) & CHAR_META
)
2521 XSTRING (result
)->data
[i
] |= 0x80;
2530 /************************************************************************
2532 ************************************************************************/
2534 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
2536 /* Initialize this part of alloc.c. */
2541 mem_z
.left
= mem_z
.right
= MEM_NIL
;
2542 mem_z
.parent
= NULL
;
2543 mem_z
.color
= MEM_BLACK
;
2544 mem_z
.start
= mem_z
.end
= NULL
;
2549 /* Value is a pointer to the mem_node containing START. Value is
2550 MEM_NIL if there is no node in the tree containing START. */
2552 static INLINE
struct mem_node
*
2558 /* Make the search always successful to speed up the loop below. */
2559 mem_z
.start
= start
;
2560 mem_z
.end
= (char *) start
+ 1;
2563 while (start
< p
->start
|| start
>= p
->end
)
2564 p
= start
< p
->start
? p
->left
: p
->right
;
2569 /* Insert a new node into the tree for a block of memory with start
2570 address START, end address END, and type TYPE. Value is a
2571 pointer to the node that was inserted. */
2573 static struct mem_node
*
2574 mem_insert (start
, end
, type
)
2578 struct mem_node
*c
, *parent
, *x
;
2580 /* See where in the tree a node for START belongs. In this
2581 particular application, it shouldn't happen that a node is already
2582 present. For debugging purposes, let's check that. */
2586 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
2588 while (c
!= MEM_NIL
)
2590 if (start
>= c
->start
&& start
< c
->end
)
2593 c
= start
< c
->start
? c
->left
: c
->right
;
2596 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2598 while (c
!= MEM_NIL
)
2601 c
= start
< c
->start
? c
->left
: c
->right
;
2604 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
2606 /* Create a new node. */
2607 #ifdef GC_MALLOC_CHECK
2608 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
2612 x
= (struct mem_node
*) xmalloc (sizeof *x
);
2618 x
->left
= x
->right
= MEM_NIL
;
2621 /* Insert it as child of PARENT or install it as root. */
2624 if (start
< parent
->start
)
2632 /* Re-establish red-black tree properties. */
2633 mem_insert_fixup (x
);
2639 /* Re-establish the red-black properties of the tree, and thereby
2640 balance the tree, after node X has been inserted; X is always red. */
2643 mem_insert_fixup (x
)
2646 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
2648 /* X is red and its parent is red. This is a violation of
2649 red-black tree property #3. */
2651 if (x
->parent
== x
->parent
->parent
->left
)
2653 /* We're on the left side of our grandparent, and Y is our
2655 struct mem_node
*y
= x
->parent
->parent
->right
;
2657 if (y
->color
== MEM_RED
)
2659 /* Uncle and parent are red but should be black because
2660 X is red. Change the colors accordingly and proceed
2661 with the grandparent. */
2662 x
->parent
->color
= MEM_BLACK
;
2663 y
->color
= MEM_BLACK
;
2664 x
->parent
->parent
->color
= MEM_RED
;
2665 x
= x
->parent
->parent
;
2669 /* Parent and uncle have different colors; parent is
2670 red, uncle is black. */
2671 if (x
== x
->parent
->right
)
2674 mem_rotate_left (x
);
2677 x
->parent
->color
= MEM_BLACK
;
2678 x
->parent
->parent
->color
= MEM_RED
;
2679 mem_rotate_right (x
->parent
->parent
);
2684 /* This is the symmetrical case of above. */
2685 struct mem_node
*y
= x
->parent
->parent
->left
;
2687 if (y
->color
== MEM_RED
)
2689 x
->parent
->color
= MEM_BLACK
;
2690 y
->color
= MEM_BLACK
;
2691 x
->parent
->parent
->color
= MEM_RED
;
2692 x
= x
->parent
->parent
;
2696 if (x
== x
->parent
->left
)
2699 mem_rotate_right (x
);
2702 x
->parent
->color
= MEM_BLACK
;
2703 x
->parent
->parent
->color
= MEM_RED
;
2704 mem_rotate_left (x
->parent
->parent
);
2709 /* The root may have been changed to red due to the algorithm. Set
2710 it to black so that property #5 is satisfied. */
2711 mem_root
->color
= MEM_BLACK
;
2727 /* Turn y's left sub-tree into x's right sub-tree. */
2730 if (y
->left
!= MEM_NIL
)
2731 y
->left
->parent
= x
;
2733 /* Y's parent was x's parent. */
2735 y
->parent
= x
->parent
;
2737 /* Get the parent to point to y instead of x. */
2740 if (x
== x
->parent
->left
)
2741 x
->parent
->left
= y
;
2743 x
->parent
->right
= y
;
2748 /* Put x on y's left. */
2762 mem_rotate_right (x
)
2765 struct mem_node
*y
= x
->left
;
2768 if (y
->right
!= MEM_NIL
)
2769 y
->right
->parent
= x
;
2772 y
->parent
= x
->parent
;
2775 if (x
== x
->parent
->right
)
2776 x
->parent
->right
= y
;
2778 x
->parent
->left
= y
;
2789 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
2795 struct mem_node
*x
, *y
;
2797 if (!z
|| z
== MEM_NIL
)
2800 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
2805 while (y
->left
!= MEM_NIL
)
2809 if (y
->left
!= MEM_NIL
)
2814 x
->parent
= y
->parent
;
2817 if (y
== y
->parent
->left
)
2818 y
->parent
->left
= x
;
2820 y
->parent
->right
= x
;
2827 z
->start
= y
->start
;
2832 if (y
->color
== MEM_BLACK
)
2833 mem_delete_fixup (x
);
2835 #ifdef GC_MALLOC_CHECK
2843 /* Re-establish the red-black properties of the tree, after a
2847 mem_delete_fixup (x
)
2850 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
2852 if (x
== x
->parent
->left
)
2854 struct mem_node
*w
= x
->parent
->right
;
2856 if (w
->color
== MEM_RED
)
2858 w
->color
= MEM_BLACK
;
2859 x
->parent
->color
= MEM_RED
;
2860 mem_rotate_left (x
->parent
);
2861 w
= x
->parent
->right
;
2864 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
2871 if (w
->right
->color
== MEM_BLACK
)
2873 w
->left
->color
= MEM_BLACK
;
2875 mem_rotate_right (w
);
2876 w
= x
->parent
->right
;
2878 w
->color
= x
->parent
->color
;
2879 x
->parent
->color
= MEM_BLACK
;
2880 w
->right
->color
= MEM_BLACK
;
2881 mem_rotate_left (x
->parent
);
2887 struct mem_node
*w
= x
->parent
->left
;
2889 if (w
->color
== MEM_RED
)
2891 w
->color
= MEM_BLACK
;
2892 x
->parent
->color
= MEM_RED
;
2893 mem_rotate_right (x
->parent
);
2894 w
= x
->parent
->left
;
2897 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
2904 if (w
->left
->color
== MEM_BLACK
)
2906 w
->right
->color
= MEM_BLACK
;
2908 mem_rotate_left (w
);
2909 w
= x
->parent
->left
;
2912 w
->color
= x
->parent
->color
;
2913 x
->parent
->color
= MEM_BLACK
;
2914 w
->left
->color
= MEM_BLACK
;
2915 mem_rotate_right (x
->parent
);
2921 x
->color
= MEM_BLACK
;
2925 /* Value is non-zero if P is a pointer to a live Lisp string on
2926 the heap. M is a pointer to the mem_block for P. */
2929 live_string_p (m
, p
)
2933 if (m
->type
== MEM_TYPE_STRING
)
2935 struct string_block
*b
= (struct string_block
*) m
->start
;
2936 int offset
= (char *) p
- (char *) &b
->strings
[0];
2938 /* P must point to the start of a Lisp_String structure, and it
2939 must not be on the free-list. */
2940 return (offset
% sizeof b
->strings
[0] == 0
2941 && ((struct Lisp_String
*) p
)->data
!= NULL
);
2948 /* Value is non-zero if P is a pointer to a live Lisp cons on
2949 the heap. M is a pointer to the mem_block for P. */
2956 if (m
->type
== MEM_TYPE_CONS
)
2958 struct cons_block
*b
= (struct cons_block
*) m
->start
;
2959 int offset
= (char *) p
- (char *) &b
->conses
[0];
2961 /* P must point to the start of a Lisp_Cons, not be
2962 one of the unused cells in the current cons block,
2963 and not be on the free-list. */
2964 return (offset
% sizeof b
->conses
[0] == 0
2966 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
2967 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
2974 /* Value is non-zero if P is a pointer to a live Lisp symbol on
2975 the heap. M is a pointer to the mem_block for P. */
2978 live_symbol_p (m
, p
)
2982 if (m
->type
== MEM_TYPE_SYMBOL
)
2984 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
2985 int offset
= (char *) p
- (char *) &b
->symbols
[0];
2987 /* P must point to the start of a Lisp_Symbol, not be
2988 one of the unused cells in the current symbol block,
2989 and not be on the free-list. */
2990 return (offset
% sizeof b
->symbols
[0] == 0
2991 && (b
!= symbol_block
2992 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
2993 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3000 /* Value is non-zero if P is a pointer to a live Lisp float on
3001 the heap. M is a pointer to the mem_block for P. */
3008 if (m
->type
== MEM_TYPE_FLOAT
)
3010 struct float_block
*b
= (struct float_block
*) m
->start
;
3011 int offset
= (char *) p
- (char *) &b
->floats
[0];
3013 /* P must point to the start of a Lisp_Float, not be
3014 one of the unused cells in the current float block,
3015 and not be on the free-list. */
3016 return (offset
% sizeof b
->floats
[0] == 0
3017 && (b
!= float_block
3018 || offset
/ sizeof b
->floats
[0] < float_block_index
)
3019 && !EQ (((struct Lisp_Float
*) p
)->type
, Vdead
));
3026 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3027 the heap. M is a pointer to the mem_block for P. */
3034 if (m
->type
== MEM_TYPE_MISC
)
3036 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3037 int offset
= (char *) p
- (char *) &b
->markers
[0];
3039 /* P must point to the start of a Lisp_Misc, not be
3040 one of the unused cells in the current misc block,
3041 and not be on the free-list. */
3042 return (offset
% sizeof b
->markers
[0] == 0
3043 && (b
!= marker_block
3044 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3045 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3052 /* Value is non-zero if P is a pointer to a live vector-like object.
3053 M is a pointer to the mem_block for P. */
3056 live_vector_p (m
, p
)
3060 return m
->type
== MEM_TYPE_VECTOR
&& p
== m
->start
;
3064 /* Value is non-zero of P is a pointer to a live buffer. M is a
3065 pointer to the mem_block for P. */
3068 live_buffer_p (m
, p
)
3072 /* P must point to the start of the block, and the buffer
3073 must not have been killed. */
3074 return (m
->type
== MEM_TYPE_BUFFER
3076 && !NILP (((struct buffer
*) p
)->name
));
3079 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3083 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3085 /* Array of objects that are kept alive because the C stack contains
3086 a pattern that looks like a reference to them . */
3088 #define MAX_ZOMBIES 10
3089 static Lisp_Object zombies
[MAX_ZOMBIES
];
3091 /* Number of zombie objects. */
3093 static int nzombies
;
3095 /* Number of garbage collections. */
3099 /* Average percentage of zombies per collection. */
3101 static double avg_zombies
;
3103 /* Max. number of live and zombie objects. */
3105 static int max_live
, max_zombies
;
3107 /* Average number of live objects per GC. */
3109 static double avg_live
;
3111 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3112 "Show information about live and zombie objects.")
3115 Lisp_Object args
[7];
3116 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d");
3117 args
[1] = make_number (ngcs
);
3118 args
[2] = make_float (avg_live
);
3119 args
[3] = make_float (avg_zombies
);
3120 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3121 args
[5] = make_number (max_live
);
3122 args
[6] = make_number (max_zombies
);
3123 return Fmessage (7, args
);
3126 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3129 /* Mark OBJ if we can prove it's a Lisp_Object. */
3132 mark_maybe_object (obj
)
3135 void *po
= (void *) XPNTR (obj
);
3136 struct mem_node
*m
= mem_find (po
);
3142 switch (XGCTYPE (obj
))
3145 mark_p
= (live_string_p (m
, po
)
3146 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3150 mark_p
= (live_cons_p (m
, po
)
3151 && !XMARKBIT (XCONS (obj
)->car
));
3155 mark_p
= (live_symbol_p (m
, po
)
3156 && !XMARKBIT (XSYMBOL (obj
)->plist
));
3160 mark_p
= (live_float_p (m
, po
)
3161 && !XMARKBIT (XFLOAT (obj
)->type
));
3164 case Lisp_Vectorlike
:
3165 /* Note: can't check GC_BUFFERP before we know it's a
3166 buffer because checking that dereferences the pointer
3167 PO which might point anywhere. */
3168 if (live_vector_p (m
, po
))
3169 mark_p
= (!GC_SUBRP (obj
)
3170 && !(XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
));
3171 else if (live_buffer_p (m
, po
))
3172 mark_p
= GC_BUFFERP (obj
) && !XMARKBIT (XBUFFER (obj
)->name
);
3176 if (live_misc_p (m
, po
))
3178 switch (XMISCTYPE (obj
))
3180 case Lisp_Misc_Marker
:
3181 mark_p
= !XMARKBIT (XMARKER (obj
)->chain
);
3184 case Lisp_Misc_Buffer_Local_Value
:
3185 case Lisp_Misc_Some_Buffer_Local_Value
:
3186 mark_p
= !XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
3189 case Lisp_Misc_Overlay
:
3190 mark_p
= !XMARKBIT (XOVERLAY (obj
)->plist
);
3197 case Lisp_Type_Limit
:
3203 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3204 if (nzombies
< MAX_ZOMBIES
)
3205 zombies
[nzombies
] = *p
;
3213 /* Mark Lisp objects in the address range START..END. */
3216 mark_memory (start
, end
)
3221 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3225 /* Make START the pointer to the start of the memory region,
3226 if it isn't already. */
3234 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3235 mark_maybe_object (*p
);
3239 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3241 static int setjmp_tested_p
, longjmps_done
;
3243 #define SETJMP_WILL_LIKELY_WORK "\
3245 Emacs garbage collector has been changed to use conservative stack\n\
3246 marking. Emacs has determined that the method it uses to do the\n\
3247 marking will likely work on your system, but this isn't sure.\n\
3249 If you are a system-programmer, or can get the help of a local wizard\n\
3250 who is, please take a look at the function mark_stack in alloc.c, and\n\
3251 verify that the methods used are appropriate for your system.\n\
3253 Please mail the result to <gerd@gnu.org>.\n\
3256 #define SETJMP_WILL_NOT_WORK "\
3258 Emacs garbage collector has been changed to use conservative stack\n\
3259 marking. Emacs has determined that the default method it uses to do the\n\
3260 marking will not work on your system. We will need a system-dependent\n\
3261 solution for your system.\n\
3263 Please take a look at the function mark_stack in alloc.c, and\n\
3264 try to find a way to make it work on your system.\n\
3265 Please mail the result to <gerd@gnu.org>.\n\
3269 /* Perform a quick check if it looks like setjmp saves registers in a
3270 jmp_buf. Print a message to stderr saying so. When this test
3271 succeeds, this is _not_ a proof that setjmp is sufficient for
3272 conservative stack marking. Only the sources or a disassembly
3283 /* Arrange for X to be put in a register. */
3289 if (longjmps_done
== 1)
3291 /* Came here after the longjmp at the end of the function.
3293 If x == 1, the longjmp has restored the register to its
3294 value before the setjmp, and we can hope that setjmp
3295 saves all such registers in the jmp_buf, although that
3298 For other values of X, either something really strange is
3299 taking place, or the setjmp just didn't save the register. */
3302 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3305 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3312 if (longjmps_done
== 1)
3316 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3319 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3321 /* Abort if anything GCPRO'd doesn't survive the GC. */
3329 for (p
= gcprolist
; p
; p
= p
->next
)
3330 for (i
= 0; i
< p
->nvars
; ++i
)
3331 if (!survives_gc_p (p
->var
[i
]))
3335 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3342 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3343 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3345 fprintf (stderr
, " %d = ", i
);
3346 debug_print (zombies
[i
]);
3350 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3353 /* Mark live Lisp objects on the C stack.
3355 There are several system-dependent problems to consider when
3356 porting this to new architectures:
3360 We have to mark Lisp objects in CPU registers that can hold local
3361 variables or are used to pass parameters.
3363 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3364 something that either saves relevant registers on the stack, or
3365 calls mark_maybe_object passing it each register's contents.
3367 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3368 implementation assumes that calling setjmp saves registers we need
3369 to see in a jmp_buf which itself lies on the stack. This doesn't
3370 have to be true! It must be verified for each system, possibly
3371 by taking a look at the source code of setjmp.
3375 Architectures differ in the way their processor stack is organized.
3376 For example, the stack might look like this
3379 | Lisp_Object | size = 4
3381 | something else | size = 2
3383 | Lisp_Object | size = 4
3387 In such a case, not every Lisp_Object will be aligned equally. To
3388 find all Lisp_Object on the stack it won't be sufficient to walk
3389 the stack in steps of 4 bytes. Instead, two passes will be
3390 necessary, one starting at the start of the stack, and a second
3391 pass starting at the start of the stack + 2. Likewise, if the
3392 minimal alignment of Lisp_Objects on the stack is 1, four passes
3393 would be necessary, each one starting with one byte more offset
3394 from the stack start.
3396 The current code assumes by default that Lisp_Objects are aligned
3397 equally on the stack. */
3403 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3406 /* This trick flushes the register windows so that all the state of
3407 the process is contained in the stack. */
3412 /* Save registers that we need to see on the stack. We need to see
3413 registers used to hold register variables and registers used to
3415 #ifdef GC_SAVE_REGISTERS_ON_STACK
3416 GC_SAVE_REGISTERS_ON_STACK (end
);
3417 #else /* not GC_SAVE_REGISTERS_ON_STACK */
3419 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
3420 setjmp will definitely work, test it
3421 and print a message with the result
3423 if (!setjmp_tested_p
)
3425 setjmp_tested_p
= 1;
3428 #endif /* GC_SETJMP_WORKS */
3431 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
3432 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
3434 /* This assumes that the stack is a contiguous region in memory. If
3435 that's not the case, something has to be done here to iterate
3436 over the stack segments. */
3437 #if GC_LISP_OBJECT_ALIGNMENT == 1
3438 mark_memory (stack_base
, end
);
3439 mark_memory ((char *) stack_base
+ 1, end
);
3440 mark_memory ((char *) stack_base
+ 2, end
);
3441 mark_memory ((char *) stack_base
+ 3, end
);
3442 #elif GC_LISP_OBJECT_ALIGNMENT == 2
3443 mark_memory (stack_base
, end
);
3444 mark_memory ((char *) stack_base
+ 2, end
);
3446 mark_memory (stack_base
, end
);
3449 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3455 #endif /* GC_MARK_STACK != 0 */
3459 /***********************************************************************
3460 Pure Storage Management
3461 ***********************************************************************/
3463 /* Allocate room for SIZE bytes from pure Lisp storage and return a
3464 pointer to it. TYPE is the Lisp type for which the memory is
3465 allocated. TYPE < 0 means it's not used for a Lisp object.
3467 If store_pure_type_info is set and TYPE is >= 0, the type of
3468 the allocated object is recorded in pure_types. */
3470 static POINTER_TYPE
*
3471 pure_alloc (size
, type
)
3476 POINTER_TYPE
*result
;
3477 char *beg
= PUREBEG
;
3479 /* Give Lisp_Floats an extra alignment. */
3480 if (type
== Lisp_Float
)
3483 #if defined __GNUC__ && __GNUC__ >= 2
3484 alignment
= __alignof (struct Lisp_Float
);
3486 alignment
= sizeof (struct Lisp_Float
);
3488 pure_bytes_used
= ALIGN (pure_bytes_used
, alignment
);
3491 nbytes
= ALIGN (size
, sizeof (EMACS_INT
));
3492 if (pure_bytes_used
+ nbytes
> PURESIZE
)
3493 error ("Pure Lisp storage exhausted");
3495 result
= (POINTER_TYPE
*) (beg
+ pure_bytes_used
);
3496 pure_bytes_used
+= nbytes
;
3501 /* Return a string allocated in pure space. DATA is a buffer holding
3502 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
3503 non-zero means make the result string multibyte.
3505 Must get an error if pure storage is full, since if it cannot hold
3506 a large string it may be able to hold conses that point to that
3507 string; then the string is not protected from gc. */
3510 make_pure_string (data
, nchars
, nbytes
, multibyte
)
3516 struct Lisp_String
*s
;
3518 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
3519 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
3521 s
->size_byte
= multibyte
? nbytes
: -1;
3522 bcopy (data
, s
->data
, nbytes
);
3523 s
->data
[nbytes
] = '\0';
3524 s
->intervals
= NULL_INTERVAL
;
3525 XSETSTRING (string
, s
);
3530 /* Return a cons allocated from pure space. Give it pure copies
3531 of CAR as car and CDR as cdr. */
3534 pure_cons (car
, cdr
)
3535 Lisp_Object car
, cdr
;
3537 register Lisp_Object
new;
3538 struct Lisp_Cons
*p
;
3540 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
3542 XCAR (new) = Fpurecopy (car
);
3543 XCDR (new) = Fpurecopy (cdr
);
3548 /* Value is a float object with value NUM allocated from pure space. */
3551 make_pure_float (num
)
3554 register Lisp_Object
new;
3555 struct Lisp_Float
*p
;
3557 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
3559 XFLOAT_DATA (new) = num
;
3564 /* Return a vector with room for LEN Lisp_Objects allocated from
3568 make_pure_vector (len
)
3572 struct Lisp_Vector
*p
;
3573 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
3575 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
3576 XSETVECTOR (new, p
);
3577 XVECTOR (new)->size
= len
;
3582 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
3583 "Make a copy of OBJECT in pure storage.\n\
3584 Recursively copies contents of vectors and cons cells.\n\
3585 Does not copy symbols. Copies strings without text properties.")
3587 register Lisp_Object obj
;
3589 if (NILP (Vpurify_flag
))
3592 if (PURE_POINTER_P (XPNTR (obj
)))
3596 return pure_cons (XCAR (obj
), XCDR (obj
));
3597 else if (FLOATP (obj
))
3598 return make_pure_float (XFLOAT_DATA (obj
));
3599 else if (STRINGP (obj
))
3600 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
3601 STRING_BYTES (XSTRING (obj
)),
3602 STRING_MULTIBYTE (obj
));
3603 else if (COMPILEDP (obj
) || VECTORP (obj
))
3605 register struct Lisp_Vector
*vec
;
3606 register int i
, size
;
3608 size
= XVECTOR (obj
)->size
;
3609 if (size
& PSEUDOVECTOR_FLAG
)
3610 size
&= PSEUDOVECTOR_SIZE_MASK
;
3611 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
3612 for (i
= 0; i
< size
; i
++)
3613 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
3614 if (COMPILEDP (obj
))
3615 XSETCOMPILED (obj
, vec
);
3617 XSETVECTOR (obj
, vec
);
3620 else if (MARKERP (obj
))
3621 error ("Attempt to copy a marker to pure storage");
3628 /***********************************************************************
3630 ***********************************************************************/
3632 /* Put an entry in staticvec, pointing at the variable with address
3636 staticpro (varaddress
)
3637 Lisp_Object
*varaddress
;
3639 staticvec
[staticidx
++] = varaddress
;
3640 if (staticidx
>= NSTATICS
)
3648 struct catchtag
*next
;
3653 struct backtrace
*next
;
3654 Lisp_Object
*function
;
3655 Lisp_Object
*args
; /* Points to vector of args. */
3656 int nargs
; /* Length of vector. */
3657 /* If nargs is UNEVALLED, args points to slot holding list of
3664 /***********************************************************************
3666 ***********************************************************************/
3668 /* Temporarily prevent garbage collection. */
3671 inhibit_garbage_collection ()
3673 int count
= specpdl_ptr
- specpdl
;
3675 int nbits
= min (VALBITS
, BITS_PER_INT
);
3677 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
3679 specbind (Qgc_cons_threshold
, number
);
3685 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
3686 "Reclaim storage for Lisp objects no longer needed.\n\
3687 Returns info on amount of space in use:\n\
3688 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
3689 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
3690 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS\n\
3691 (USED-STRINGS . FREE-STRINGS))\n\
3692 Garbage collection happens automatically if you cons more than\n\
3693 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
3696 register struct gcpro
*tail
;
3697 register struct specbinding
*bind
;
3698 struct catchtag
*catch;
3699 struct handler
*handler
;
3700 register struct backtrace
*backlist
;
3701 char stack_top_variable
;
3704 Lisp_Object total
[7];
3706 /* In case user calls debug_print during GC,
3707 don't let that cause a recursive GC. */
3708 consing_since_gc
= 0;
3710 /* Save what's currently displayed in the echo area. */
3711 message_p
= push_message ();
3713 /* Save a copy of the contents of the stack, for debugging. */
3714 #if MAX_SAVE_STACK > 0
3715 if (NILP (Vpurify_flag
))
3717 i
= &stack_top_variable
- stack_bottom
;
3719 if (i
< MAX_SAVE_STACK
)
3721 if (stack_copy
== 0)
3722 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
3723 else if (stack_copy_size
< i
)
3724 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
3727 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
3728 bcopy (stack_bottom
, stack_copy
, i
);
3730 bcopy (&stack_top_variable
, stack_copy
, i
);
3734 #endif /* MAX_SAVE_STACK > 0 */
3736 if (garbage_collection_messages
)
3737 message1_nolog ("Garbage collecting...");
3741 shrink_regexp_cache ();
3743 /* Don't keep undo information around forever. */
3745 register struct buffer
*nextb
= all_buffers
;
3749 /* If a buffer's undo list is Qt, that means that undo is
3750 turned off in that buffer. Calling truncate_undo_list on
3751 Qt tends to return NULL, which effectively turns undo back on.
3752 So don't call truncate_undo_list if undo_list is Qt. */
3753 if (! EQ (nextb
->undo_list
, Qt
))
3755 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
3757 nextb
= nextb
->next
;
3763 /* clear_marks (); */
3765 /* Mark all the special slots that serve as the roots of accessibility.
3767 Usually the special slots to mark are contained in particular structures.
3768 Then we know no slot is marked twice because the structures don't overlap.
3769 In some cases, the structures point to the slots to be marked.
3770 For these, we use MARKBIT to avoid double marking of the slot. */
3772 for (i
= 0; i
< staticidx
; i
++)
3773 mark_object (staticvec
[i
]);
3775 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
3776 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
3779 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3780 for (i
= 0; i
< tail
->nvars
; i
++)
3781 if (!XMARKBIT (tail
->var
[i
]))
3783 /* Explicit casting prevents compiler warning about
3784 discarding the `volatile' qualifier. */
3785 mark_object ((Lisp_Object
*)&tail
->var
[i
]);
3786 XMARK (tail
->var
[i
]);
3791 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
3793 mark_object (&bind
->symbol
);
3794 mark_object (&bind
->old_value
);
3796 for (catch = catchlist
; catch; catch = catch->next
)
3798 mark_object (&catch->tag
);
3799 mark_object (&catch->val
);
3801 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
3803 mark_object (&handler
->handler
);
3804 mark_object (&handler
->var
);
3806 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3808 if (!XMARKBIT (*backlist
->function
))
3810 mark_object (backlist
->function
);
3811 XMARK (*backlist
->function
);
3813 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3816 i
= backlist
->nargs
- 1;
3818 if (!XMARKBIT (backlist
->args
[i
]))
3820 mark_object (&backlist
->args
[i
]);
3821 XMARK (backlist
->args
[i
]);
3826 /* Look thru every buffer's undo list
3827 for elements that update markers that were not marked,
3830 register struct buffer
*nextb
= all_buffers
;
3834 /* If a buffer's undo list is Qt, that means that undo is
3835 turned off in that buffer. Calling truncate_undo_list on
3836 Qt tends to return NULL, which effectively turns undo back on.
3837 So don't call truncate_undo_list if undo_list is Qt. */
3838 if (! EQ (nextb
->undo_list
, Qt
))
3840 Lisp_Object tail
, prev
;
3841 tail
= nextb
->undo_list
;
3843 while (CONSP (tail
))
3845 if (GC_CONSP (XCAR (tail
))
3846 && GC_MARKERP (XCAR (XCAR (tail
)))
3847 && ! XMARKBIT (XMARKER (XCAR (XCAR (tail
)))->chain
))
3850 nextb
->undo_list
= tail
= XCDR (tail
);
3852 tail
= XCDR (prev
) = XCDR (tail
);
3862 nextb
= nextb
->next
;
3866 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3872 /* Clear the mark bits that we set in certain root slots. */
3874 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
3875 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
3876 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
3877 for (i
= 0; i
< tail
->nvars
; i
++)
3878 XUNMARK (tail
->var
[i
]);
3881 unmark_byte_stack ();
3882 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
3884 XUNMARK (*backlist
->function
);
3885 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
3888 i
= backlist
->nargs
- 1;
3890 XUNMARK (backlist
->args
[i
]);
3892 XUNMARK (buffer_defaults
.name
);
3893 XUNMARK (buffer_local_symbols
.name
);
3895 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
3901 /* clear_marks (); */
3904 consing_since_gc
= 0;
3905 if (gc_cons_threshold
< 10000)
3906 gc_cons_threshold
= 10000;
3908 if (garbage_collection_messages
)
3910 if (message_p
|| minibuf_level
> 0)
3913 message1_nolog ("Garbage collecting...done");
3918 total
[0] = Fcons (make_number (total_conses
),
3919 make_number (total_free_conses
));
3920 total
[1] = Fcons (make_number (total_symbols
),
3921 make_number (total_free_symbols
));
3922 total
[2] = Fcons (make_number (total_markers
),
3923 make_number (total_free_markers
));
3924 total
[3] = Fcons (make_number (total_string_size
),
3925 make_number (total_vector_size
));
3926 total
[4] = Fcons (make_number (total_floats
),
3927 make_number (total_free_floats
));
3928 total
[5] = Fcons (make_number (total_intervals
),
3929 make_number (total_free_intervals
));
3930 total
[6] = Fcons (make_number (total_strings
),
3931 make_number (total_free_strings
));
3933 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3935 /* Compute average percentage of zombies. */
3938 for (i
= 0; i
< 7; ++i
)
3939 nlive
+= XFASTINT (XCAR (total
[i
]));
3941 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
3942 max_live
= max (nlive
, max_live
);
3943 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
3944 max_zombies
= max (nzombies
, max_zombies
);
3949 return Flist (7, total
);
3953 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
3954 only interesting objects referenced from glyphs are strings. */
3957 mark_glyph_matrix (matrix
)
3958 struct glyph_matrix
*matrix
;
3960 struct glyph_row
*row
= matrix
->rows
;
3961 struct glyph_row
*end
= row
+ matrix
->nrows
;
3963 for (; row
< end
; ++row
)
3967 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
3969 struct glyph
*glyph
= row
->glyphs
[area
];
3970 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
3972 for (; glyph
< end_glyph
; ++glyph
)
3973 if (GC_STRINGP (glyph
->object
)
3974 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
3975 mark_object (&glyph
->object
);
3981 /* Mark Lisp faces in the face cache C. */
3985 struct face_cache
*c
;
3990 for (i
= 0; i
< c
->used
; ++i
)
3992 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
3996 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
3997 mark_object (&face
->lface
[j
]);
4004 #ifdef HAVE_WINDOW_SYSTEM
4006 /* Mark Lisp objects in image IMG. */
4012 mark_object (&img
->spec
);
4014 if (!NILP (img
->data
.lisp_val
))
4015 mark_object (&img
->data
.lisp_val
);
4019 /* Mark Lisp objects in image cache of frame F. It's done this way so
4020 that we don't have to include xterm.h here. */
4023 mark_image_cache (f
)
4026 forall_images_in_image_cache (f
, mark_image
);
4029 #endif /* HAVE_X_WINDOWS */
4033 /* Mark reference to a Lisp_Object.
4034 If the object referred to has not been seen yet, recursively mark
4035 all the references contained in it. */
4037 #define LAST_MARKED_SIZE 500
4038 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
4039 int last_marked_index
;
4042 mark_object (argptr
)
4043 Lisp_Object
*argptr
;
4045 Lisp_Object
*objptr
= argptr
;
4046 register Lisp_Object obj
;
4047 #ifdef GC_CHECK_MARKED_OBJECTS
4057 if (PURE_POINTER_P (XPNTR (obj
)))
4060 last_marked
[last_marked_index
++] = objptr
;
4061 if (last_marked_index
== LAST_MARKED_SIZE
)
4062 last_marked_index
= 0;
4064 /* Perform some sanity checks on the objects marked here. Abort if
4065 we encounter an object we know is bogus. This increases GC time
4066 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4067 #ifdef GC_CHECK_MARKED_OBJECTS
4069 po
= (void *) XPNTR (obj
);
4071 /* Check that the object pointed to by PO is known to be a Lisp
4072 structure allocated from the heap. */
4073 #define CHECK_ALLOCATED() \
4075 m = mem_find (po); \
4080 /* Check that the object pointed to by PO is live, using predicate
4082 #define CHECK_LIVE(LIVEP) \
4084 if (!LIVEP (m, po)) \
4088 /* Check both of the above conditions. */
4089 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4091 CHECK_ALLOCATED (); \
4092 CHECK_LIVE (LIVEP); \
4095 #else /* not GC_CHECK_MARKED_OBJECTS */
4097 #define CHECK_ALLOCATED() (void) 0
4098 #define CHECK_LIVE(LIVEP) (void) 0
4099 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4101 #endif /* not GC_CHECK_MARKED_OBJECTS */
4103 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4107 register struct Lisp_String
*ptr
= XSTRING (obj
);
4108 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4109 MARK_INTERVAL_TREE (ptr
->intervals
);
4111 #ifdef GC_CHECK_STRING_BYTES
4113 /* Check that the string size recorded in the string is the
4114 same as the one recorded in the sdata structure. */
4115 struct sdata
*p
= SDATA_OF_STRING (ptr
);
4116 if (GC_STRING_BYTES (ptr
) != SDATA_NBYTES (p
))
4119 #endif /* GC_CHECK_STRING_BYTES */
4123 case Lisp_Vectorlike
:
4124 #ifdef GC_CHECK_MARKED_OBJECTS
4126 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4127 && po
!= &buffer_defaults
4128 && po
!= &buffer_local_symbols
)
4130 #endif /* GC_CHECK_MARKED_OBJECTS */
4132 if (GC_BUFFERP (obj
))
4134 if (!XMARKBIT (XBUFFER (obj
)->name
))
4136 #ifdef GC_CHECK_MARKED_OBJECTS
4137 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4140 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4145 #endif /* GC_CHECK_MARKED_OBJECTS */
4149 else if (GC_SUBRP (obj
))
4151 else if (GC_COMPILEDP (obj
))
4152 /* We could treat this just like a vector, but it is better to
4153 save the COMPILED_CONSTANTS element for last and avoid
4156 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4157 register EMACS_INT size
= ptr
->size
;
4160 if (size
& ARRAY_MARK_FLAG
)
4161 break; /* Already marked */
4163 CHECK_LIVE (live_vector_p
);
4164 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4165 size
&= PSEUDOVECTOR_SIZE_MASK
;
4166 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4168 if (i
!= COMPILED_CONSTANTS
)
4169 mark_object (&ptr
->contents
[i
]);
4171 /* This cast should be unnecessary, but some Mips compiler complains
4172 (MIPS-ABI + SysVR4, DC/OSx, etc). */
4173 objptr
= (Lisp_Object
*) &ptr
->contents
[COMPILED_CONSTANTS
];
4176 else if (GC_FRAMEP (obj
))
4178 register struct frame
*ptr
= XFRAME (obj
);
4179 register EMACS_INT size
= ptr
->size
;
4181 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4182 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4184 CHECK_LIVE (live_vector_p
);
4185 mark_object (&ptr
->name
);
4186 mark_object (&ptr
->icon_name
);
4187 mark_object (&ptr
->title
);
4188 mark_object (&ptr
->focus_frame
);
4189 mark_object (&ptr
->selected_window
);
4190 mark_object (&ptr
->minibuffer_window
);
4191 mark_object (&ptr
->param_alist
);
4192 mark_object (&ptr
->scroll_bars
);
4193 mark_object (&ptr
->condemned_scroll_bars
);
4194 mark_object (&ptr
->menu_bar_items
);
4195 mark_object (&ptr
->face_alist
);
4196 mark_object (&ptr
->menu_bar_vector
);
4197 mark_object (&ptr
->buffer_predicate
);
4198 mark_object (&ptr
->buffer_list
);
4199 mark_object (&ptr
->menu_bar_window
);
4200 mark_object (&ptr
->tool_bar_window
);
4201 mark_face_cache (ptr
->face_cache
);
4202 #ifdef HAVE_WINDOW_SYSTEM
4203 mark_image_cache (ptr
);
4204 mark_object (&ptr
->desired_tool_bar_items
);
4205 mark_object (&ptr
->current_tool_bar_items
);
4206 mark_object (&ptr
->desired_tool_bar_string
);
4207 mark_object (&ptr
->current_tool_bar_string
);
4208 #endif /* HAVE_WINDOW_SYSTEM */
4210 else if (GC_BOOL_VECTOR_P (obj
))
4212 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4214 if (ptr
->size
& ARRAY_MARK_FLAG
)
4215 break; /* Already marked */
4216 CHECK_LIVE (live_vector_p
);
4217 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4219 else if (GC_WINDOWP (obj
))
4221 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4222 struct window
*w
= XWINDOW (obj
);
4223 register EMACS_INT size
= ptr
->size
;
4226 /* Stop if already marked. */
4227 if (size
& ARRAY_MARK_FLAG
)
4231 CHECK_LIVE (live_vector_p
);
4232 ptr
->size
|= ARRAY_MARK_FLAG
;
4234 /* There is no Lisp data above The member CURRENT_MATRIX in
4235 struct WINDOW. Stop marking when that slot is reached. */
4237 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4239 mark_object (&ptr
->contents
[i
]);
4241 /* Mark glyphs for leaf windows. Marking window matrices is
4242 sufficient because frame matrices use the same glyph
4244 if (NILP (w
->hchild
)
4246 && w
->current_matrix
)
4248 mark_glyph_matrix (w
->current_matrix
);
4249 mark_glyph_matrix (w
->desired_matrix
);
4252 else if (GC_HASH_TABLE_P (obj
))
4254 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4255 EMACS_INT size
= h
->size
;
4257 /* Stop if already marked. */
4258 if (size
& ARRAY_MARK_FLAG
)
4262 CHECK_LIVE (live_vector_p
);
4263 h
->size
|= ARRAY_MARK_FLAG
;
4265 /* Mark contents. */
4266 mark_object (&h
->test
);
4267 mark_object (&h
->weak
);
4268 mark_object (&h
->rehash_size
);
4269 mark_object (&h
->rehash_threshold
);
4270 mark_object (&h
->hash
);
4271 mark_object (&h
->next
);
4272 mark_object (&h
->index
);
4273 mark_object (&h
->user_hash_function
);
4274 mark_object (&h
->user_cmp_function
);
4276 /* If hash table is not weak, mark all keys and values.
4277 For weak tables, mark only the vector. */
4278 if (GC_NILP (h
->weak
))
4279 mark_object (&h
->key_and_value
);
4281 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
4286 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4287 register EMACS_INT size
= ptr
->size
;
4290 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
4291 CHECK_LIVE (live_vector_p
);
4292 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
4293 if (size
& PSEUDOVECTOR_FLAG
)
4294 size
&= PSEUDOVECTOR_SIZE_MASK
;
4296 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4297 mark_object (&ptr
->contents
[i
]);
4303 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4304 struct Lisp_Symbol
*ptrx
;
4306 if (XMARKBIT (ptr
->plist
)) break;
4307 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4309 mark_object ((Lisp_Object
*) &ptr
->value
);
4310 mark_object (&ptr
->function
);
4311 mark_object (&ptr
->plist
);
4313 if (!PURE_POINTER_P (ptr
->name
))
4314 MARK_STRING (ptr
->name
);
4315 MARK_INTERVAL_TREE (ptr
->name
->intervals
);
4317 /* Note that we do not mark the obarray of the symbol.
4318 It is safe not to do so because nothing accesses that
4319 slot except to check whether it is nil. */
4323 /* For the benefit of the last_marked log. */
4324 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
4325 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4326 XSETSYMBOL (obj
, ptrx
);
4327 /* We can't goto loop here because *objptr doesn't contain an
4328 actual Lisp_Object with valid datatype field. */
4335 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4336 switch (XMISCTYPE (obj
))
4338 case Lisp_Misc_Marker
:
4339 XMARK (XMARKER (obj
)->chain
);
4340 /* DO NOT mark thru the marker's chain.
4341 The buffer's markers chain does not preserve markers from gc;
4342 instead, markers are removed from the chain when freed by gc. */
4345 case Lisp_Misc_Buffer_Local_Value
:
4346 case Lisp_Misc_Some_Buffer_Local_Value
:
4348 register struct Lisp_Buffer_Local_Value
*ptr
4349 = XBUFFER_LOCAL_VALUE (obj
);
4350 if (XMARKBIT (ptr
->realvalue
)) break;
4351 XMARK (ptr
->realvalue
);
4352 /* If the cdr is nil, avoid recursion for the car. */
4353 if (EQ (ptr
->cdr
, Qnil
))
4355 objptr
= &ptr
->realvalue
;
4358 mark_object (&ptr
->realvalue
);
4359 mark_object (&ptr
->buffer
);
4360 mark_object (&ptr
->frame
);
4365 case Lisp_Misc_Intfwd
:
4366 case Lisp_Misc_Boolfwd
:
4367 case Lisp_Misc_Objfwd
:
4368 case Lisp_Misc_Buffer_Objfwd
:
4369 case Lisp_Misc_Kboard_Objfwd
:
4370 /* Don't bother with Lisp_Buffer_Objfwd,
4371 since all markable slots in current buffer marked anyway. */
4372 /* Don't need to do Lisp_Objfwd, since the places they point
4373 are protected with staticpro. */
4376 case Lisp_Misc_Overlay
:
4378 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
4379 if (!XMARKBIT (ptr
->plist
))
4382 mark_object (&ptr
->start
);
4383 mark_object (&ptr
->end
);
4384 objptr
= &ptr
->plist
;
4397 register struct Lisp_Cons
*ptr
= XCONS (obj
);
4398 if (XMARKBIT (ptr
->car
)) break;
4399 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
4401 /* If the cdr is nil, avoid recursion for the car. */
4402 if (EQ (ptr
->cdr
, Qnil
))
4407 mark_object (&ptr
->car
);
4413 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
4414 XMARK (XFLOAT (obj
)->type
);
4425 #undef CHECK_ALLOCATED
4426 #undef CHECK_ALLOCATED_AND_LIVE
4429 /* Mark the pointers in a buffer structure. */
4435 register struct buffer
*buffer
= XBUFFER (buf
);
4436 register Lisp_Object
*ptr
;
4437 Lisp_Object base_buffer
;
4439 /* This is the buffer's markbit */
4440 mark_object (&buffer
->name
);
4441 XMARK (buffer
->name
);
4443 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
4445 if (CONSP (buffer
->undo_list
))
4448 tail
= buffer
->undo_list
;
4450 while (CONSP (tail
))
4452 register struct Lisp_Cons
*ptr
= XCONS (tail
);
4454 if (XMARKBIT (ptr
->car
))
4457 if (GC_CONSP (ptr
->car
)
4458 && ! XMARKBIT (XCAR (ptr
->car
))
4459 && GC_MARKERP (XCAR (ptr
->car
)))
4461 XMARK (XCAR (ptr
->car
));
4462 mark_object (&XCDR (ptr
->car
));
4465 mark_object (&ptr
->car
);
4467 if (CONSP (ptr
->cdr
))
4473 mark_object (&XCDR (tail
));
4476 mark_object (&buffer
->undo_list
);
4478 for (ptr
= &buffer
->name
+ 1;
4479 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
4483 /* If this is an indirect buffer, mark its base buffer. */
4484 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
4486 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
4487 mark_buffer (base_buffer
);
4492 /* Mark the pointers in the kboard objects. */
4499 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
4501 if (kb
->kbd_macro_buffer
)
4502 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
4504 mark_object (&kb
->Voverriding_terminal_local_map
);
4505 mark_object (&kb
->Vlast_command
);
4506 mark_object (&kb
->Vreal_last_command
);
4507 mark_object (&kb
->Vprefix_arg
);
4508 mark_object (&kb
->Vlast_prefix_arg
);
4509 mark_object (&kb
->kbd_queue
);
4510 mark_object (&kb
->defining_kbd_macro
);
4511 mark_object (&kb
->Vlast_kbd_macro
);
4512 mark_object (&kb
->Vsystem_key_alist
);
4513 mark_object (&kb
->system_key_syms
);
4514 mark_object (&kb
->Vdefault_minibuffer_frame
);
4519 /* Value is non-zero if OBJ will survive the current GC because it's
4520 either marked or does not need to be marked to survive. */
4528 switch (XGCTYPE (obj
))
4535 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
4539 switch (XMISCTYPE (obj
))
4541 case Lisp_Misc_Marker
:
4542 survives_p
= XMARKBIT (obj
);
4545 case Lisp_Misc_Buffer_Local_Value
:
4546 case Lisp_Misc_Some_Buffer_Local_Value
:
4547 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
4550 case Lisp_Misc_Intfwd
:
4551 case Lisp_Misc_Boolfwd
:
4552 case Lisp_Misc_Objfwd
:
4553 case Lisp_Misc_Buffer_Objfwd
:
4554 case Lisp_Misc_Kboard_Objfwd
:
4558 case Lisp_Misc_Overlay
:
4559 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
4569 struct Lisp_String
*s
= XSTRING (obj
);
4570 survives_p
= STRING_MARKED_P (s
);
4574 case Lisp_Vectorlike
:
4575 if (GC_BUFFERP (obj
))
4576 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
4577 else if (GC_SUBRP (obj
))
4580 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
4584 survives_p
= XMARKBIT (XCAR (obj
));
4588 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
4595 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
4600 /* Sweep: find all structures not marked, and free them. */
4605 /* Remove or mark entries in weak hash tables.
4606 This must be done before any object is unmarked. */
4607 sweep_weak_hash_tables ();
4611 /* Put all unmarked conses on free list */
4613 register struct cons_block
*cblk
;
4614 struct cons_block
**cprev
= &cons_block
;
4615 register int lim
= cons_block_index
;
4616 register int num_free
= 0, num_used
= 0;
4620 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
4624 for (i
= 0; i
< lim
; i
++)
4625 if (!XMARKBIT (cblk
->conses
[i
].car
))
4628 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
4629 cons_free_list
= &cblk
->conses
[i
];
4631 cons_free_list
->car
= Vdead
;
4637 XUNMARK (cblk
->conses
[i
].car
);
4639 lim
= CONS_BLOCK_SIZE
;
4640 /* If this block contains only free conses and we have already
4641 seen more than two blocks worth of free conses then deallocate
4643 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
4645 *cprev
= cblk
->next
;
4646 /* Unhook from the free list. */
4647 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
4653 num_free
+= this_free
;
4654 cprev
= &cblk
->next
;
4657 total_conses
= num_used
;
4658 total_free_conses
= num_free
;
4661 /* Put all unmarked floats on free list */
4663 register struct float_block
*fblk
;
4664 struct float_block
**fprev
= &float_block
;
4665 register int lim
= float_block_index
;
4666 register int num_free
= 0, num_used
= 0;
4668 float_free_list
= 0;
4670 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
4674 for (i
= 0; i
< lim
; i
++)
4675 if (!XMARKBIT (fblk
->floats
[i
].type
))
4678 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
4679 float_free_list
= &fblk
->floats
[i
];
4681 float_free_list
->type
= Vdead
;
4687 XUNMARK (fblk
->floats
[i
].type
);
4689 lim
= FLOAT_BLOCK_SIZE
;
4690 /* If this block contains only free floats and we have already
4691 seen more than two blocks worth of free floats then deallocate
4693 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
4695 *fprev
= fblk
->next
;
4696 /* Unhook from the free list. */
4697 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
4703 num_free
+= this_free
;
4704 fprev
= &fblk
->next
;
4707 total_floats
= num_used
;
4708 total_free_floats
= num_free
;
4711 /* Put all unmarked intervals on free list */
4713 register struct interval_block
*iblk
;
4714 struct interval_block
**iprev
= &interval_block
;
4715 register int lim
= interval_block_index
;
4716 register int num_free
= 0, num_used
= 0;
4718 interval_free_list
= 0;
4720 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
4725 for (i
= 0; i
< lim
; i
++)
4727 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
4729 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
4730 interval_free_list
= &iblk
->intervals
[i
];
4736 XUNMARK (iblk
->intervals
[i
].plist
);
4739 lim
= INTERVAL_BLOCK_SIZE
;
4740 /* If this block contains only free intervals and we have already
4741 seen more than two blocks worth of free intervals then
4742 deallocate this block. */
4743 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
4745 *iprev
= iblk
->next
;
4746 /* Unhook from the free list. */
4747 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
4749 n_interval_blocks
--;
4753 num_free
+= this_free
;
4754 iprev
= &iblk
->next
;
4757 total_intervals
= num_used
;
4758 total_free_intervals
= num_free
;
4761 /* Put all unmarked symbols on free list */
4763 register struct symbol_block
*sblk
;
4764 struct symbol_block
**sprev
= &symbol_block
;
4765 register int lim
= symbol_block_index
;
4766 register int num_free
= 0, num_used
= 0;
4768 symbol_free_list
= 0;
4770 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
4774 for (i
= 0; i
< lim
; i
++)
4775 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
4777 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
4778 symbol_free_list
= &sblk
->symbols
[i
];
4780 symbol_free_list
->function
= Vdead
;
4787 if (!PURE_POINTER_P (sblk
->symbols
[i
].name
))
4788 UNMARK_STRING (sblk
->symbols
[i
].name
);
4789 XUNMARK (sblk
->symbols
[i
].plist
);
4791 lim
= SYMBOL_BLOCK_SIZE
;
4792 /* If this block contains only free symbols and we have already
4793 seen more than two blocks worth of free symbols then deallocate
4795 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
4797 *sprev
= sblk
->next
;
4798 /* Unhook from the free list. */
4799 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
4805 num_free
+= this_free
;
4806 sprev
= &sblk
->next
;
4809 total_symbols
= num_used
;
4810 total_free_symbols
= num_free
;
4813 /* Put all unmarked misc's on free list.
4814 For a marker, first unchain it from the buffer it points into. */
4816 register struct marker_block
*mblk
;
4817 struct marker_block
**mprev
= &marker_block
;
4818 register int lim
= marker_block_index
;
4819 register int num_free
= 0, num_used
= 0;
4821 marker_free_list
= 0;
4823 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
4827 EMACS_INT already_free
= -1;
4829 for (i
= 0; i
< lim
; i
++)
4831 Lisp_Object
*markword
;
4832 switch (mblk
->markers
[i
].u_marker
.type
)
4834 case Lisp_Misc_Marker
:
4835 markword
= &mblk
->markers
[i
].u_marker
.chain
;
4837 case Lisp_Misc_Buffer_Local_Value
:
4838 case Lisp_Misc_Some_Buffer_Local_Value
:
4839 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
4841 case Lisp_Misc_Overlay
:
4842 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
4844 case Lisp_Misc_Free
:
4845 /* If the object was already free, keep it
4846 on the free list. */
4847 markword
= (Lisp_Object
*) &already_free
;
4853 if (markword
&& !XMARKBIT (*markword
))
4856 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
4858 /* tem1 avoids Sun compiler bug */
4859 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
4860 XSETMARKER (tem
, tem1
);
4861 unchain_marker (tem
);
4863 /* Set the type of the freed object to Lisp_Misc_Free.
4864 We could leave the type alone, since nobody checks it,
4865 but this might catch bugs faster. */
4866 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
4867 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
4868 marker_free_list
= &mblk
->markers
[i
];
4875 XUNMARK (*markword
);
4878 lim
= MARKER_BLOCK_SIZE
;
4879 /* If this block contains only free markers and we have already
4880 seen more than two blocks worth of free markers then deallocate
4882 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
4884 *mprev
= mblk
->next
;
4885 /* Unhook from the free list. */
4886 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
4892 num_free
+= this_free
;
4893 mprev
= &mblk
->next
;
4897 total_markers
= num_used
;
4898 total_free_markers
= num_free
;
4901 /* Free all unmarked buffers */
4903 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
4906 if (!XMARKBIT (buffer
->name
))
4909 prev
->next
= buffer
->next
;
4911 all_buffers
= buffer
->next
;
4912 next
= buffer
->next
;
4918 XUNMARK (buffer
->name
);
4919 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
4920 prev
= buffer
, buffer
= buffer
->next
;
4924 /* Free all unmarked vectors */
4926 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
4927 total_vector_size
= 0;
4930 if (!(vector
->size
& ARRAY_MARK_FLAG
))
4933 prev
->next
= vector
->next
;
4935 all_vectors
= vector
->next
;
4936 next
= vector
->next
;
4944 vector
->size
&= ~ARRAY_MARK_FLAG
;
4945 if (vector
->size
& PSEUDOVECTOR_FLAG
)
4946 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
4948 total_vector_size
+= vector
->size
;
4949 prev
= vector
, vector
= vector
->next
;
4957 /* Debugging aids. */
4959 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
4960 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
4961 This may be helpful in debugging Emacs's memory usage.\n\
4962 We divide the value by 1024 to make sure it fits in a Lisp integer.")
4967 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
4972 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
4973 "Return a list of counters that measure how much consing there has been.\n\
4974 Each of these counters increments for a certain kind of object.\n\
4975 The counters wrap around from the largest positive integer to zero.\n\
4976 Garbage collection does not decrease them.\n\
4977 The elements of the value are as follows:\n\
4978 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)\n\
4979 All are in units of 1 = one object consed\n\
4980 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
4982 MISCS include overlays, markers, and some internal types.\n\
4983 Frames, windows, buffers, and subprocesses count as vectors\n\
4984 (but the contents of a buffer's text do not count here).")
4987 Lisp_Object consed
[8];
4990 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4992 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4994 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4996 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
4998 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5000 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5002 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5004 strings_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
5006 return Flist (8, consed
);
5009 int suppress_checking
;
5011 die (msg
, file
, line
)
5016 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5021 /* Initialization */
5026 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5027 pure_bytes_used
= 0;
5028 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5030 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5033 pure_size
= PURESIZE
;
5036 ignore_warnings
= 1;
5037 #ifdef DOUG_LEA_MALLOC
5038 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5039 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5040 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5050 malloc_hysteresis
= 32;
5052 malloc_hysteresis
= 0;
5055 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5057 ignore_warnings
= 0;
5059 byte_stack_list
= 0;
5061 consing_since_gc
= 0;
5062 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5063 #ifdef VIRT_ADDR_VARIES
5064 malloc_sbrk_unused
= 1<<22; /* A large number */
5065 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5066 #endif /* VIRT_ADDR_VARIES */
5073 byte_stack_list
= 0;
5075 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5076 setjmp_tested_p
= longjmps_done
= 0;
5084 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5085 "*Number of bytes of consing between garbage collections.\n\
5086 Garbage collection can happen automatically once this many bytes have been\n\
5087 allocated since the last garbage collection. All data types count.\n\n\
5088 Garbage collection happens automatically only when `eval' is called.\n\n\
5089 By binding this temporarily to a large number, you can effectively\n\
5090 prevent garbage collection during a part of the program.");
5092 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5093 "Number of bytes of sharable Lisp data allocated so far.");
5095 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5096 "Number of cons cells that have been consed so far.");
5098 DEFVAR_INT ("floats-consed", &floats_consed
,
5099 "Number of floats that have been consed so far.");
5101 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5102 "Number of vector cells that have been consed so far.");
5104 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5105 "Number of symbols that have been consed so far.");
5107 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5108 "Number of string characters that have been consed so far.");
5110 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5111 "Number of miscellaneous objects that have been consed so far.");
5113 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5114 "Number of intervals that have been consed so far.");
5116 DEFVAR_INT ("strings-consed", &strings_consed
,
5117 "Number of strings that have been consed so far.");
5119 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5120 "Non-nil means loading Lisp code in order to dump an executable.\n\
5121 This means that certain objects should be allocated in shared (pure) space.");
5123 DEFVAR_INT ("undo-limit", &undo_limit
,
5124 "Keep no more undo information once it exceeds this size.\n\
5125 This limit is applied when garbage collection happens.\n\
5126 The size is counted as the number of bytes occupied,\n\
5127 which includes both saved text and other data.");
5130 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5131 "Don't keep more than this much size of undo information.\n\
5132 A command which pushes past this size is itself forgotten.\n\
5133 This limit is applied when garbage collection happens.\n\
5134 The size is counted as the number of bytes occupied,\n\
5135 which includes both saved text and other data.");
5136 undo_strong_limit
= 30000;
5138 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5139 "Non-nil means display messages at start and end of garbage collection.");
5140 garbage_collection_messages
= 0;
5142 /* We build this in advance because if we wait until we need it, we might
5143 not be able to allocate the memory to hold it. */
5145 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
5146 staticpro (&memory_signal_data
);
5148 staticpro (&Qgc_cons_threshold
);
5149 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5151 staticpro (&Qchar_table_extra_slots
);
5152 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5157 defsubr (&Smake_byte_code
);
5158 defsubr (&Smake_list
);
5159 defsubr (&Smake_vector
);
5160 defsubr (&Smake_char_table
);
5161 defsubr (&Smake_string
);
5162 defsubr (&Smake_bool_vector
);
5163 defsubr (&Smake_symbol
);
5164 defsubr (&Smake_marker
);
5165 defsubr (&Spurecopy
);
5166 defsubr (&Sgarbage_collect
);
5167 defsubr (&Smemory_limit
);
5168 defsubr (&Smemory_use_counts
);
5170 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5171 defsubr (&Sgc_status
);