1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
3 2000, 2001, 2002, 2003, 2004 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. */
24 #include <limits.h> /* For CHAR_BIT. */
30 /* Note that this declares bzero on OSF/1. How dumb. */
34 /* This file is part of the core Lisp implementation, and thus must
35 deal with the real data structures. If the Lisp implementation is
36 replaced, this file likely will not be used. */
38 #undef HIDE_LISP_IMPLEMENTATION
41 #include "intervals.h"
47 #include "blockinput.h"
49 #include "syssignal.h"
52 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
53 memory. Can do this only if using gmalloc.c. */
55 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
56 #undef GC_MALLOC_CHECK
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 /* Value of _bytes_used, when spare_memory was freed. */
90 static __malloc_size_t bytes_used_when_full
;
92 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
93 to a struct Lisp_String. */
95 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
96 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
97 #define STRING_MARKED_P(S) ((S)->size & ARRAY_MARK_FLAG)
99 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
100 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
101 #define VECTOR_MARKED_P(V) ((V)->size & ARRAY_MARK_FLAG)
103 /* Value is the number of bytes/chars of S, a pointer to a struct
104 Lisp_String. This must be used instead of STRING_BYTES (S) or
105 S->size during GC, because S->size contains the mark bit for
108 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
109 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
111 /* Number of bytes of consing done since the last gc. */
113 int consing_since_gc
;
115 /* Count the amount of consing of various sorts of space. */
117 EMACS_INT cons_cells_consed
;
118 EMACS_INT floats_consed
;
119 EMACS_INT vector_cells_consed
;
120 EMACS_INT symbols_consed
;
121 EMACS_INT string_chars_consed
;
122 EMACS_INT misc_objects_consed
;
123 EMACS_INT intervals_consed
;
124 EMACS_INT strings_consed
;
126 /* Number of bytes of consing since GC before another GC should be done. */
128 EMACS_INT gc_cons_threshold
;
130 /* Nonzero during GC. */
134 /* Nonzero means abort if try to GC.
135 This is for code which is written on the assumption that
136 no GC will happen, so as to verify that assumption. */
140 /* Nonzero means display messages at beginning and end of GC. */
142 int garbage_collection_messages
;
144 #ifndef VIRT_ADDR_VARIES
146 #endif /* VIRT_ADDR_VARIES */
147 int malloc_sbrk_used
;
149 #ifndef VIRT_ADDR_VARIES
151 #endif /* VIRT_ADDR_VARIES */
152 int malloc_sbrk_unused
;
154 /* Two limits controlling how much undo information to keep. */
156 EMACS_INT undo_limit
;
157 EMACS_INT undo_strong_limit
;
158 EMACS_INT undo_outer_limit
;
160 /* Number of live and free conses etc. */
162 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
163 static int total_free_conses
, total_free_markers
, total_free_symbols
;
164 static int total_free_floats
, total_floats
;
166 /* Points to memory space allocated as "spare", to be freed if we run
169 static char *spare_memory
;
171 /* Amount of spare memory to keep in reserve. */
173 #define SPARE_MEMORY (1 << 14)
175 /* Number of extra blocks malloc should get when it needs more core. */
177 static int malloc_hysteresis
;
179 /* Non-nil means defun should do purecopy on the function definition. */
181 Lisp_Object Vpurify_flag
;
183 /* Non-nil means we are handling a memory-full error. */
185 Lisp_Object Vmemory_full
;
189 /* Initialize it to a nonzero value to force it into data space
190 (rather than bss space). That way unexec will remap it into text
191 space (pure), on some systems. We have not implemented the
192 remapping on more recent systems because this is less important
193 nowadays than in the days of small memories and timesharing. */
195 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {1,};
196 #define PUREBEG (char *) pure
200 #define pure PURE_SEG_BITS /* Use shared memory segment */
201 #define PUREBEG (char *)PURE_SEG_BITS
203 #endif /* HAVE_SHM */
205 /* Pointer to the pure area, and its size. */
207 static char *purebeg
;
208 static size_t pure_size
;
210 /* Number of bytes of pure storage used before pure storage overflowed.
211 If this is non-zero, this implies that an overflow occurred. */
213 static size_t pure_bytes_used_before_overflow
;
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 *) purebeg + pure_size)) \
220 && ((PNTR_COMPARISON_TYPE) (P) \
221 >= (PNTR_COMPARISON_TYPE) purebeg))
223 /* Index in pure at which next pure object will be allocated.. */
225 EMACS_INT pure_bytes_used
;
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 Vmemory_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 /* Hook run after GC has finished. */
256 Lisp_Object Vpost_gc_hook
, Qpost_gc_hook
;
258 Lisp_Object Vgc_elapsed
; /* accumulated elapsed time in GC */
259 EMACS_INT gcs_done
; /* accumulated GCs */
261 static void mark_buffer
P_ ((Lisp_Object
));
262 extern void mark_kboards
P_ ((void));
263 extern void mark_ttys
P_ ((void));
264 extern void mark_backtrace
P_ ((void));
265 static void gc_sweep
P_ ((void));
266 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
267 static void mark_face_cache
P_ ((struct face_cache
*));
269 #ifdef HAVE_WINDOW_SYSTEM
270 static void mark_image
P_ ((struct image
*));
271 static void mark_image_cache
P_ ((struct frame
*));
272 #endif /* HAVE_WINDOW_SYSTEM */
274 static struct Lisp_String
*allocate_string
P_ ((void));
275 static void compact_small_strings
P_ ((void));
276 static void free_large_strings
P_ ((void));
277 static void sweep_strings
P_ ((void));
279 extern int message_enable_multibyte
;
281 /* When scanning the C stack for live Lisp objects, Emacs keeps track
282 of what memory allocated via lisp_malloc is intended for what
283 purpose. This enumeration specifies the type of memory. */
294 /* Keep the following vector-like types together, with
295 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
296 first. Or change the code of live_vector_p, for instance. */
304 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
306 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
307 #include <stdio.h> /* For fprintf. */
310 /* A unique object in pure space used to make some Lisp objects
311 on free lists recognizable in O(1). */
315 #ifdef GC_MALLOC_CHECK
317 enum mem_type allocated_mem_type
;
318 int dont_register_blocks
;
320 #endif /* GC_MALLOC_CHECK */
322 /* A node in the red-black tree describing allocated memory containing
323 Lisp data. Each such block is recorded with its start and end
324 address when it is allocated, and removed from the tree when it
327 A red-black tree is a balanced binary tree with the following
330 1. Every node is either red or black.
331 2. Every leaf is black.
332 3. If a node is red, then both of its children are black.
333 4. Every simple path from a node to a descendant leaf contains
334 the same number of black nodes.
335 5. The root is always black.
337 When nodes are inserted into the tree, or deleted from the tree,
338 the tree is "fixed" so that these properties are always true.
340 A red-black tree with N internal nodes has height at most 2
341 log(N+1). Searches, insertions and deletions are done in O(log N).
342 Please see a text book about data structures for a detailed
343 description of red-black trees. Any book worth its salt should
348 /* Children of this node. These pointers are never NULL. When there
349 is no child, the value is MEM_NIL, which points to a dummy node. */
350 struct mem_node
*left
, *right
;
352 /* The parent of this node. In the root node, this is NULL. */
353 struct mem_node
*parent
;
355 /* Start and end of allocated region. */
359 enum {MEM_BLACK
, MEM_RED
} color
;
365 /* Base address of stack. Set in main. */
367 Lisp_Object
*stack_base
;
369 /* Root of the tree describing allocated Lisp memory. */
371 static struct mem_node
*mem_root
;
373 /* Lowest and highest known address in the heap. */
375 static void *min_heap_address
, *max_heap_address
;
377 /* Sentinel node of the tree. */
379 static struct mem_node mem_z
;
380 #define MEM_NIL &mem_z
382 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
383 static struct Lisp_Vector
*allocate_vectorlike
P_ ((EMACS_INT
, enum mem_type
));
384 static void lisp_free
P_ ((POINTER_TYPE
*));
385 static void mark_stack
P_ ((void));
386 static int live_vector_p
P_ ((struct mem_node
*, void *));
387 static int live_buffer_p
P_ ((struct mem_node
*, void *));
388 static int live_string_p
P_ ((struct mem_node
*, void *));
389 static int live_cons_p
P_ ((struct mem_node
*, void *));
390 static int live_symbol_p
P_ ((struct mem_node
*, void *));
391 static int live_float_p
P_ ((struct mem_node
*, void *));
392 static int live_misc_p
P_ ((struct mem_node
*, void *));
393 static void mark_maybe_object
P_ ((Lisp_Object
));
394 static void mark_memory
P_ ((void *, void *));
395 static void mem_init
P_ ((void));
396 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
397 static void mem_insert_fixup
P_ ((struct mem_node
*));
398 static void mem_rotate_left
P_ ((struct mem_node
*));
399 static void mem_rotate_right
P_ ((struct mem_node
*));
400 static void mem_delete
P_ ((struct mem_node
*));
401 static void mem_delete_fixup
P_ ((struct mem_node
*));
402 static INLINE
struct mem_node
*mem_find
P_ ((void *));
404 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
405 static void check_gcpros
P_ ((void));
408 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
410 /* Recording what needs to be marked for gc. */
412 struct gcpro
*gcprolist
;
414 /* Addresses of staticpro'd variables. Initialize it to a nonzero
415 value; otherwise some compilers put it into BSS. */
417 #define NSTATICS 1280
418 Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
420 /* Index of next unused slot in staticvec. */
424 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
427 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
428 ALIGNMENT must be a power of 2. */
430 #define ALIGN(ptr, ALIGNMENT) \
431 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
432 & ~((ALIGNMENT) - 1)))
436 /************************************************************************
438 ************************************************************************/
440 /* Function malloc calls this if it finds we are near exhausting storage. */
446 pending_malloc_warning
= str
;
450 /* Display an already-pending malloc warning. */
453 display_malloc_warning ()
455 call3 (intern ("display-warning"),
457 build_string (pending_malloc_warning
),
458 intern ("emergency"));
459 pending_malloc_warning
= 0;
463 #ifdef DOUG_LEA_MALLOC
464 # define BYTES_USED (mallinfo ().arena)
466 # define BYTES_USED _bytes_used
470 /* Called if malloc returns zero. */
477 #ifndef SYSTEM_MALLOC
478 bytes_used_when_full
= BYTES_USED
;
481 /* The first time we get here, free the spare memory. */
488 /* This used to call error, but if we've run out of memory, we could
489 get infinite recursion trying to build the string. */
491 Fsignal (Qnil
, Vmemory_signal_data
);
495 /* Called if we can't allocate relocatable space for a buffer. */
498 buffer_memory_full ()
500 /* If buffers use the relocating allocator, no need to free
501 spare_memory, because we may have plenty of malloc space left
502 that we could get, and if we don't, the malloc that fails will
503 itself cause spare_memory to be freed. If buffers don't use the
504 relocating allocator, treat this like any other failing
513 /* This used to call error, but if we've run out of memory, we could
514 get infinite recursion trying to build the string. */
516 Fsignal (Qnil
, Vmemory_signal_data
);
520 /* Like malloc but check for no memory and block interrupt input.. */
526 register POINTER_TYPE
*val
;
529 val
= (POINTER_TYPE
*) malloc (size
);
538 /* Like realloc but check for no memory and block interrupt input.. */
541 xrealloc (block
, size
)
545 register POINTER_TYPE
*val
;
548 /* We must call malloc explicitly when BLOCK is 0, since some
549 reallocs don't do this. */
551 val
= (POINTER_TYPE
*) malloc (size
);
553 val
= (POINTER_TYPE
*) realloc (block
, size
);
556 if (!val
&& size
) memory_full ();
561 /* Like free but block interrupt input. */
573 /* Like strdup, but uses xmalloc. */
579 size_t len
= strlen (s
) + 1;
580 char *p
= (char *) xmalloc (len
);
586 /* Unwind for SAFE_ALLOCA */
589 safe_alloca_unwind (arg
)
592 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
602 /* Like malloc but used for allocating Lisp data. NBYTES is the
603 number of bytes to allocate, TYPE describes the intended use of the
604 allcated memory block (for strings, for conses, ...). */
606 static void *lisp_malloc_loser
;
608 static POINTER_TYPE
*
609 lisp_malloc (nbytes
, type
)
617 #ifdef GC_MALLOC_CHECK
618 allocated_mem_type
= type
;
621 val
= (void *) malloc (nbytes
);
624 /* If the memory just allocated cannot be addressed thru a Lisp
625 object's pointer, and it needs to be,
626 that's equivalent to running out of memory. */
627 if (val
&& type
!= MEM_TYPE_NON_LISP
)
630 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
631 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
633 lisp_malloc_loser
= val
;
640 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
641 if (val
&& type
!= MEM_TYPE_NON_LISP
)
642 mem_insert (val
, (char *) val
+ nbytes
, type
);
651 /* Free BLOCK. This must be called to free memory allocated with a
652 call to lisp_malloc. */
660 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
661 mem_delete (mem_find (block
));
666 /* Allocation of aligned blocks of memory to store Lisp data. */
667 /* The entry point is lisp_align_malloc which returns blocks of at most */
668 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
671 /* BLOCK_ALIGN has to be a power of 2. */
672 #define BLOCK_ALIGN (1 << 10)
674 /* Padding to leave at the end of a malloc'd block. This is to give
675 malloc a chance to minimize the amount of memory wasted to alignment.
676 It should be tuned to the particular malloc library used.
677 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
678 posix_memalign on the other hand would ideally prefer a value of 4
679 because otherwise, there's 1020 bytes wasted between each ablocks.
680 But testing shows that those 1020 will most of the time be efficiently
681 used by malloc to place other objects, so a value of 0 is still preferable
682 unless you have a lot of cons&floats and virtually nothing else. */
683 #define BLOCK_PADDING 0
684 #define BLOCK_BYTES \
685 (BLOCK_ALIGN - sizeof (struct aligned_block *) - BLOCK_PADDING)
687 /* Internal data structures and constants. */
689 #define ABLOCKS_SIZE 16
691 /* An aligned block of memory. */
696 char payload
[BLOCK_BYTES
];
697 struct ablock
*next_free
;
699 /* `abase' is the aligned base of the ablocks. */
700 /* It is overloaded to hold the virtual `busy' field that counts
701 the number of used ablock in the parent ablocks.
702 The first ablock has the `busy' field, the others have the `abase'
703 field. To tell the difference, we assume that pointers will have
704 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
705 is used to tell whether the real base of the parent ablocks is `abase'
706 (if not, the word before the first ablock holds a pointer to the
708 struct ablocks
*abase
;
709 /* The padding of all but the last ablock is unused. The padding of
710 the last ablock in an ablocks is not allocated. */
712 char padding
[BLOCK_PADDING
];
716 /* A bunch of consecutive aligned blocks. */
719 struct ablock blocks
[ABLOCKS_SIZE
];
722 /* Size of the block requested from malloc or memalign. */
723 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
725 #define ABLOCK_ABASE(block) \
726 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
727 ? (struct ablocks *)(block) \
730 /* Virtual `busy' field. */
731 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
733 /* Pointer to the (not necessarily aligned) malloc block. */
734 #ifdef HAVE_POSIX_MEMALIGN
735 #define ABLOCKS_BASE(abase) (abase)
737 #define ABLOCKS_BASE(abase) \
738 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
741 /* The list of free ablock. */
742 static struct ablock
*free_ablock
;
744 /* Allocate an aligned block of nbytes.
745 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
746 smaller or equal to BLOCK_BYTES. */
747 static POINTER_TYPE
*
748 lisp_align_malloc (nbytes
, type
)
753 struct ablocks
*abase
;
755 eassert (nbytes
<= BLOCK_BYTES
);
759 #ifdef GC_MALLOC_CHECK
760 allocated_mem_type
= type
;
766 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
768 #ifdef DOUG_LEA_MALLOC
769 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
770 because mapped region contents are not preserved in
772 mallopt (M_MMAP_MAX
, 0);
775 #ifdef HAVE_POSIX_MEMALIGN
777 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
783 base
= malloc (ABLOCKS_BYTES
);
784 abase
= ALIGN (base
, BLOCK_ALIGN
);
793 aligned
= (base
== abase
);
795 ((void**)abase
)[-1] = base
;
797 #ifdef DOUG_LEA_MALLOC
798 /* Back to a reasonable maximum of mmap'ed areas. */
799 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
803 /* If the memory just allocated cannot be addressed thru a Lisp
804 object's pointer, and it needs to be, that's equivalent to
805 running out of memory. */
806 if (type
!= MEM_TYPE_NON_LISP
)
809 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
811 if ((char *) XCONS (tem
) != end
)
813 lisp_malloc_loser
= base
;
821 /* Initialize the blocks and put them on the free list.
822 Is `base' was not properly aligned, we can't use the last block. */
823 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
825 abase
->blocks
[i
].abase
= abase
;
826 abase
->blocks
[i
].x
.next_free
= free_ablock
;
827 free_ablock
= &abase
->blocks
[i
];
829 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
831 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
832 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
833 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
834 eassert (ABLOCKS_BASE (abase
) == base
);
835 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
838 abase
= ABLOCK_ABASE (free_ablock
);
839 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
841 free_ablock
= free_ablock
->x
.next_free
;
843 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
844 if (val
&& type
!= MEM_TYPE_NON_LISP
)
845 mem_insert (val
, (char *) val
+ nbytes
, type
);
852 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
857 lisp_align_free (block
)
860 struct ablock
*ablock
= block
;
861 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
864 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
865 mem_delete (mem_find (block
));
867 /* Put on free list. */
868 ablock
->x
.next_free
= free_ablock
;
869 free_ablock
= ablock
;
870 /* Update busy count. */
871 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
873 if (2 > (long) ABLOCKS_BUSY (abase
))
874 { /* All the blocks are free. */
875 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
876 struct ablock
**tem
= &free_ablock
;
877 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
881 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
884 *tem
= (*tem
)->x
.next_free
;
887 tem
= &(*tem
)->x
.next_free
;
889 eassert ((aligned
& 1) == aligned
);
890 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
891 free (ABLOCKS_BASE (abase
));
896 /* Return a new buffer structure allocated from the heap with
897 a call to lisp_malloc. */
903 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
909 /* Arranging to disable input signals while we're in malloc.
911 This only works with GNU malloc. To help out systems which can't
912 use GNU malloc, all the calls to malloc, realloc, and free
913 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
914 pairs; unfortunately, we have no idea what C library functions
915 might call malloc, so we can't really protect them unless you're
916 using GNU malloc. Fortunately, most of the major operating systems
917 can use GNU malloc. */
919 #ifndef SYSTEM_MALLOC
920 #ifndef DOUG_LEA_MALLOC
921 extern void * (*__malloc_hook
) P_ ((size_t));
922 extern void * (*__realloc_hook
) P_ ((void *, size_t));
923 extern void (*__free_hook
) P_ ((void *));
924 /* Else declared in malloc.h, perhaps with an extra arg. */
925 #endif /* DOUG_LEA_MALLOC */
926 static void * (*old_malloc_hook
) ();
927 static void * (*old_realloc_hook
) ();
928 static void (*old_free_hook
) ();
930 /* This function is used as the hook for free to call. */
933 emacs_blocked_free (ptr
)
938 #ifdef GC_MALLOC_CHECK
944 if (m
== MEM_NIL
|| m
->start
!= ptr
)
947 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
952 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
956 #endif /* GC_MALLOC_CHECK */
958 __free_hook
= old_free_hook
;
961 /* If we released our reserve (due to running out of memory),
962 and we have a fair amount free once again,
963 try to set aside another reserve in case we run out once more. */
964 if (spare_memory
== 0
965 /* Verify there is enough space that even with the malloc
966 hysteresis this call won't run out again.
967 The code here is correct as long as SPARE_MEMORY
968 is substantially larger than the block size malloc uses. */
969 && (bytes_used_when_full
970 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
971 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
973 __free_hook
= emacs_blocked_free
;
978 /* If we released our reserve (due to running out of memory),
979 and we have a fair amount free once again,
980 try to set aside another reserve in case we run out once more.
982 This is called when a relocatable block is freed in ralloc.c. */
985 refill_memory_reserve ()
987 if (spare_memory
== 0)
988 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
992 /* This function is the malloc hook that Emacs uses. */
995 emacs_blocked_malloc (size
)
1001 __malloc_hook
= old_malloc_hook
;
1002 #ifdef DOUG_LEA_MALLOC
1003 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
1005 __malloc_extra_blocks
= malloc_hysteresis
;
1008 value
= (void *) malloc (size
);
1010 #ifdef GC_MALLOC_CHECK
1012 struct mem_node
*m
= mem_find (value
);
1015 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1017 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1018 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1023 if (!dont_register_blocks
)
1025 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1026 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1029 #endif /* GC_MALLOC_CHECK */
1031 __malloc_hook
= emacs_blocked_malloc
;
1034 /* fprintf (stderr, "%p malloc\n", value); */
1039 /* This function is the realloc hook that Emacs uses. */
1042 emacs_blocked_realloc (ptr
, size
)
1049 __realloc_hook
= old_realloc_hook
;
1051 #ifdef GC_MALLOC_CHECK
1054 struct mem_node
*m
= mem_find (ptr
);
1055 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1058 "Realloc of %p which wasn't allocated with malloc\n",
1066 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1068 /* Prevent malloc from registering blocks. */
1069 dont_register_blocks
= 1;
1070 #endif /* GC_MALLOC_CHECK */
1072 value
= (void *) realloc (ptr
, size
);
1074 #ifdef GC_MALLOC_CHECK
1075 dont_register_blocks
= 0;
1078 struct mem_node
*m
= mem_find (value
);
1081 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1085 /* Can't handle zero size regions in the red-black tree. */
1086 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1089 /* fprintf (stderr, "%p <- realloc\n", value); */
1090 #endif /* GC_MALLOC_CHECK */
1092 __realloc_hook
= emacs_blocked_realloc
;
1099 /* Called from main to set up malloc to use our hooks. */
1102 uninterrupt_malloc ()
1104 if (__free_hook
!= emacs_blocked_free
)
1105 old_free_hook
= __free_hook
;
1106 __free_hook
= emacs_blocked_free
;
1108 if (__malloc_hook
!= emacs_blocked_malloc
)
1109 old_malloc_hook
= __malloc_hook
;
1110 __malloc_hook
= emacs_blocked_malloc
;
1112 if (__realloc_hook
!= emacs_blocked_realloc
)
1113 old_realloc_hook
= __realloc_hook
;
1114 __realloc_hook
= emacs_blocked_realloc
;
1117 #endif /* not SYSTEM_MALLOC */
1121 /***********************************************************************
1123 ***********************************************************************/
1125 /* Number of intervals allocated in an interval_block structure.
1126 The 1020 is 1024 minus malloc overhead. */
1128 #define INTERVAL_BLOCK_SIZE \
1129 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1131 /* Intervals are allocated in chunks in form of an interval_block
1134 struct interval_block
1136 /* Place `intervals' first, to preserve alignment. */
1137 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1138 struct interval_block
*next
;
1141 /* Current interval block. Its `next' pointer points to older
1144 struct interval_block
*interval_block
;
1146 /* Index in interval_block above of the next unused interval
1149 static int interval_block_index
;
1151 /* Number of free and live intervals. */
1153 static int total_free_intervals
, total_intervals
;
1155 /* List of free intervals. */
1157 INTERVAL interval_free_list
;
1159 /* Total number of interval blocks now in use. */
1161 int n_interval_blocks
;
1164 /* Initialize interval allocation. */
1169 interval_block
= NULL
;
1170 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1171 interval_free_list
= 0;
1172 n_interval_blocks
= 0;
1176 /* Return a new interval. */
1183 if (interval_free_list
)
1185 val
= interval_free_list
;
1186 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1190 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1192 register struct interval_block
*newi
;
1194 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1197 newi
->next
= interval_block
;
1198 interval_block
= newi
;
1199 interval_block_index
= 0;
1200 n_interval_blocks
++;
1202 val
= &interval_block
->intervals
[interval_block_index
++];
1204 consing_since_gc
+= sizeof (struct interval
);
1206 RESET_INTERVAL (val
);
1212 /* Mark Lisp objects in interval I. */
1215 mark_interval (i
, dummy
)
1216 register INTERVAL i
;
1219 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1221 mark_object (i
->plist
);
1225 /* Mark the interval tree rooted in TREE. Don't call this directly;
1226 use the macro MARK_INTERVAL_TREE instead. */
1229 mark_interval_tree (tree
)
1230 register INTERVAL tree
;
1232 /* No need to test if this tree has been marked already; this
1233 function is always called through the MARK_INTERVAL_TREE macro,
1234 which takes care of that. */
1236 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1240 /* Mark the interval tree rooted in I. */
1242 #define MARK_INTERVAL_TREE(i) \
1244 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1245 mark_interval_tree (i); \
1249 #define UNMARK_BALANCE_INTERVALS(i) \
1251 if (! NULL_INTERVAL_P (i)) \
1252 (i) = balance_intervals (i); \
1256 /* Number support. If NO_UNION_TYPE isn't in effect, we
1257 can't create number objects in macros. */
1265 obj
.s
.type
= Lisp_Int
;
1270 /***********************************************************************
1272 ***********************************************************************/
1274 /* Lisp_Strings are allocated in string_block structures. When a new
1275 string_block is allocated, all the Lisp_Strings it contains are
1276 added to a free-list string_free_list. When a new Lisp_String is
1277 needed, it is taken from that list. During the sweep phase of GC,
1278 string_blocks that are entirely free are freed, except two which
1281 String data is allocated from sblock structures. Strings larger
1282 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1283 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1285 Sblocks consist internally of sdata structures, one for each
1286 Lisp_String. The sdata structure points to the Lisp_String it
1287 belongs to. The Lisp_String points back to the `u.data' member of
1288 its sdata structure.
1290 When a Lisp_String is freed during GC, it is put back on
1291 string_free_list, and its `data' member and its sdata's `string'
1292 pointer is set to null. The size of the string is recorded in the
1293 `u.nbytes' member of the sdata. So, sdata structures that are no
1294 longer used, can be easily recognized, and it's easy to compact the
1295 sblocks of small strings which we do in compact_small_strings. */
1297 /* Size in bytes of an sblock structure used for small strings. This
1298 is 8192 minus malloc overhead. */
1300 #define SBLOCK_SIZE 8188
1302 /* Strings larger than this are considered large strings. String data
1303 for large strings is allocated from individual sblocks. */
1305 #define LARGE_STRING_BYTES 1024
1307 /* Structure describing string memory sub-allocated from an sblock.
1308 This is where the contents of Lisp strings are stored. */
1312 /* Back-pointer to the string this sdata belongs to. If null, this
1313 structure is free, and the NBYTES member of the union below
1314 contains the string's byte size (the same value that STRING_BYTES
1315 would return if STRING were non-null). If non-null, STRING_BYTES
1316 (STRING) is the size of the data, and DATA contains the string's
1318 struct Lisp_String
*string
;
1320 #ifdef GC_CHECK_STRING_BYTES
1323 unsigned char data
[1];
1325 #define SDATA_NBYTES(S) (S)->nbytes
1326 #define SDATA_DATA(S) (S)->data
1328 #else /* not GC_CHECK_STRING_BYTES */
1332 /* When STRING in non-null. */
1333 unsigned char data
[1];
1335 /* When STRING is null. */
1340 #define SDATA_NBYTES(S) (S)->u.nbytes
1341 #define SDATA_DATA(S) (S)->u.data
1343 #endif /* not GC_CHECK_STRING_BYTES */
1347 /* Structure describing a block of memory which is sub-allocated to
1348 obtain string data memory for strings. Blocks for small strings
1349 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1350 as large as needed. */
1355 struct sblock
*next
;
1357 /* Pointer to the next free sdata block. This points past the end
1358 of the sblock if there isn't any space left in this block. */
1359 struct sdata
*next_free
;
1361 /* Start of data. */
1362 struct sdata first_data
;
1365 /* Number of Lisp strings in a string_block structure. The 1020 is
1366 1024 minus malloc overhead. */
1368 #define STRING_BLOCK_SIZE \
1369 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1371 /* Structure describing a block from which Lisp_String structures
1376 /* Place `strings' first, to preserve alignment. */
1377 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1378 struct string_block
*next
;
1381 /* Head and tail of the list of sblock structures holding Lisp string
1382 data. We always allocate from current_sblock. The NEXT pointers
1383 in the sblock structures go from oldest_sblock to current_sblock. */
1385 static struct sblock
*oldest_sblock
, *current_sblock
;
1387 /* List of sblocks for large strings. */
1389 static struct sblock
*large_sblocks
;
1391 /* List of string_block structures, and how many there are. */
1393 static struct string_block
*string_blocks
;
1394 static int n_string_blocks
;
1396 /* Free-list of Lisp_Strings. */
1398 static struct Lisp_String
*string_free_list
;
1400 /* Number of live and free Lisp_Strings. */
1402 static int total_strings
, total_free_strings
;
1404 /* Number of bytes used by live strings. */
1406 static int total_string_size
;
1408 /* Given a pointer to a Lisp_String S which is on the free-list
1409 string_free_list, return a pointer to its successor in the
1412 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1414 /* Return a pointer to the sdata structure belonging to Lisp string S.
1415 S must be live, i.e. S->data must not be null. S->data is actually
1416 a pointer to the `u.data' member of its sdata structure; the
1417 structure starts at a constant offset in front of that. */
1419 #ifdef GC_CHECK_STRING_BYTES
1421 #define SDATA_OF_STRING(S) \
1422 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1423 - sizeof (EMACS_INT)))
1425 #else /* not GC_CHECK_STRING_BYTES */
1427 #define SDATA_OF_STRING(S) \
1428 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1430 #endif /* not GC_CHECK_STRING_BYTES */
1432 /* Value is the size of an sdata structure large enough to hold NBYTES
1433 bytes of string data. The value returned includes a terminating
1434 NUL byte, the size of the sdata structure, and padding. */
1436 #ifdef GC_CHECK_STRING_BYTES
1438 #define SDATA_SIZE(NBYTES) \
1439 ((sizeof (struct Lisp_String *) \
1441 + sizeof (EMACS_INT) \
1442 + sizeof (EMACS_INT) - 1) \
1443 & ~(sizeof (EMACS_INT) - 1))
1445 #else /* not GC_CHECK_STRING_BYTES */
1447 #define SDATA_SIZE(NBYTES) \
1448 ((sizeof (struct Lisp_String *) \
1450 + sizeof (EMACS_INT) - 1) \
1451 & ~(sizeof (EMACS_INT) - 1))
1453 #endif /* not GC_CHECK_STRING_BYTES */
1455 /* Initialize string allocation. Called from init_alloc_once. */
1460 total_strings
= total_free_strings
= total_string_size
= 0;
1461 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1462 string_blocks
= NULL
;
1463 n_string_blocks
= 0;
1464 string_free_list
= NULL
;
1468 #ifdef GC_CHECK_STRING_BYTES
1470 static int check_string_bytes_count
;
1472 void check_string_bytes
P_ ((int));
1473 void check_sblock
P_ ((struct sblock
*));
1475 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1478 /* Like GC_STRING_BYTES, but with debugging check. */
1482 struct Lisp_String
*s
;
1484 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1485 if (!PURE_POINTER_P (s
)
1487 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1492 /* Check validity of Lisp strings' string_bytes member in B. */
1498 struct sdata
*from
, *end
, *from_end
;
1502 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1504 /* Compute the next FROM here because copying below may
1505 overwrite data we need to compute it. */
1508 /* Check that the string size recorded in the string is the
1509 same as the one recorded in the sdata structure. */
1511 CHECK_STRING_BYTES (from
->string
);
1514 nbytes
= GC_STRING_BYTES (from
->string
);
1516 nbytes
= SDATA_NBYTES (from
);
1518 nbytes
= SDATA_SIZE (nbytes
);
1519 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1524 /* Check validity of Lisp strings' string_bytes member. ALL_P
1525 non-zero means check all strings, otherwise check only most
1526 recently allocated strings. Used for hunting a bug. */
1529 check_string_bytes (all_p
)
1536 for (b
= large_sblocks
; b
; b
= b
->next
)
1538 struct Lisp_String
*s
= b
->first_data
.string
;
1540 CHECK_STRING_BYTES (s
);
1543 for (b
= oldest_sblock
; b
; b
= b
->next
)
1547 check_sblock (current_sblock
);
1550 #endif /* GC_CHECK_STRING_BYTES */
1553 /* Return a new Lisp_String. */
1555 static struct Lisp_String
*
1558 struct Lisp_String
*s
;
1560 /* If the free-list is empty, allocate a new string_block, and
1561 add all the Lisp_Strings in it to the free-list. */
1562 if (string_free_list
== NULL
)
1564 struct string_block
*b
;
1567 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1568 bzero (b
, sizeof *b
);
1569 b
->next
= string_blocks
;
1573 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1576 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1577 string_free_list
= s
;
1580 total_free_strings
+= STRING_BLOCK_SIZE
;
1583 /* Pop a Lisp_String off the free-list. */
1584 s
= string_free_list
;
1585 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1587 /* Probably not strictly necessary, but play it safe. */
1588 bzero (s
, sizeof *s
);
1590 --total_free_strings
;
1593 consing_since_gc
+= sizeof *s
;
1595 #ifdef GC_CHECK_STRING_BYTES
1602 if (++check_string_bytes_count
== 200)
1604 check_string_bytes_count
= 0;
1605 check_string_bytes (1);
1608 check_string_bytes (0);
1610 #endif /* GC_CHECK_STRING_BYTES */
1616 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1617 plus a NUL byte at the end. Allocate an sdata structure for S, and
1618 set S->data to its `u.data' member. Store a NUL byte at the end of
1619 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1620 S->data if it was initially non-null. */
1623 allocate_string_data (s
, nchars
, nbytes
)
1624 struct Lisp_String
*s
;
1627 struct sdata
*data
, *old_data
;
1629 int needed
, old_nbytes
;
1631 /* Determine the number of bytes needed to store NBYTES bytes
1633 needed
= SDATA_SIZE (nbytes
);
1635 if (nbytes
> LARGE_STRING_BYTES
)
1637 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1639 #ifdef DOUG_LEA_MALLOC
1640 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1641 because mapped region contents are not preserved in
1644 In case you think of allowing it in a dumped Emacs at the
1645 cost of not being able to re-dump, there's another reason:
1646 mmap'ed data typically have an address towards the top of the
1647 address space, which won't fit into an EMACS_INT (at least on
1648 32-bit systems with the current tagging scheme). --fx */
1649 mallopt (M_MMAP_MAX
, 0);
1652 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1654 #ifdef DOUG_LEA_MALLOC
1655 /* Back to a reasonable maximum of mmap'ed areas. */
1656 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1659 b
->next_free
= &b
->first_data
;
1660 b
->first_data
.string
= NULL
;
1661 b
->next
= large_sblocks
;
1664 else if (current_sblock
== NULL
1665 || (((char *) current_sblock
+ SBLOCK_SIZE
1666 - (char *) current_sblock
->next_free
)
1669 /* Not enough room in the current sblock. */
1670 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1671 b
->next_free
= &b
->first_data
;
1672 b
->first_data
.string
= NULL
;
1676 current_sblock
->next
= b
;
1684 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1685 old_nbytes
= GC_STRING_BYTES (s
);
1687 data
= b
->next_free
;
1689 s
->data
= SDATA_DATA (data
);
1690 #ifdef GC_CHECK_STRING_BYTES
1691 SDATA_NBYTES (data
) = nbytes
;
1694 s
->size_byte
= nbytes
;
1695 s
->data
[nbytes
] = '\0';
1696 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1698 /* If S had already data assigned, mark that as free by setting its
1699 string back-pointer to null, and recording the size of the data
1703 SDATA_NBYTES (old_data
) = old_nbytes
;
1704 old_data
->string
= NULL
;
1707 consing_since_gc
+= needed
;
1711 /* Sweep and compact strings. */
1716 struct string_block
*b
, *next
;
1717 struct string_block
*live_blocks
= NULL
;
1719 string_free_list
= NULL
;
1720 total_strings
= total_free_strings
= 0;
1721 total_string_size
= 0;
1723 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1724 for (b
= string_blocks
; b
; b
= next
)
1727 struct Lisp_String
*free_list_before
= string_free_list
;
1731 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1733 struct Lisp_String
*s
= b
->strings
+ i
;
1737 /* String was not on free-list before. */
1738 if (STRING_MARKED_P (s
))
1740 /* String is live; unmark it and its intervals. */
1743 if (!NULL_INTERVAL_P (s
->intervals
))
1744 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1747 total_string_size
+= STRING_BYTES (s
);
1751 /* String is dead. Put it on the free-list. */
1752 struct sdata
*data
= SDATA_OF_STRING (s
);
1754 /* Save the size of S in its sdata so that we know
1755 how large that is. Reset the sdata's string
1756 back-pointer so that we know it's free. */
1757 #ifdef GC_CHECK_STRING_BYTES
1758 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1761 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1763 data
->string
= NULL
;
1765 /* Reset the strings's `data' member so that we
1769 /* Put the string on the free-list. */
1770 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1771 string_free_list
= s
;
1777 /* S was on the free-list before. Put it there again. */
1778 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1779 string_free_list
= s
;
1784 /* Free blocks that contain free Lisp_Strings only, except
1785 the first two of them. */
1786 if (nfree
== STRING_BLOCK_SIZE
1787 && total_free_strings
> STRING_BLOCK_SIZE
)
1791 string_free_list
= free_list_before
;
1795 total_free_strings
+= nfree
;
1796 b
->next
= live_blocks
;
1801 string_blocks
= live_blocks
;
1802 free_large_strings ();
1803 compact_small_strings ();
1807 /* Free dead large strings. */
1810 free_large_strings ()
1812 struct sblock
*b
, *next
;
1813 struct sblock
*live_blocks
= NULL
;
1815 for (b
= large_sblocks
; b
; b
= next
)
1819 if (b
->first_data
.string
== NULL
)
1823 b
->next
= live_blocks
;
1828 large_sblocks
= live_blocks
;
1832 /* Compact data of small strings. Free sblocks that don't contain
1833 data of live strings after compaction. */
1836 compact_small_strings ()
1838 struct sblock
*b
, *tb
, *next
;
1839 struct sdata
*from
, *to
, *end
, *tb_end
;
1840 struct sdata
*to_end
, *from_end
;
1842 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1843 to, and TB_END is the end of TB. */
1845 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1846 to
= &tb
->first_data
;
1848 /* Step through the blocks from the oldest to the youngest. We
1849 expect that old blocks will stabilize over time, so that less
1850 copying will happen this way. */
1851 for (b
= oldest_sblock
; b
; b
= b
->next
)
1854 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1856 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1858 /* Compute the next FROM here because copying below may
1859 overwrite data we need to compute it. */
1862 #ifdef GC_CHECK_STRING_BYTES
1863 /* Check that the string size recorded in the string is the
1864 same as the one recorded in the sdata structure. */
1866 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1868 #endif /* GC_CHECK_STRING_BYTES */
1871 nbytes
= GC_STRING_BYTES (from
->string
);
1873 nbytes
= SDATA_NBYTES (from
);
1875 nbytes
= SDATA_SIZE (nbytes
);
1876 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1878 /* FROM->string non-null means it's alive. Copy its data. */
1881 /* If TB is full, proceed with the next sblock. */
1882 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1883 if (to_end
> tb_end
)
1887 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1888 to
= &tb
->first_data
;
1889 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1892 /* Copy, and update the string's `data' pointer. */
1895 xassert (tb
!= b
|| to
<= from
);
1896 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1897 to
->string
->data
= SDATA_DATA (to
);
1900 /* Advance past the sdata we copied to. */
1906 /* The rest of the sblocks following TB don't contain live data, so
1907 we can free them. */
1908 for (b
= tb
->next
; b
; b
= next
)
1916 current_sblock
= tb
;
1920 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1921 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
1922 LENGTH must be an integer.
1923 INIT must be an integer that represents a character. */)
1925 Lisp_Object length
, init
;
1927 register Lisp_Object val
;
1928 register unsigned char *p
, *end
;
1931 CHECK_NATNUM (length
);
1932 CHECK_NUMBER (init
);
1935 if (SINGLE_BYTE_CHAR_P (c
))
1937 nbytes
= XINT (length
);
1938 val
= make_uninit_string (nbytes
);
1940 end
= p
+ SCHARS (val
);
1946 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1947 int len
= CHAR_STRING (c
, str
);
1949 nbytes
= len
* XINT (length
);
1950 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1955 bcopy (str
, p
, len
);
1965 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1966 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
1967 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
1969 Lisp_Object length
, init
;
1971 register Lisp_Object val
;
1972 struct Lisp_Bool_Vector
*p
;
1974 int length_in_chars
, length_in_elts
, bits_per_value
;
1976 CHECK_NATNUM (length
);
1978 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
1980 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1981 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
1982 / BOOL_VECTOR_BITS_PER_CHAR
);
1984 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1985 slot `size' of the struct Lisp_Bool_Vector. */
1986 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1987 p
= XBOOL_VECTOR (val
);
1989 /* Get rid of any bits that would cause confusion. */
1991 XSETBOOL_VECTOR (val
, p
);
1992 p
->size
= XFASTINT (length
);
1994 real_init
= (NILP (init
) ? 0 : -1);
1995 for (i
= 0; i
< length_in_chars
; i
++)
1996 p
->data
[i
] = real_init
;
1998 /* Clear the extraneous bits in the last byte. */
1999 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2000 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
2001 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2007 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2008 of characters from the contents. This string may be unibyte or
2009 multibyte, depending on the contents. */
2012 make_string (contents
, nbytes
)
2013 const char *contents
;
2016 register Lisp_Object val
;
2017 int nchars
, multibyte_nbytes
;
2019 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
2020 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2021 /* CONTENTS contains no multibyte sequences or contains an invalid
2022 multibyte sequence. We must make unibyte string. */
2023 val
= make_unibyte_string (contents
, nbytes
);
2025 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2030 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2033 make_unibyte_string (contents
, length
)
2034 const char *contents
;
2037 register Lisp_Object val
;
2038 val
= make_uninit_string (length
);
2039 bcopy (contents
, SDATA (val
), length
);
2040 STRING_SET_UNIBYTE (val
);
2045 /* Make a multibyte string from NCHARS characters occupying NBYTES
2046 bytes at CONTENTS. */
2049 make_multibyte_string (contents
, nchars
, nbytes
)
2050 const char *contents
;
2053 register Lisp_Object val
;
2054 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2055 bcopy (contents
, SDATA (val
), nbytes
);
2060 /* Make a string from NCHARS characters occupying NBYTES bytes at
2061 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2064 make_string_from_bytes (contents
, nchars
, nbytes
)
2065 const char *contents
;
2068 register Lisp_Object val
;
2069 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2070 bcopy (contents
, SDATA (val
), nbytes
);
2071 if (SBYTES (val
) == SCHARS (val
))
2072 STRING_SET_UNIBYTE (val
);
2077 /* Make a string from NCHARS characters occupying NBYTES bytes at
2078 CONTENTS. The argument MULTIBYTE controls whether to label the
2079 string as multibyte. If NCHARS is negative, it counts the number of
2080 characters by itself. */
2083 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2084 const char *contents
;
2088 register Lisp_Object val
;
2093 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2097 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2098 bcopy (contents
, SDATA (val
), nbytes
);
2100 STRING_SET_UNIBYTE (val
);
2105 /* Make a string from the data at STR, treating it as multibyte if the
2112 return make_string (str
, strlen (str
));
2116 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2117 occupying LENGTH bytes. */
2120 make_uninit_string (length
)
2124 val
= make_uninit_multibyte_string (length
, length
);
2125 STRING_SET_UNIBYTE (val
);
2130 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2131 which occupy NBYTES bytes. */
2134 make_uninit_multibyte_string (nchars
, nbytes
)
2138 struct Lisp_String
*s
;
2143 s
= allocate_string ();
2144 allocate_string_data (s
, nchars
, nbytes
);
2145 XSETSTRING (string
, s
);
2146 string_chars_consed
+= nbytes
;
2152 /***********************************************************************
2154 ***********************************************************************/
2156 /* We store float cells inside of float_blocks, allocating a new
2157 float_block with malloc whenever necessary. Float cells reclaimed
2158 by GC are put on a free list to be reallocated before allocating
2159 any new float cells from the latest float_block. */
2161 #define FLOAT_BLOCK_SIZE \
2162 (((BLOCK_BYTES - sizeof (struct float_block *) \
2163 /* The compiler might add padding at the end. */ \
2164 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2165 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2167 #define GETMARKBIT(block,n) \
2168 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2169 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2172 #define SETMARKBIT(block,n) \
2173 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2174 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2176 #define UNSETMARKBIT(block,n) \
2177 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2178 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2180 #define FLOAT_BLOCK(fptr) \
2181 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2183 #define FLOAT_INDEX(fptr) \
2184 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2188 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2189 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2190 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2191 struct float_block
*next
;
2194 #define FLOAT_MARKED_P(fptr) \
2195 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2197 #define FLOAT_MARK(fptr) \
2198 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2200 #define FLOAT_UNMARK(fptr) \
2201 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2203 /* Current float_block. */
2205 struct float_block
*float_block
;
2207 /* Index of first unused Lisp_Float in the current float_block. */
2209 int float_block_index
;
2211 /* Total number of float blocks now in use. */
2215 /* Free-list of Lisp_Floats. */
2217 struct Lisp_Float
*float_free_list
;
2220 /* Initialize float allocation. */
2226 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2227 float_free_list
= 0;
2232 /* Explicitly free a float cell by putting it on the free-list. */
2236 struct Lisp_Float
*ptr
;
2238 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
2239 float_free_list
= ptr
;
2243 /* Return a new float object with value FLOAT_VALUE. */
2246 make_float (float_value
)
2249 register Lisp_Object val
;
2251 if (float_free_list
)
2253 /* We use the data field for chaining the free list
2254 so that we won't use the same field that has the mark bit. */
2255 XSETFLOAT (val
, float_free_list
);
2256 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
2260 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2262 register struct float_block
*new;
2264 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2266 new->next
= float_block
;
2267 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2269 float_block_index
= 0;
2272 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2273 float_block_index
++;
2276 XFLOAT_DATA (val
) = float_value
;
2277 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2278 consing_since_gc
+= sizeof (struct Lisp_Float
);
2285 /***********************************************************************
2287 ***********************************************************************/
2289 /* We store cons cells inside of cons_blocks, allocating a new
2290 cons_block with malloc whenever necessary. Cons cells reclaimed by
2291 GC are put on a free list to be reallocated before allocating
2292 any new cons cells from the latest cons_block. */
2294 #define CONS_BLOCK_SIZE \
2295 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2296 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2298 #define CONS_BLOCK(fptr) \
2299 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2301 #define CONS_INDEX(fptr) \
2302 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2306 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2307 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2308 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2309 struct cons_block
*next
;
2312 #define CONS_MARKED_P(fptr) \
2313 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2315 #define CONS_MARK(fptr) \
2316 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2318 #define CONS_UNMARK(fptr) \
2319 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2321 /* Current cons_block. */
2323 struct cons_block
*cons_block
;
2325 /* Index of first unused Lisp_Cons in the current block. */
2327 int cons_block_index
;
2329 /* Free-list of Lisp_Cons structures. */
2331 struct Lisp_Cons
*cons_free_list
;
2333 /* Total number of cons blocks now in use. */
2338 /* Initialize cons allocation. */
2344 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2350 /* Explicitly free a cons cell by putting it on the free-list. */
2354 struct Lisp_Cons
*ptr
;
2356 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2360 cons_free_list
= ptr
;
2363 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2364 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2366 Lisp_Object car
, cdr
;
2368 register Lisp_Object val
;
2372 /* We use the cdr for chaining the free list
2373 so that we won't use the same field that has the mark bit. */
2374 XSETCONS (val
, cons_free_list
);
2375 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2379 if (cons_block_index
== CONS_BLOCK_SIZE
)
2381 register struct cons_block
*new;
2382 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2384 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2385 new->next
= cons_block
;
2387 cons_block_index
= 0;
2390 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2396 eassert (!CONS_MARKED_P (XCONS (val
)));
2397 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2398 cons_cells_consed
++;
2402 /* Get an error now if there's any junk in the cons free list. */
2406 struct Lisp_Cons
*tail
= cons_free_list
;
2410 tail
= *(struct Lisp_Cons
**)&tail
->cdr
;
2414 /* Make a list of 2, 3, 4 or 5 specified objects. */
2418 Lisp_Object arg1
, arg2
;
2420 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2425 list3 (arg1
, arg2
, arg3
)
2426 Lisp_Object arg1
, arg2
, arg3
;
2428 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2433 list4 (arg1
, arg2
, arg3
, arg4
)
2434 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2436 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2441 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2442 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2444 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2445 Fcons (arg5
, Qnil
)))));
2449 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2450 doc
: /* Return a newly created list with specified arguments as elements.
2451 Any number of arguments, even zero arguments, are allowed.
2452 usage: (list &rest OBJECTS) */)
2455 register Lisp_Object
*args
;
2457 register Lisp_Object val
;
2463 val
= Fcons (args
[nargs
], val
);
2469 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2470 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2472 register Lisp_Object length
, init
;
2474 register Lisp_Object val
;
2477 CHECK_NATNUM (length
);
2478 size
= XFASTINT (length
);
2483 val
= Fcons (init
, val
);
2488 val
= Fcons (init
, val
);
2493 val
= Fcons (init
, val
);
2498 val
= Fcons (init
, val
);
2503 val
= Fcons (init
, val
);
2518 /***********************************************************************
2520 ***********************************************************************/
2522 /* Singly-linked list of all vectors. */
2524 struct Lisp_Vector
*all_vectors
;
2526 /* Total number of vector-like objects now in use. */
2531 /* Value is a pointer to a newly allocated Lisp_Vector structure
2532 with room for LEN Lisp_Objects. */
2534 static struct Lisp_Vector
*
2535 allocate_vectorlike (len
, type
)
2539 struct Lisp_Vector
*p
;
2542 #ifdef DOUG_LEA_MALLOC
2543 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2544 because mapped region contents are not preserved in
2547 mallopt (M_MMAP_MAX
, 0);
2551 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2552 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2554 #ifdef DOUG_LEA_MALLOC
2555 /* Back to a reasonable maximum of mmap'ed areas. */
2557 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2561 consing_since_gc
+= nbytes
;
2562 vector_cells_consed
+= len
;
2564 p
->next
= all_vectors
;
2571 /* Allocate a vector with NSLOTS slots. */
2573 struct Lisp_Vector
*
2574 allocate_vector (nslots
)
2577 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2583 /* Allocate other vector-like structures. */
2585 struct Lisp_Hash_Table
*
2586 allocate_hash_table ()
2588 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2589 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2593 for (i
= 0; i
< len
; ++i
)
2594 v
->contents
[i
] = Qnil
;
2596 return (struct Lisp_Hash_Table
*) v
;
2603 EMACS_INT len
= VECSIZE (struct window
);
2604 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2607 for (i
= 0; i
< len
; ++i
)
2608 v
->contents
[i
] = Qnil
;
2611 return (struct window
*) v
;
2618 EMACS_INT len
= VECSIZE (struct frame
);
2619 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2622 for (i
= 0; i
< len
; ++i
)
2623 v
->contents
[i
] = make_number (0);
2625 return (struct frame
*) v
;
2629 struct Lisp_Process
*
2632 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2633 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2636 for (i
= 0; i
< len
; ++i
)
2637 v
->contents
[i
] = Qnil
;
2640 return (struct Lisp_Process
*) v
;
2644 struct Lisp_Vector
*
2645 allocate_other_vector (len
)
2648 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2651 for (i
= 0; i
< len
; ++i
)
2652 v
->contents
[i
] = Qnil
;
2659 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2660 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2661 See also the function `vector'. */)
2663 register Lisp_Object length
, init
;
2666 register EMACS_INT sizei
;
2668 register struct Lisp_Vector
*p
;
2670 CHECK_NATNUM (length
);
2671 sizei
= XFASTINT (length
);
2673 p
= allocate_vector (sizei
);
2674 for (index
= 0; index
< sizei
; index
++)
2675 p
->contents
[index
] = init
;
2677 XSETVECTOR (vector
, p
);
2682 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2683 doc
: /* Return a newly created char-table, with purpose PURPOSE.
2684 Each element is initialized to INIT, which defaults to nil.
2685 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
2686 The property's value should be an integer between 0 and 10. */)
2688 register Lisp_Object purpose
, init
;
2692 CHECK_SYMBOL (purpose
);
2693 n
= Fget (purpose
, Qchar_table_extra_slots
);
2695 if (XINT (n
) < 0 || XINT (n
) > 10)
2696 args_out_of_range (n
, Qnil
);
2697 /* Add 2 to the size for the defalt and parent slots. */
2698 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2700 XCHAR_TABLE (vector
)->top
= Qt
;
2701 XCHAR_TABLE (vector
)->parent
= Qnil
;
2702 XCHAR_TABLE (vector
)->purpose
= purpose
;
2703 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2708 /* Return a newly created sub char table with default value DEFALT.
2709 Since a sub char table does not appear as a top level Emacs Lisp
2710 object, we don't need a Lisp interface to make it. */
2713 make_sub_char_table (defalt
)
2717 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2718 XCHAR_TABLE (vector
)->top
= Qnil
;
2719 XCHAR_TABLE (vector
)->defalt
= defalt
;
2720 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2725 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2726 doc
: /* Return a newly created vector with specified arguments as elements.
2727 Any number of arguments, even zero arguments, are allowed.
2728 usage: (vector &rest OBJECTS) */)
2733 register Lisp_Object len
, val
;
2735 register struct Lisp_Vector
*p
;
2737 XSETFASTINT (len
, nargs
);
2738 val
= Fmake_vector (len
, Qnil
);
2740 for (index
= 0; index
< nargs
; index
++)
2741 p
->contents
[index
] = args
[index
];
2746 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2747 doc
: /* Create a byte-code object with specified arguments as elements.
2748 The arguments should be the arglist, bytecode-string, constant vector,
2749 stack size, (optional) doc string, and (optional) interactive spec.
2750 The first four arguments are required; at most six have any
2752 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2757 register Lisp_Object len
, val
;
2759 register struct Lisp_Vector
*p
;
2761 XSETFASTINT (len
, nargs
);
2762 if (!NILP (Vpurify_flag
))
2763 val
= make_pure_vector ((EMACS_INT
) nargs
);
2765 val
= Fmake_vector (len
, Qnil
);
2767 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2768 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2769 earlier because they produced a raw 8-bit string for byte-code
2770 and now such a byte-code string is loaded as multibyte while
2771 raw 8-bit characters converted to multibyte form. Thus, now we
2772 must convert them back to the original unibyte form. */
2773 args
[1] = Fstring_as_unibyte (args
[1]);
2776 for (index
= 0; index
< nargs
; index
++)
2778 if (!NILP (Vpurify_flag
))
2779 args
[index
] = Fpurecopy (args
[index
]);
2780 p
->contents
[index
] = args
[index
];
2782 XSETCOMPILED (val
, p
);
2788 /***********************************************************************
2790 ***********************************************************************/
2792 /* Each symbol_block is just under 1020 bytes long, since malloc
2793 really allocates in units of powers of two and uses 4 bytes for its
2796 #define SYMBOL_BLOCK_SIZE \
2797 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2801 /* Place `symbols' first, to preserve alignment. */
2802 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2803 struct symbol_block
*next
;
2806 /* Current symbol block and index of first unused Lisp_Symbol
2809 struct symbol_block
*symbol_block
;
2810 int symbol_block_index
;
2812 /* List of free symbols. */
2814 struct Lisp_Symbol
*symbol_free_list
;
2816 /* Total number of symbol blocks now in use. */
2818 int n_symbol_blocks
;
2821 /* Initialize symbol allocation. */
2826 symbol_block
= NULL
;
2827 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
2828 symbol_free_list
= 0;
2829 n_symbol_blocks
= 0;
2833 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2834 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
2835 Its value and function definition are void, and its property list is nil. */)
2839 register Lisp_Object val
;
2840 register struct Lisp_Symbol
*p
;
2842 CHECK_STRING (name
);
2844 if (symbol_free_list
)
2846 XSETSYMBOL (val
, symbol_free_list
);
2847 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2851 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2853 struct symbol_block
*new;
2854 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2856 new->next
= symbol_block
;
2858 symbol_block_index
= 0;
2861 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
2862 symbol_block_index
++;
2868 p
->value
= Qunbound
;
2869 p
->function
= Qunbound
;
2872 p
->interned
= SYMBOL_UNINTERNED
;
2874 p
->indirect_variable
= 0;
2875 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2882 /***********************************************************************
2883 Marker (Misc) Allocation
2884 ***********************************************************************/
2886 /* Allocation of markers and other objects that share that structure.
2887 Works like allocation of conses. */
2889 #define MARKER_BLOCK_SIZE \
2890 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2894 /* Place `markers' first, to preserve alignment. */
2895 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2896 struct marker_block
*next
;
2899 struct marker_block
*marker_block
;
2900 int marker_block_index
;
2902 union Lisp_Misc
*marker_free_list
;
2904 /* Total number of marker blocks now in use. */
2906 int n_marker_blocks
;
2911 marker_block
= NULL
;
2912 marker_block_index
= MARKER_BLOCK_SIZE
;
2913 marker_free_list
= 0;
2914 n_marker_blocks
= 0;
2917 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2924 if (marker_free_list
)
2926 XSETMISC (val
, marker_free_list
);
2927 marker_free_list
= marker_free_list
->u_free
.chain
;
2931 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2933 struct marker_block
*new;
2934 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2936 new->next
= marker_block
;
2938 marker_block_index
= 0;
2940 total_free_markers
+= MARKER_BLOCK_SIZE
;
2942 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
2943 marker_block_index
++;
2946 --total_free_markers
;
2947 consing_since_gc
+= sizeof (union Lisp_Misc
);
2948 misc_objects_consed
++;
2949 XMARKER (val
)->gcmarkbit
= 0;
2953 /* Free a Lisp_Misc object */
2959 XMISC (misc
)->u_marker
.type
= Lisp_Misc_Free
;
2960 XMISC (misc
)->u_free
.chain
= marker_free_list
;
2961 marker_free_list
= XMISC (misc
);
2963 total_free_markers
++;
2966 /* Return a Lisp_Misc_Save_Value object containing POINTER and
2967 INTEGER. This is used to package C values to call record_unwind_protect.
2968 The unwind function can get the C values back using XSAVE_VALUE. */
2971 make_save_value (pointer
, integer
)
2975 register Lisp_Object val
;
2976 register struct Lisp_Save_Value
*p
;
2978 val
= allocate_misc ();
2979 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
2980 p
= XSAVE_VALUE (val
);
2981 p
->pointer
= pointer
;
2982 p
->integer
= integer
;
2987 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2988 doc
: /* Return a newly allocated marker which does not point at any place. */)
2991 register Lisp_Object val
;
2992 register struct Lisp_Marker
*p
;
2994 val
= allocate_misc ();
2995 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3001 p
->insertion_type
= 0;
3005 /* Put MARKER back on the free list after using it temporarily. */
3008 free_marker (marker
)
3011 unchain_marker (XMARKER (marker
));
3016 /* Return a newly created vector or string with specified arguments as
3017 elements. If all the arguments are characters that can fit
3018 in a string of events, make a string; otherwise, make a vector.
3020 Any number of arguments, even zero arguments, are allowed. */
3023 make_event_array (nargs
, args
)
3029 for (i
= 0; i
< nargs
; i
++)
3030 /* The things that fit in a string
3031 are characters that are in 0...127,
3032 after discarding the meta bit and all the bits above it. */
3033 if (!INTEGERP (args
[i
])
3034 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3035 return Fvector (nargs
, args
);
3037 /* Since the loop exited, we know that all the things in it are
3038 characters, so we can make a string. */
3042 result
= Fmake_string (make_number (nargs
), make_number (0));
3043 for (i
= 0; i
< nargs
; i
++)
3045 SSET (result
, i
, XINT (args
[i
]));
3046 /* Move the meta bit to the right place for a string char. */
3047 if (XINT (args
[i
]) & CHAR_META
)
3048 SSET (result
, i
, SREF (result
, i
) | 0x80);
3057 /************************************************************************
3059 ************************************************************************/
3061 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3063 /* Conservative C stack marking requires a method to identify possibly
3064 live Lisp objects given a pointer value. We do this by keeping
3065 track of blocks of Lisp data that are allocated in a red-black tree
3066 (see also the comment of mem_node which is the type of nodes in
3067 that tree). Function lisp_malloc adds information for an allocated
3068 block to the red-black tree with calls to mem_insert, and function
3069 lisp_free removes it with mem_delete. Functions live_string_p etc
3070 call mem_find to lookup information about a given pointer in the
3071 tree, and use that to determine if the pointer points to a Lisp
3074 /* Initialize this part of alloc.c. */
3079 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3080 mem_z
.parent
= NULL
;
3081 mem_z
.color
= MEM_BLACK
;
3082 mem_z
.start
= mem_z
.end
= NULL
;
3087 /* Value is a pointer to the mem_node containing START. Value is
3088 MEM_NIL if there is no node in the tree containing START. */
3090 static INLINE
struct mem_node
*
3096 if (start
< min_heap_address
|| start
> max_heap_address
)
3099 /* Make the search always successful to speed up the loop below. */
3100 mem_z
.start
= start
;
3101 mem_z
.end
= (char *) start
+ 1;
3104 while (start
< p
->start
|| start
>= p
->end
)
3105 p
= start
< p
->start
? p
->left
: p
->right
;
3110 /* Insert a new node into the tree for a block of memory with start
3111 address START, end address END, and type TYPE. Value is a
3112 pointer to the node that was inserted. */
3114 static struct mem_node
*
3115 mem_insert (start
, end
, type
)
3119 struct mem_node
*c
, *parent
, *x
;
3121 if (start
< min_heap_address
)
3122 min_heap_address
= start
;
3123 if (end
> max_heap_address
)
3124 max_heap_address
= end
;
3126 /* See where in the tree a node for START belongs. In this
3127 particular application, it shouldn't happen that a node is already
3128 present. For debugging purposes, let's check that. */
3132 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3134 while (c
!= MEM_NIL
)
3136 if (start
>= c
->start
&& start
< c
->end
)
3139 c
= start
< c
->start
? c
->left
: c
->right
;
3142 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3144 while (c
!= MEM_NIL
)
3147 c
= start
< c
->start
? c
->left
: c
->right
;
3150 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3152 /* Create a new node. */
3153 #ifdef GC_MALLOC_CHECK
3154 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3158 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3164 x
->left
= x
->right
= MEM_NIL
;
3167 /* Insert it as child of PARENT or install it as root. */
3170 if (start
< parent
->start
)
3178 /* Re-establish red-black tree properties. */
3179 mem_insert_fixup (x
);
3185 /* Re-establish the red-black properties of the tree, and thereby
3186 balance the tree, after node X has been inserted; X is always red. */
3189 mem_insert_fixup (x
)
3192 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3194 /* X is red and its parent is red. This is a violation of
3195 red-black tree property #3. */
3197 if (x
->parent
== x
->parent
->parent
->left
)
3199 /* We're on the left side of our grandparent, and Y is our
3201 struct mem_node
*y
= x
->parent
->parent
->right
;
3203 if (y
->color
== MEM_RED
)
3205 /* Uncle and parent are red but should be black because
3206 X is red. Change the colors accordingly and proceed
3207 with the grandparent. */
3208 x
->parent
->color
= MEM_BLACK
;
3209 y
->color
= MEM_BLACK
;
3210 x
->parent
->parent
->color
= MEM_RED
;
3211 x
= x
->parent
->parent
;
3215 /* Parent and uncle have different colors; parent is
3216 red, uncle is black. */
3217 if (x
== x
->parent
->right
)
3220 mem_rotate_left (x
);
3223 x
->parent
->color
= MEM_BLACK
;
3224 x
->parent
->parent
->color
= MEM_RED
;
3225 mem_rotate_right (x
->parent
->parent
);
3230 /* This is the symmetrical case of above. */
3231 struct mem_node
*y
= x
->parent
->parent
->left
;
3233 if (y
->color
== MEM_RED
)
3235 x
->parent
->color
= MEM_BLACK
;
3236 y
->color
= MEM_BLACK
;
3237 x
->parent
->parent
->color
= MEM_RED
;
3238 x
= x
->parent
->parent
;
3242 if (x
== x
->parent
->left
)
3245 mem_rotate_right (x
);
3248 x
->parent
->color
= MEM_BLACK
;
3249 x
->parent
->parent
->color
= MEM_RED
;
3250 mem_rotate_left (x
->parent
->parent
);
3255 /* The root may have been changed to red due to the algorithm. Set
3256 it to black so that property #5 is satisfied. */
3257 mem_root
->color
= MEM_BLACK
;
3273 /* Turn y's left sub-tree into x's right sub-tree. */
3276 if (y
->left
!= MEM_NIL
)
3277 y
->left
->parent
= x
;
3279 /* Y's parent was x's parent. */
3281 y
->parent
= x
->parent
;
3283 /* Get the parent to point to y instead of x. */
3286 if (x
== x
->parent
->left
)
3287 x
->parent
->left
= y
;
3289 x
->parent
->right
= y
;
3294 /* Put x on y's left. */
3308 mem_rotate_right (x
)
3311 struct mem_node
*y
= x
->left
;
3314 if (y
->right
!= MEM_NIL
)
3315 y
->right
->parent
= x
;
3318 y
->parent
= x
->parent
;
3321 if (x
== x
->parent
->right
)
3322 x
->parent
->right
= y
;
3324 x
->parent
->left
= y
;
3335 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3341 struct mem_node
*x
, *y
;
3343 if (!z
|| z
== MEM_NIL
)
3346 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3351 while (y
->left
!= MEM_NIL
)
3355 if (y
->left
!= MEM_NIL
)
3360 x
->parent
= y
->parent
;
3363 if (y
== y
->parent
->left
)
3364 y
->parent
->left
= x
;
3366 y
->parent
->right
= x
;
3373 z
->start
= y
->start
;
3378 if (y
->color
== MEM_BLACK
)
3379 mem_delete_fixup (x
);
3381 #ifdef GC_MALLOC_CHECK
3389 /* Re-establish the red-black properties of the tree, after a
3393 mem_delete_fixup (x
)
3396 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3398 if (x
== x
->parent
->left
)
3400 struct mem_node
*w
= x
->parent
->right
;
3402 if (w
->color
== MEM_RED
)
3404 w
->color
= MEM_BLACK
;
3405 x
->parent
->color
= MEM_RED
;
3406 mem_rotate_left (x
->parent
);
3407 w
= x
->parent
->right
;
3410 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3417 if (w
->right
->color
== MEM_BLACK
)
3419 w
->left
->color
= MEM_BLACK
;
3421 mem_rotate_right (w
);
3422 w
= x
->parent
->right
;
3424 w
->color
= x
->parent
->color
;
3425 x
->parent
->color
= MEM_BLACK
;
3426 w
->right
->color
= MEM_BLACK
;
3427 mem_rotate_left (x
->parent
);
3433 struct mem_node
*w
= x
->parent
->left
;
3435 if (w
->color
== MEM_RED
)
3437 w
->color
= MEM_BLACK
;
3438 x
->parent
->color
= MEM_RED
;
3439 mem_rotate_right (x
->parent
);
3440 w
= x
->parent
->left
;
3443 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3450 if (w
->left
->color
== MEM_BLACK
)
3452 w
->right
->color
= MEM_BLACK
;
3454 mem_rotate_left (w
);
3455 w
= x
->parent
->left
;
3458 w
->color
= x
->parent
->color
;
3459 x
->parent
->color
= MEM_BLACK
;
3460 w
->left
->color
= MEM_BLACK
;
3461 mem_rotate_right (x
->parent
);
3467 x
->color
= MEM_BLACK
;
3471 /* Value is non-zero if P is a pointer to a live Lisp string on
3472 the heap. M is a pointer to the mem_block for P. */
3475 live_string_p (m
, p
)
3479 if (m
->type
== MEM_TYPE_STRING
)
3481 struct string_block
*b
= (struct string_block
*) m
->start
;
3482 int offset
= (char *) p
- (char *) &b
->strings
[0];
3484 /* P must point to the start of a Lisp_String structure, and it
3485 must not be on the free-list. */
3487 && offset
% sizeof b
->strings
[0] == 0
3488 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3489 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3496 /* Value is non-zero if P is a pointer to a live Lisp cons on
3497 the heap. M is a pointer to the mem_block for P. */
3504 if (m
->type
== MEM_TYPE_CONS
)
3506 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3507 int offset
= (char *) p
- (char *) &b
->conses
[0];
3509 /* P must point to the start of a Lisp_Cons, not be
3510 one of the unused cells in the current cons block,
3511 and not be on the free-list. */
3513 && offset
% sizeof b
->conses
[0] == 0
3514 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3516 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3517 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3524 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3525 the heap. M is a pointer to the mem_block for P. */
3528 live_symbol_p (m
, p
)
3532 if (m
->type
== MEM_TYPE_SYMBOL
)
3534 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3535 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3537 /* P must point to the start of a Lisp_Symbol, not be
3538 one of the unused cells in the current symbol block,
3539 and not be on the free-list. */
3541 && offset
% sizeof b
->symbols
[0] == 0
3542 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3543 && (b
!= symbol_block
3544 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3545 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3552 /* Value is non-zero if P is a pointer to a live Lisp float on
3553 the heap. M is a pointer to the mem_block for P. */
3560 if (m
->type
== MEM_TYPE_FLOAT
)
3562 struct float_block
*b
= (struct float_block
*) m
->start
;
3563 int offset
= (char *) p
- (char *) &b
->floats
[0];
3565 /* P must point to the start of a Lisp_Float and not be
3566 one of the unused cells in the current float block. */
3568 && offset
% sizeof b
->floats
[0] == 0
3569 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3570 && (b
!= float_block
3571 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3578 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3579 the heap. M is a pointer to the mem_block for P. */
3586 if (m
->type
== MEM_TYPE_MISC
)
3588 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3589 int offset
= (char *) p
- (char *) &b
->markers
[0];
3591 /* P must point to the start of a Lisp_Misc, not be
3592 one of the unused cells in the current misc block,
3593 and not be on the free-list. */
3595 && offset
% sizeof b
->markers
[0] == 0
3596 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3597 && (b
!= marker_block
3598 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3599 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3606 /* Value is non-zero if P is a pointer to a live vector-like object.
3607 M is a pointer to the mem_block for P. */
3610 live_vector_p (m
, p
)
3614 return (p
== m
->start
3615 && m
->type
>= MEM_TYPE_VECTOR
3616 && m
->type
<= MEM_TYPE_WINDOW
);
3620 /* Value is non-zero if P is a pointer to a live buffer. M is a
3621 pointer to the mem_block for P. */
3624 live_buffer_p (m
, p
)
3628 /* P must point to the start of the block, and the buffer
3629 must not have been killed. */
3630 return (m
->type
== MEM_TYPE_BUFFER
3632 && !NILP (((struct buffer
*) p
)->name
));
3635 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3639 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3641 /* Array of objects that are kept alive because the C stack contains
3642 a pattern that looks like a reference to them . */
3644 #define MAX_ZOMBIES 10
3645 static Lisp_Object zombies
[MAX_ZOMBIES
];
3647 /* Number of zombie objects. */
3649 static int nzombies
;
3651 /* Number of garbage collections. */
3655 /* Average percentage of zombies per collection. */
3657 static double avg_zombies
;
3659 /* Max. number of live and zombie objects. */
3661 static int max_live
, max_zombies
;
3663 /* Average number of live objects per GC. */
3665 static double avg_live
;
3667 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3668 doc
: /* Show information about live and zombie objects. */)
3671 Lisp_Object args
[8], zombie_list
= Qnil
;
3673 for (i
= 0; i
< nzombies
; i
++)
3674 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3675 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3676 args
[1] = make_number (ngcs
);
3677 args
[2] = make_float (avg_live
);
3678 args
[3] = make_float (avg_zombies
);
3679 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3680 args
[5] = make_number (max_live
);
3681 args
[6] = make_number (max_zombies
);
3682 args
[7] = zombie_list
;
3683 return Fmessage (8, args
);
3686 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3689 /* Mark OBJ if we can prove it's a Lisp_Object. */
3692 mark_maybe_object (obj
)
3695 void *po
= (void *) XPNTR (obj
);
3696 struct mem_node
*m
= mem_find (po
);
3702 switch (XGCTYPE (obj
))
3705 mark_p
= (live_string_p (m
, po
)
3706 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3710 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
3714 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
3718 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
3721 case Lisp_Vectorlike
:
3722 /* Note: can't check GC_BUFFERP before we know it's a
3723 buffer because checking that dereferences the pointer
3724 PO which might point anywhere. */
3725 if (live_vector_p (m
, po
))
3726 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
3727 else if (live_buffer_p (m
, po
))
3728 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
3732 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
3736 case Lisp_Type_Limit
:
3742 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3743 if (nzombies
< MAX_ZOMBIES
)
3744 zombies
[nzombies
] = obj
;
3753 /* If P points to Lisp data, mark that as live if it isn't already
3757 mark_maybe_pointer (p
)
3762 /* Quickly rule out some values which can't point to Lisp data. We
3763 assume that Lisp data is aligned on even addresses. */
3764 if ((EMACS_INT
) p
& 1)
3770 Lisp_Object obj
= Qnil
;
3774 case MEM_TYPE_NON_LISP
:
3775 /* Nothing to do; not a pointer to Lisp memory. */
3778 case MEM_TYPE_BUFFER
:
3779 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
3780 XSETVECTOR (obj
, p
);
3784 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
3788 case MEM_TYPE_STRING
:
3789 if (live_string_p (m
, p
)
3790 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
3791 XSETSTRING (obj
, p
);
3795 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
3799 case MEM_TYPE_SYMBOL
:
3800 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
3801 XSETSYMBOL (obj
, p
);
3804 case MEM_TYPE_FLOAT
:
3805 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
3809 case MEM_TYPE_VECTOR
:
3810 case MEM_TYPE_PROCESS
:
3811 case MEM_TYPE_HASH_TABLE
:
3812 case MEM_TYPE_FRAME
:
3813 case MEM_TYPE_WINDOW
:
3814 if (live_vector_p (m
, p
))
3817 XSETVECTOR (tem
, p
);
3818 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
3833 /* Mark Lisp objects referenced from the address range START..END. */
3836 mark_memory (start
, end
)
3842 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3846 /* Make START the pointer to the start of the memory region,
3847 if it isn't already. */
3855 /* Mark Lisp_Objects. */
3856 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3857 mark_maybe_object (*p
);
3859 /* Mark Lisp data pointed to. This is necessary because, in some
3860 situations, the C compiler optimizes Lisp objects away, so that
3861 only a pointer to them remains. Example:
3863 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
3866 Lisp_Object obj = build_string ("test");
3867 struct Lisp_String *s = XSTRING (obj);
3868 Fgarbage_collect ();
3869 fprintf (stderr, "test `%s'\n", s->data);
3873 Here, `obj' isn't really used, and the compiler optimizes it
3874 away. The only reference to the life string is through the
3877 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
3878 mark_maybe_pointer (*pp
);
3881 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
3882 the GCC system configuration. In gcc 3.2, the only systems for
3883 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
3884 by others?) and ns32k-pc532-min. */
3886 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3888 static int setjmp_tested_p
, longjmps_done
;
3890 #define SETJMP_WILL_LIKELY_WORK "\
3892 Emacs garbage collector has been changed to use conservative stack\n\
3893 marking. Emacs has determined that the method it uses to do the\n\
3894 marking will likely work on your system, but this isn't sure.\n\
3896 If you are a system-programmer, or can get the help of a local wizard\n\
3897 who is, please take a look at the function mark_stack in alloc.c, and\n\
3898 verify that the methods used are appropriate for your system.\n\
3900 Please mail the result to <emacs-devel@gnu.org>.\n\
3903 #define SETJMP_WILL_NOT_WORK "\
3905 Emacs garbage collector has been changed to use conservative stack\n\
3906 marking. Emacs has determined that the default method it uses to do the\n\
3907 marking will not work on your system. We will need a system-dependent\n\
3908 solution for your system.\n\
3910 Please take a look at the function mark_stack in alloc.c, and\n\
3911 try to find a way to make it work on your system.\n\
3913 Note that you may get false negatives, depending on the compiler.\n\
3914 In particular, you need to use -O with GCC for this test.\n\
3916 Please mail the result to <emacs-devel@gnu.org>.\n\
3920 /* Perform a quick check if it looks like setjmp saves registers in a
3921 jmp_buf. Print a message to stderr saying so. When this test
3922 succeeds, this is _not_ a proof that setjmp is sufficient for
3923 conservative stack marking. Only the sources or a disassembly
3934 /* Arrange for X to be put in a register. */
3940 if (longjmps_done
== 1)
3942 /* Came here after the longjmp at the end of the function.
3944 If x == 1, the longjmp has restored the register to its
3945 value before the setjmp, and we can hope that setjmp
3946 saves all such registers in the jmp_buf, although that
3949 For other values of X, either something really strange is
3950 taking place, or the setjmp just didn't save the register. */
3953 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3956 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3963 if (longjmps_done
== 1)
3967 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3970 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3972 /* Abort if anything GCPRO'd doesn't survive the GC. */
3980 for (p
= gcprolist
; p
; p
= p
->next
)
3981 for (i
= 0; i
< p
->nvars
; ++i
)
3982 if (!survives_gc_p (p
->var
[i
]))
3983 /* FIXME: It's not necessarily a bug. It might just be that the
3984 GCPRO is unnecessary or should release the object sooner. */
3988 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3995 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3996 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3998 fprintf (stderr
, " %d = ", i
);
3999 debug_print (zombies
[i
]);
4003 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4006 /* Mark live Lisp objects on the C stack.
4008 There are several system-dependent problems to consider when
4009 porting this to new architectures:
4013 We have to mark Lisp objects in CPU registers that can hold local
4014 variables or are used to pass parameters.
4016 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4017 something that either saves relevant registers on the stack, or
4018 calls mark_maybe_object passing it each register's contents.
4020 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4021 implementation assumes that calling setjmp saves registers we need
4022 to see in a jmp_buf which itself lies on the stack. This doesn't
4023 have to be true! It must be verified for each system, possibly
4024 by taking a look at the source code of setjmp.
4028 Architectures differ in the way their processor stack is organized.
4029 For example, the stack might look like this
4032 | Lisp_Object | size = 4
4034 | something else | size = 2
4036 | Lisp_Object | size = 4
4040 In such a case, not every Lisp_Object will be aligned equally. To
4041 find all Lisp_Object on the stack it won't be sufficient to walk
4042 the stack in steps of 4 bytes. Instead, two passes will be
4043 necessary, one starting at the start of the stack, and a second
4044 pass starting at the start of the stack + 2. Likewise, if the
4045 minimal alignment of Lisp_Objects on the stack is 1, four passes
4046 would be necessary, each one starting with one byte more offset
4047 from the stack start.
4049 The current code assumes by default that Lisp_Objects are aligned
4050 equally on the stack. */
4057 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4060 /* This trick flushes the register windows so that all the state of
4061 the process is contained in the stack. */
4062 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4063 needed on ia64 too. See mach_dep.c, where it also says inline
4064 assembler doesn't work with relevant proprietary compilers. */
4069 /* Save registers that we need to see on the stack. We need to see
4070 registers used to hold register variables and registers used to
4072 #ifdef GC_SAVE_REGISTERS_ON_STACK
4073 GC_SAVE_REGISTERS_ON_STACK (end
);
4074 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4076 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4077 setjmp will definitely work, test it
4078 and print a message with the result
4080 if (!setjmp_tested_p
)
4082 setjmp_tested_p
= 1;
4085 #endif /* GC_SETJMP_WORKS */
4088 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4089 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4091 /* This assumes that the stack is a contiguous region in memory. If
4092 that's not the case, something has to be done here to iterate
4093 over the stack segments. */
4094 #ifndef GC_LISP_OBJECT_ALIGNMENT
4096 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4098 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4101 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4102 mark_memory ((char *) stack_base
+ i
, end
);
4104 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4110 #endif /* GC_MARK_STACK != 0 */
4114 /***********************************************************************
4115 Pure Storage Management
4116 ***********************************************************************/
4118 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4119 pointer to it. TYPE is the Lisp type for which the memory is
4120 allocated. TYPE < 0 means it's not used for a Lisp object.
4122 If store_pure_type_info is set and TYPE is >= 0, the type of
4123 the allocated object is recorded in pure_types. */
4125 static POINTER_TYPE
*
4126 pure_alloc (size
, type
)
4130 POINTER_TYPE
*result
;
4132 size_t alignment
= (1 << GCTYPEBITS
);
4134 size_t alignment
= sizeof (EMACS_INT
);
4136 /* Give Lisp_Floats an extra alignment. */
4137 if (type
== Lisp_Float
)
4139 #if defined __GNUC__ && __GNUC__ >= 2
4140 alignment
= __alignof (struct Lisp_Float
);
4142 alignment
= sizeof (struct Lisp_Float
);
4148 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4149 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4151 if (pure_bytes_used
<= pure_size
)
4154 /* Don't allocate a large amount here,
4155 because it might get mmap'd and then its address
4156 might not be usable. */
4157 purebeg
= (char *) xmalloc (10000);
4159 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4160 pure_bytes_used
= 0;
4165 /* Print a warning if PURESIZE is too small. */
4170 if (pure_bytes_used_before_overflow
)
4171 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4172 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4176 /* Return a string allocated in pure space. DATA is a buffer holding
4177 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4178 non-zero means make the result string multibyte.
4180 Must get an error if pure storage is full, since if it cannot hold
4181 a large string it may be able to hold conses that point to that
4182 string; then the string is not protected from gc. */
4185 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4191 struct Lisp_String
*s
;
4193 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4194 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4196 s
->size_byte
= multibyte
? nbytes
: -1;
4197 bcopy (data
, s
->data
, nbytes
);
4198 s
->data
[nbytes
] = '\0';
4199 s
->intervals
= NULL_INTERVAL
;
4200 XSETSTRING (string
, s
);
4205 /* Return a cons allocated from pure space. Give it pure copies
4206 of CAR as car and CDR as cdr. */
4209 pure_cons (car
, cdr
)
4210 Lisp_Object car
, cdr
;
4212 register Lisp_Object
new;
4213 struct Lisp_Cons
*p
;
4215 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4217 XSETCAR (new, Fpurecopy (car
));
4218 XSETCDR (new, Fpurecopy (cdr
));
4223 /* Value is a float object with value NUM allocated from pure space. */
4226 make_pure_float (num
)
4229 register Lisp_Object
new;
4230 struct Lisp_Float
*p
;
4232 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4234 XFLOAT_DATA (new) = num
;
4239 /* Return a vector with room for LEN Lisp_Objects allocated from
4243 make_pure_vector (len
)
4247 struct Lisp_Vector
*p
;
4248 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4250 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4251 XSETVECTOR (new, p
);
4252 XVECTOR (new)->size
= len
;
4257 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4258 doc
: /* Make a copy of OBJECT in pure storage.
4259 Recursively copies contents of vectors and cons cells.
4260 Does not copy symbols. Copies strings without text properties. */)
4262 register Lisp_Object obj
;
4264 if (NILP (Vpurify_flag
))
4267 if (PURE_POINTER_P (XPNTR (obj
)))
4271 return pure_cons (XCAR (obj
), XCDR (obj
));
4272 else if (FLOATP (obj
))
4273 return make_pure_float (XFLOAT_DATA (obj
));
4274 else if (STRINGP (obj
))
4275 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4277 STRING_MULTIBYTE (obj
));
4278 else if (COMPILEDP (obj
) || VECTORP (obj
))
4280 register struct Lisp_Vector
*vec
;
4284 size
= XVECTOR (obj
)->size
;
4285 if (size
& PSEUDOVECTOR_FLAG
)
4286 size
&= PSEUDOVECTOR_SIZE_MASK
;
4287 vec
= XVECTOR (make_pure_vector (size
));
4288 for (i
= 0; i
< size
; i
++)
4289 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4290 if (COMPILEDP (obj
))
4291 XSETCOMPILED (obj
, vec
);
4293 XSETVECTOR (obj
, vec
);
4296 else if (MARKERP (obj
))
4297 error ("Attempt to copy a marker to pure storage");
4304 /***********************************************************************
4306 ***********************************************************************/
4308 /* Put an entry in staticvec, pointing at the variable with address
4312 staticpro (varaddress
)
4313 Lisp_Object
*varaddress
;
4315 staticvec
[staticidx
++] = varaddress
;
4316 if (staticidx
>= NSTATICS
)
4324 struct catchtag
*next
;
4328 /***********************************************************************
4330 ***********************************************************************/
4332 /* Temporarily prevent garbage collection. */
4335 inhibit_garbage_collection ()
4337 int count
= SPECPDL_INDEX ();
4338 int nbits
= min (VALBITS
, BITS_PER_INT
);
4340 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4345 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4346 doc
: /* Reclaim storage for Lisp objects no longer needed.
4347 Garbage collection happens automatically if you cons more than
4348 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4349 `garbage-collect' normally returns a list with info on amount of space in use:
4350 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4351 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4352 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4353 (USED-STRINGS . FREE-STRINGS))
4354 However, if there was overflow in pure space, `garbage-collect'
4355 returns nil, because real GC can't be done. */)
4358 register struct specbinding
*bind
;
4359 struct catchtag
*catch;
4360 struct handler
*handler
;
4361 char stack_top_variable
;
4364 Lisp_Object total
[8];
4365 int count
= SPECPDL_INDEX ();
4366 EMACS_TIME t1
, t2
, t3
;
4371 EMACS_GET_TIME (t1
);
4373 /* Can't GC if pure storage overflowed because we can't determine
4374 if something is a pure object or not. */
4375 if (pure_bytes_used_before_overflow
)
4378 /* In case user calls debug_print during GC,
4379 don't let that cause a recursive GC. */
4380 consing_since_gc
= 0;
4382 /* Save what's currently displayed in the echo area. */
4383 message_p
= push_message ();
4384 record_unwind_protect (pop_message_unwind
, Qnil
);
4386 /* Save a copy of the contents of the stack, for debugging. */
4387 #if MAX_SAVE_STACK > 0
4388 if (NILP (Vpurify_flag
))
4390 i
= &stack_top_variable
- stack_bottom
;
4392 if (i
< MAX_SAVE_STACK
)
4394 if (stack_copy
== 0)
4395 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4396 else if (stack_copy_size
< i
)
4397 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4400 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4401 bcopy (stack_bottom
, stack_copy
, i
);
4403 bcopy (&stack_top_variable
, stack_copy
, i
);
4407 #endif /* MAX_SAVE_STACK > 0 */
4409 if (garbage_collection_messages
)
4410 message1_nolog ("Garbage collecting...");
4414 shrink_regexp_cache ();
4416 /* Don't keep undo information around forever. */
4418 register struct buffer
*nextb
= all_buffers
;
4422 /* If a buffer's undo list is Qt, that means that undo is
4423 turned off in that buffer. Calling truncate_undo_list on
4424 Qt tends to return NULL, which effectively turns undo back on.
4425 So don't call truncate_undo_list if undo_list is Qt. */
4426 if (! EQ (nextb
->undo_list
, Qt
))
4428 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
4429 undo_strong_limit
, undo_outer_limit
);
4431 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4432 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4434 /* If a buffer's gap size is more than 10% of the buffer
4435 size, or larger than 2000 bytes, then shrink it
4436 accordingly. Keep a minimum size of 20 bytes. */
4437 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4439 if (nextb
->text
->gap_size
> size
)
4441 struct buffer
*save_current
= current_buffer
;
4442 current_buffer
= nextb
;
4443 make_gap (-(nextb
->text
->gap_size
- size
));
4444 current_buffer
= save_current
;
4448 nextb
= nextb
->next
;
4454 /* clear_marks (); */
4456 /* Mark all the special slots that serve as the roots of accessibility. */
4458 for (i
= 0; i
< staticidx
; i
++)
4459 mark_object (*staticvec
[i
]);
4461 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4463 mark_object (bind
->symbol
);
4464 mark_object (bind
->old_value
);
4471 extern void xg_mark_data ();
4476 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4477 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4481 register struct gcpro
*tail
;
4482 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4483 for (i
= 0; i
< tail
->nvars
; i
++)
4484 mark_object (tail
->var
[i
]);
4489 for (catch = catchlist
; catch; catch = catch->next
)
4491 mark_object (catch->tag
);
4492 mark_object (catch->val
);
4494 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4496 mark_object (handler
->handler
);
4497 mark_object (handler
->var
);
4501 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4505 /* Everything is now marked, except for the things that require special
4506 finalization, i.e. the undo_list.
4507 Look thru every buffer's undo list
4508 for elements that update markers that were not marked,
4511 register struct buffer
*nextb
= all_buffers
;
4515 /* If a buffer's undo list is Qt, that means that undo is
4516 turned off in that buffer. Calling truncate_undo_list on
4517 Qt tends to return NULL, which effectively turns undo back on.
4518 So don't call truncate_undo_list if undo_list is Qt. */
4519 if (! EQ (nextb
->undo_list
, Qt
))
4521 Lisp_Object tail
, prev
;
4522 tail
= nextb
->undo_list
;
4524 while (CONSP (tail
))
4526 if (GC_CONSP (XCAR (tail
))
4527 && GC_MARKERP (XCAR (XCAR (tail
)))
4528 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
4531 nextb
->undo_list
= tail
= XCDR (tail
);
4535 XSETCDR (prev
, tail
);
4545 /* Now that we have stripped the elements that need not be in the
4546 undo_list any more, we can finally mark the list. */
4547 mark_object (nextb
->undo_list
);
4549 nextb
= nextb
->next
;
4555 /* Clear the mark bits that we set in certain root slots. */
4557 unmark_byte_stack ();
4558 VECTOR_UNMARK (&buffer_defaults
);
4559 VECTOR_UNMARK (&buffer_local_symbols
);
4561 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4567 /* clear_marks (); */
4570 consing_since_gc
= 0;
4571 if (gc_cons_threshold
< 10000)
4572 gc_cons_threshold
= 10000;
4574 if (garbage_collection_messages
)
4576 if (message_p
|| minibuf_level
> 0)
4579 message1_nolog ("Garbage collecting...done");
4582 unbind_to (count
, Qnil
);
4584 total
[0] = Fcons (make_number (total_conses
),
4585 make_number (total_free_conses
));
4586 total
[1] = Fcons (make_number (total_symbols
),
4587 make_number (total_free_symbols
));
4588 total
[2] = Fcons (make_number (total_markers
),
4589 make_number (total_free_markers
));
4590 total
[3] = make_number (total_string_size
);
4591 total
[4] = make_number (total_vector_size
);
4592 total
[5] = Fcons (make_number (total_floats
),
4593 make_number (total_free_floats
));
4594 total
[6] = Fcons (make_number (total_intervals
),
4595 make_number (total_free_intervals
));
4596 total
[7] = Fcons (make_number (total_strings
),
4597 make_number (total_free_strings
));
4599 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4601 /* Compute average percentage of zombies. */
4604 for (i
= 0; i
< 7; ++i
)
4605 if (CONSP (total
[i
]))
4606 nlive
+= XFASTINT (XCAR (total
[i
]));
4608 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4609 max_live
= max (nlive
, max_live
);
4610 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4611 max_zombies
= max (nzombies
, max_zombies
);
4616 if (!NILP (Vpost_gc_hook
))
4618 int count
= inhibit_garbage_collection ();
4619 safe_run_hooks (Qpost_gc_hook
);
4620 unbind_to (count
, Qnil
);
4623 /* Accumulate statistics. */
4624 EMACS_GET_TIME (t2
);
4625 EMACS_SUB_TIME (t3
, t2
, t1
);
4626 if (FLOATP (Vgc_elapsed
))
4627 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
4629 EMACS_USECS (t3
) * 1.0e-6);
4632 return Flist (sizeof total
/ sizeof *total
, total
);
4636 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4637 only interesting objects referenced from glyphs are strings. */
4640 mark_glyph_matrix (matrix
)
4641 struct glyph_matrix
*matrix
;
4643 struct glyph_row
*row
= matrix
->rows
;
4644 struct glyph_row
*end
= row
+ matrix
->nrows
;
4646 for (; row
< end
; ++row
)
4650 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
4652 struct glyph
*glyph
= row
->glyphs
[area
];
4653 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
4655 for (; glyph
< end_glyph
; ++glyph
)
4656 if (GC_STRINGP (glyph
->object
)
4657 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
4658 mark_object (glyph
->object
);
4664 /* Mark Lisp faces in the face cache C. */
4668 struct face_cache
*c
;
4673 for (i
= 0; i
< c
->used
; ++i
)
4675 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
4679 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
4680 mark_object (face
->lface
[j
]);
4687 #ifdef HAVE_WINDOW_SYSTEM
4689 /* Mark Lisp objects in image IMG. */
4695 mark_object (img
->spec
);
4697 if (!NILP (img
->data
.lisp_val
))
4698 mark_object (img
->data
.lisp_val
);
4702 /* Mark Lisp objects in image cache of frame F. It's done this way so
4703 that we don't have to include xterm.h here. */
4706 mark_image_cache (f
)
4709 forall_images_in_image_cache (f
, mark_image
);
4712 #endif /* HAVE_X_WINDOWS */
4716 /* Mark reference to a Lisp_Object.
4717 If the object referred to has not been seen yet, recursively mark
4718 all the references contained in it. */
4720 #define LAST_MARKED_SIZE 500
4721 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
4722 int last_marked_index
;
4724 /* For debugging--call abort when we cdr down this many
4725 links of a list, in mark_object. In debugging,
4726 the call to abort will hit a breakpoint.
4727 Normally this is zero and the check never goes off. */
4728 int mark_object_loop_halt
;
4734 register Lisp_Object obj
= arg
;
4735 #ifdef GC_CHECK_MARKED_OBJECTS
4743 if (PURE_POINTER_P (XPNTR (obj
)))
4746 last_marked
[last_marked_index
++] = obj
;
4747 if (last_marked_index
== LAST_MARKED_SIZE
)
4748 last_marked_index
= 0;
4750 /* Perform some sanity checks on the objects marked here. Abort if
4751 we encounter an object we know is bogus. This increases GC time
4752 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4753 #ifdef GC_CHECK_MARKED_OBJECTS
4755 po
= (void *) XPNTR (obj
);
4757 /* Check that the object pointed to by PO is known to be a Lisp
4758 structure allocated from the heap. */
4759 #define CHECK_ALLOCATED() \
4761 m = mem_find (po); \
4766 /* Check that the object pointed to by PO is live, using predicate
4768 #define CHECK_LIVE(LIVEP) \
4770 if (!LIVEP (m, po)) \
4774 /* Check both of the above conditions. */
4775 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4777 CHECK_ALLOCATED (); \
4778 CHECK_LIVE (LIVEP); \
4781 #else /* not GC_CHECK_MARKED_OBJECTS */
4783 #define CHECK_ALLOCATED() (void) 0
4784 #define CHECK_LIVE(LIVEP) (void) 0
4785 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4787 #endif /* not GC_CHECK_MARKED_OBJECTS */
4789 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4793 register struct Lisp_String
*ptr
= XSTRING (obj
);
4794 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4795 MARK_INTERVAL_TREE (ptr
->intervals
);
4797 #ifdef GC_CHECK_STRING_BYTES
4798 /* Check that the string size recorded in the string is the
4799 same as the one recorded in the sdata structure. */
4800 CHECK_STRING_BYTES (ptr
);
4801 #endif /* GC_CHECK_STRING_BYTES */
4805 case Lisp_Vectorlike
:
4806 #ifdef GC_CHECK_MARKED_OBJECTS
4808 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4809 && po
!= &buffer_defaults
4810 && po
!= &buffer_local_symbols
)
4812 #endif /* GC_CHECK_MARKED_OBJECTS */
4814 if (GC_BUFFERP (obj
))
4816 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
4818 #ifdef GC_CHECK_MARKED_OBJECTS
4819 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4822 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4827 #endif /* GC_CHECK_MARKED_OBJECTS */
4831 else if (GC_SUBRP (obj
))
4833 else if (GC_COMPILEDP (obj
))
4834 /* We could treat this just like a vector, but it is better to
4835 save the COMPILED_CONSTANTS element for last and avoid
4838 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4839 register EMACS_INT size
= ptr
->size
;
4842 if (VECTOR_MARKED_P (ptr
))
4843 break; /* Already marked */
4845 CHECK_LIVE (live_vector_p
);
4846 VECTOR_MARK (ptr
); /* Else mark it */
4847 size
&= PSEUDOVECTOR_SIZE_MASK
;
4848 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4850 if (i
!= COMPILED_CONSTANTS
)
4851 mark_object (ptr
->contents
[i
]);
4853 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
4856 else if (GC_FRAMEP (obj
))
4858 register struct frame
*ptr
= XFRAME (obj
);
4860 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4861 VECTOR_MARK (ptr
); /* Else mark it */
4863 CHECK_LIVE (live_vector_p
);
4864 mark_object (ptr
->name
);
4865 mark_object (ptr
->icon_name
);
4866 mark_object (ptr
->title
);
4867 mark_object (ptr
->focus_frame
);
4868 mark_object (ptr
->selected_window
);
4869 mark_object (ptr
->minibuffer_window
);
4870 mark_object (ptr
->param_alist
);
4871 mark_object (ptr
->scroll_bars
);
4872 mark_object (ptr
->condemned_scroll_bars
);
4873 mark_object (ptr
->menu_bar_items
);
4874 mark_object (ptr
->face_alist
);
4875 mark_object (ptr
->menu_bar_vector
);
4876 mark_object (ptr
->buffer_predicate
);
4877 mark_object (ptr
->buffer_list
);
4878 mark_object (ptr
->menu_bar_window
);
4879 mark_object (ptr
->tool_bar_window
);
4880 mark_face_cache (ptr
->face_cache
);
4881 #ifdef HAVE_WINDOW_SYSTEM
4882 mark_image_cache (ptr
);
4883 mark_object (ptr
->tool_bar_items
);
4884 mark_object (ptr
->desired_tool_bar_string
);
4885 mark_object (ptr
->current_tool_bar_string
);
4886 #endif /* HAVE_WINDOW_SYSTEM */
4888 else if (GC_BOOL_VECTOR_P (obj
))
4890 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4892 if (VECTOR_MARKED_P (ptr
))
4893 break; /* Already marked */
4894 CHECK_LIVE (live_vector_p
);
4895 VECTOR_MARK (ptr
); /* Else mark it */
4897 else if (GC_WINDOWP (obj
))
4899 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4900 struct window
*w
= XWINDOW (obj
);
4903 /* Stop if already marked. */
4904 if (VECTOR_MARKED_P (ptr
))
4908 CHECK_LIVE (live_vector_p
);
4911 /* There is no Lisp data above The member CURRENT_MATRIX in
4912 struct WINDOW. Stop marking when that slot is reached. */
4914 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4916 mark_object (ptr
->contents
[i
]);
4918 /* Mark glyphs for leaf windows. Marking window matrices is
4919 sufficient because frame matrices use the same glyph
4921 if (NILP (w
->hchild
)
4923 && w
->current_matrix
)
4925 mark_glyph_matrix (w
->current_matrix
);
4926 mark_glyph_matrix (w
->desired_matrix
);
4929 else if (GC_HASH_TABLE_P (obj
))
4931 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4933 /* Stop if already marked. */
4934 if (VECTOR_MARKED_P (h
))
4938 CHECK_LIVE (live_vector_p
);
4941 /* Mark contents. */
4942 /* Do not mark next_free or next_weak.
4943 Being in the next_weak chain
4944 should not keep the hash table alive.
4945 No need to mark `count' since it is an integer. */
4946 mark_object (h
->test
);
4947 mark_object (h
->weak
);
4948 mark_object (h
->rehash_size
);
4949 mark_object (h
->rehash_threshold
);
4950 mark_object (h
->hash
);
4951 mark_object (h
->next
);
4952 mark_object (h
->index
);
4953 mark_object (h
->user_hash_function
);
4954 mark_object (h
->user_cmp_function
);
4956 /* If hash table is not weak, mark all keys and values.
4957 For weak tables, mark only the vector. */
4958 if (GC_NILP (h
->weak
))
4959 mark_object (h
->key_and_value
);
4961 VECTOR_MARK (XVECTOR (h
->key_and_value
));
4965 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4966 register EMACS_INT size
= ptr
->size
;
4969 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4970 CHECK_LIVE (live_vector_p
);
4971 VECTOR_MARK (ptr
); /* Else mark it */
4972 if (size
& PSEUDOVECTOR_FLAG
)
4973 size
&= PSEUDOVECTOR_SIZE_MASK
;
4975 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4976 mark_object (ptr
->contents
[i
]);
4982 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4983 struct Lisp_Symbol
*ptrx
;
4985 if (ptr
->gcmarkbit
) break;
4986 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4988 mark_object (ptr
->value
);
4989 mark_object (ptr
->function
);
4990 mark_object (ptr
->plist
);
4992 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
4993 MARK_STRING (XSTRING (ptr
->xname
));
4994 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
4996 /* Note that we do not mark the obarray of the symbol.
4997 It is safe not to do so because nothing accesses that
4998 slot except to check whether it is nil. */
5002 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5003 XSETSYMBOL (obj
, ptrx
);
5010 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5011 if (XMARKER (obj
)->gcmarkbit
)
5013 XMARKER (obj
)->gcmarkbit
= 1;
5015 switch (XMISCTYPE (obj
))
5017 case Lisp_Misc_Buffer_Local_Value
:
5018 case Lisp_Misc_Some_Buffer_Local_Value
:
5020 register struct Lisp_Buffer_Local_Value
*ptr
5021 = XBUFFER_LOCAL_VALUE (obj
);
5022 /* If the cdr is nil, avoid recursion for the car. */
5023 if (EQ (ptr
->cdr
, Qnil
))
5025 obj
= ptr
->realvalue
;
5028 mark_object (ptr
->realvalue
);
5029 mark_object (ptr
->buffer
);
5030 mark_object (ptr
->frame
);
5035 case Lisp_Misc_Marker
:
5036 /* DO NOT mark thru the marker's chain.
5037 The buffer's markers chain does not preserve markers from gc;
5038 instead, markers are removed from the chain when freed by gc. */
5041 case Lisp_Misc_Intfwd
:
5042 case Lisp_Misc_Boolfwd
:
5043 case Lisp_Misc_Objfwd
:
5044 case Lisp_Misc_Buffer_Objfwd
:
5045 case Lisp_Misc_Kboard_Objfwd
:
5046 /* Don't bother with Lisp_Buffer_Objfwd,
5047 since all markable slots in current buffer marked anyway. */
5048 /* Don't need to do Lisp_Objfwd, since the places they point
5049 are protected with staticpro. */
5052 case Lisp_Misc_Save_Value
:
5055 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5056 /* If DOGC is set, POINTER is the address of a memory
5057 area containing INTEGER potential Lisp_Objects. */
5060 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5062 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5063 mark_maybe_object (*p
);
5069 case Lisp_Misc_Overlay
:
5071 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5072 mark_object (ptr
->start
);
5073 mark_object (ptr
->end
);
5074 mark_object (ptr
->plist
);
5077 XSETMISC (obj
, ptr
->next
);
5090 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5091 if (CONS_MARKED_P (ptr
)) break;
5092 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5094 /* If the cdr is nil, avoid recursion for the car. */
5095 if (EQ (ptr
->cdr
, Qnil
))
5101 mark_object (ptr
->car
);
5104 if (cdr_count
== mark_object_loop_halt
)
5110 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5111 FLOAT_MARK (XFLOAT (obj
));
5122 #undef CHECK_ALLOCATED
5123 #undef CHECK_ALLOCATED_AND_LIVE
5126 /* Mark the pointers in a buffer structure. */
5132 register struct buffer
*buffer
= XBUFFER (buf
);
5133 register Lisp_Object
*ptr
, tmp
;
5134 Lisp_Object base_buffer
;
5136 VECTOR_MARK (buffer
);
5138 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5140 /* For now, we just don't mark the undo_list. It's done later in
5141 a special way just before the sweep phase, and after stripping
5142 some of its elements that are not needed any more. */
5144 if (buffer
->overlays_before
)
5146 XSETMISC (tmp
, buffer
->overlays_before
);
5149 if (buffer
->overlays_after
)
5151 XSETMISC (tmp
, buffer
->overlays_after
);
5155 for (ptr
= &buffer
->name
;
5156 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5160 /* If this is an indirect buffer, mark its base buffer. */
5161 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5163 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5164 mark_buffer (base_buffer
);
5169 /* Value is non-zero if OBJ will survive the current GC because it's
5170 either marked or does not need to be marked to survive. */
5178 switch (XGCTYPE (obj
))
5185 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5189 survives_p
= XMARKER (obj
)->gcmarkbit
;
5193 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5196 case Lisp_Vectorlike
:
5197 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5201 survives_p
= CONS_MARKED_P (XCONS (obj
));
5205 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5212 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5217 /* Sweep: find all structures not marked, and free them. */
5222 /* Remove or mark entries in weak hash tables.
5223 This must be done before any object is unmarked. */
5224 sweep_weak_hash_tables ();
5227 #ifdef GC_CHECK_STRING_BYTES
5228 if (!noninteractive
)
5229 check_string_bytes (1);
5232 /* Put all unmarked conses on free list */
5234 register struct cons_block
*cblk
;
5235 struct cons_block
**cprev
= &cons_block
;
5236 register int lim
= cons_block_index
;
5237 register int num_free
= 0, num_used
= 0;
5241 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5245 for (i
= 0; i
< lim
; i
++)
5246 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5249 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
5250 cons_free_list
= &cblk
->conses
[i
];
5252 cons_free_list
->car
= Vdead
;
5258 CONS_UNMARK (&cblk
->conses
[i
]);
5260 lim
= CONS_BLOCK_SIZE
;
5261 /* If this block contains only free conses and we have already
5262 seen more than two blocks worth of free conses then deallocate
5264 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5266 *cprev
= cblk
->next
;
5267 /* Unhook from the free list. */
5268 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
5269 lisp_align_free (cblk
);
5274 num_free
+= this_free
;
5275 cprev
= &cblk
->next
;
5278 total_conses
= num_used
;
5279 total_free_conses
= num_free
;
5282 /* Put all unmarked floats on free list */
5284 register struct float_block
*fblk
;
5285 struct float_block
**fprev
= &float_block
;
5286 register int lim
= float_block_index
;
5287 register int num_free
= 0, num_used
= 0;
5289 float_free_list
= 0;
5291 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5295 for (i
= 0; i
< lim
; i
++)
5296 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5299 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
5300 float_free_list
= &fblk
->floats
[i
];
5305 FLOAT_UNMARK (&fblk
->floats
[i
]);
5307 lim
= FLOAT_BLOCK_SIZE
;
5308 /* If this block contains only free floats and we have already
5309 seen more than two blocks worth of free floats then deallocate
5311 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5313 *fprev
= fblk
->next
;
5314 /* Unhook from the free list. */
5315 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5316 lisp_align_free (fblk
);
5321 num_free
+= this_free
;
5322 fprev
= &fblk
->next
;
5325 total_floats
= num_used
;
5326 total_free_floats
= num_free
;
5329 /* Put all unmarked intervals on free list */
5331 register struct interval_block
*iblk
;
5332 struct interval_block
**iprev
= &interval_block
;
5333 register int lim
= interval_block_index
;
5334 register int num_free
= 0, num_used
= 0;
5336 interval_free_list
= 0;
5338 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5343 for (i
= 0; i
< lim
; i
++)
5345 if (!iblk
->intervals
[i
].gcmarkbit
)
5347 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5348 interval_free_list
= &iblk
->intervals
[i
];
5354 iblk
->intervals
[i
].gcmarkbit
= 0;
5357 lim
= INTERVAL_BLOCK_SIZE
;
5358 /* If this block contains only free intervals and we have already
5359 seen more than two blocks worth of free intervals then
5360 deallocate this block. */
5361 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5363 *iprev
= iblk
->next
;
5364 /* Unhook from the free list. */
5365 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5367 n_interval_blocks
--;
5371 num_free
+= this_free
;
5372 iprev
= &iblk
->next
;
5375 total_intervals
= num_used
;
5376 total_free_intervals
= num_free
;
5379 /* Put all unmarked symbols on free list */
5381 register struct symbol_block
*sblk
;
5382 struct symbol_block
**sprev
= &symbol_block
;
5383 register int lim
= symbol_block_index
;
5384 register int num_free
= 0, num_used
= 0;
5386 symbol_free_list
= NULL
;
5388 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5391 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5392 struct Lisp_Symbol
*end
= sym
+ lim
;
5394 for (; sym
< end
; ++sym
)
5396 /* Check if the symbol was created during loadup. In such a case
5397 it might be pointed to by pure bytecode which we don't trace,
5398 so we conservatively assume that it is live. */
5399 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5401 if (!sym
->gcmarkbit
&& !pure_p
)
5403 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5404 symbol_free_list
= sym
;
5406 symbol_free_list
->function
= Vdead
;
5414 UNMARK_STRING (XSTRING (sym
->xname
));
5419 lim
= SYMBOL_BLOCK_SIZE
;
5420 /* If this block contains only free symbols and we have already
5421 seen more than two blocks worth of free symbols then deallocate
5423 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5425 *sprev
= sblk
->next
;
5426 /* Unhook from the free list. */
5427 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5433 num_free
+= this_free
;
5434 sprev
= &sblk
->next
;
5437 total_symbols
= num_used
;
5438 total_free_symbols
= num_free
;
5441 /* Put all unmarked misc's on free list.
5442 For a marker, first unchain it from the buffer it points into. */
5444 register struct marker_block
*mblk
;
5445 struct marker_block
**mprev
= &marker_block
;
5446 register int lim
= marker_block_index
;
5447 register int num_free
= 0, num_used
= 0;
5449 marker_free_list
= 0;
5451 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5456 for (i
= 0; i
< lim
; i
++)
5458 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5460 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5461 unchain_marker (&mblk
->markers
[i
].u_marker
);
5462 /* Set the type of the freed object to Lisp_Misc_Free.
5463 We could leave the type alone, since nobody checks it,
5464 but this might catch bugs faster. */
5465 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5466 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5467 marker_free_list
= &mblk
->markers
[i
];
5473 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5476 lim
= MARKER_BLOCK_SIZE
;
5477 /* If this block contains only free markers and we have already
5478 seen more than two blocks worth of free markers then deallocate
5480 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5482 *mprev
= mblk
->next
;
5483 /* Unhook from the free list. */
5484 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5490 num_free
+= this_free
;
5491 mprev
= &mblk
->next
;
5495 total_markers
= num_used
;
5496 total_free_markers
= num_free
;
5499 /* Free all unmarked buffers */
5501 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5504 if (!VECTOR_MARKED_P (buffer
))
5507 prev
->next
= buffer
->next
;
5509 all_buffers
= buffer
->next
;
5510 next
= buffer
->next
;
5516 VECTOR_UNMARK (buffer
);
5517 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5518 prev
= buffer
, buffer
= buffer
->next
;
5522 /* Free all unmarked vectors */
5524 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5525 total_vector_size
= 0;
5528 if (!VECTOR_MARKED_P (vector
))
5531 prev
->next
= vector
->next
;
5533 all_vectors
= vector
->next
;
5534 next
= vector
->next
;
5542 VECTOR_UNMARK (vector
);
5543 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5544 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5546 total_vector_size
+= vector
->size
;
5547 prev
= vector
, vector
= vector
->next
;
5551 #ifdef GC_CHECK_STRING_BYTES
5552 if (!noninteractive
)
5553 check_string_bytes (1);
5560 /* Debugging aids. */
5562 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5563 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
5564 This may be helpful in debugging Emacs's memory usage.
5565 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
5570 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5575 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5576 doc
: /* Return a list of counters that measure how much consing there has been.
5577 Each of these counters increments for a certain kind of object.
5578 The counters wrap around from the largest positive integer to zero.
5579 Garbage collection does not decrease them.
5580 The elements of the value are as follows:
5581 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
5582 All are in units of 1 = one object consed
5583 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
5585 MISCS include overlays, markers, and some internal types.
5586 Frames, windows, buffers, and subprocesses count as vectors
5587 (but the contents of a buffer's text do not count here). */)
5590 Lisp_Object consed
[8];
5592 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
5593 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
5594 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
5595 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
5596 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
5597 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
5598 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
5599 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
5601 return Flist (8, consed
);
5604 int suppress_checking
;
5606 die (msg
, file
, line
)
5611 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5616 /* Initialization */
5621 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5623 pure_size
= PURESIZE
;
5624 pure_bytes_used
= 0;
5625 pure_bytes_used_before_overflow
= 0;
5627 /* Initialize the list of free aligned blocks. */
5630 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5632 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5636 ignore_warnings
= 1;
5637 #ifdef DOUG_LEA_MALLOC
5638 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5639 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5640 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5650 malloc_hysteresis
= 32;
5652 malloc_hysteresis
= 0;
5655 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5657 ignore_warnings
= 0;
5659 byte_stack_list
= 0;
5661 consing_since_gc
= 0;
5662 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5663 #ifdef VIRT_ADDR_VARIES
5664 malloc_sbrk_unused
= 1<<22; /* A large number */
5665 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5666 #endif /* VIRT_ADDR_VARIES */
5673 byte_stack_list
= 0;
5675 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5676 setjmp_tested_p
= longjmps_done
= 0;
5679 Vgc_elapsed
= make_float (0.0);
5686 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5687 doc
: /* *Number of bytes of consing between garbage collections.
5688 Garbage collection can happen automatically once this many bytes have been
5689 allocated since the last garbage collection. All data types count.
5691 Garbage collection happens automatically only when `eval' is called.
5693 By binding this temporarily to a large number, you can effectively
5694 prevent garbage collection during a part of the program. */);
5696 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5697 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
5699 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5700 doc
: /* Number of cons cells that have been consed so far. */);
5702 DEFVAR_INT ("floats-consed", &floats_consed
,
5703 doc
: /* Number of floats that have been consed so far. */);
5705 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5706 doc
: /* Number of vector cells that have been consed so far. */);
5708 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5709 doc
: /* Number of symbols that have been consed so far. */);
5711 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5712 doc
: /* Number of string characters that have been consed so far. */);
5714 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5715 doc
: /* Number of miscellaneous objects that have been consed so far. */);
5717 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5718 doc
: /* Number of intervals that have been consed so far. */);
5720 DEFVAR_INT ("strings-consed", &strings_consed
,
5721 doc
: /* Number of strings that have been consed so far. */);
5723 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5724 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
5725 This means that certain objects should be allocated in shared (pure) space. */);
5727 DEFVAR_INT ("undo-limit", &undo_limit
,
5728 doc
: /* Keep no more undo information once it exceeds this size.
5729 This limit is applied when garbage collection happens.
5730 The size is counted as the number of bytes occupied,
5731 which includes both saved text and other data. */);
5734 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5735 doc
: /* Don't keep more than this much size of undo information.
5736 A previous command which pushes the undo list past this size
5737 is entirely forgotten when GC happens.
5738 The size is counted as the number of bytes occupied,
5739 which includes both saved text and other data. */);
5740 undo_strong_limit
= 30000;
5742 DEFVAR_INT ("undo-outer-limit", &undo_outer_limit
,
5743 doc
: /* Don't keep more than this much size of undo information.
5744 If the current command has produced more than this much undo information,
5745 GC discards it. This is a last-ditch limit to prevent memory overflow.
5746 The size is counted as the number of bytes occupied,
5747 which includes both saved text and other data. */);
5748 undo_outer_limit
= 300000;
5750 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5751 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
5752 garbage_collection_messages
= 0;
5754 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
5755 doc
: /* Hook run after garbage collection has finished. */);
5756 Vpost_gc_hook
= Qnil
;
5757 Qpost_gc_hook
= intern ("post-gc-hook");
5758 staticpro (&Qpost_gc_hook
);
5760 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
5761 doc
: /* Precomputed `signal' argument for memory-full error. */);
5762 /* We build this in advance because if we wait until we need it, we might
5763 not be able to allocate the memory to hold it. */
5766 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
5768 DEFVAR_LISP ("memory-full", &Vmemory_full
,
5769 doc
: /* Non-nil means we are handling a memory-full error. */);
5770 Vmemory_full
= Qnil
;
5772 staticpro (&Qgc_cons_threshold
);
5773 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5775 staticpro (&Qchar_table_extra_slots
);
5776 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5778 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
5779 doc
: /* Accumulated time elapsed in garbage collections.
5780 The time is in seconds as a floating point value. */);
5781 DEFVAR_INT ("gcs-done", &gcs_done
,
5782 doc
: /* Accumulated number of garbage collections done. */);
5787 defsubr (&Smake_byte_code
);
5788 defsubr (&Smake_list
);
5789 defsubr (&Smake_vector
);
5790 defsubr (&Smake_char_table
);
5791 defsubr (&Smake_string
);
5792 defsubr (&Smake_bool_vector
);
5793 defsubr (&Smake_symbol
);
5794 defsubr (&Smake_marker
);
5795 defsubr (&Spurecopy
);
5796 defsubr (&Sgarbage_collect
);
5797 defsubr (&Smemory_limit
);
5798 defsubr (&Smemory_use_counts
);
5800 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5801 defsubr (&Sgc_status
);
5805 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
5806 (do not change this comment) */