1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,1999,2000,01,02,03,2004
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
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
;
159 /* Number of live and free conses etc. */
161 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
162 static int total_free_conses
, total_free_markers
, total_free_symbols
;
163 static int total_free_floats
, total_floats
;
165 /* Points to memory space allocated as "spare", to be freed if we run
168 static char *spare_memory
;
170 /* Amount of spare memory to keep in reserve. */
172 #define SPARE_MEMORY (1 << 14)
174 /* Number of extra blocks malloc should get when it needs more core. */
176 static int malloc_hysteresis
;
178 /* Non-nil means defun should do purecopy on the function definition. */
180 Lisp_Object Vpurify_flag
;
182 /* Non-nil means we are handling a memory-full error. */
184 Lisp_Object Vmemory_full
;
188 /* Force it into data space! Initialize it to a nonzero value;
189 otherwise some compilers put it into BSS. */
191 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {1,};
192 #define PUREBEG (char *) pure
196 #define pure PURE_SEG_BITS /* Use shared memory segment */
197 #define PUREBEG (char *)PURE_SEG_BITS
199 #endif /* HAVE_SHM */
201 /* Pointer to the pure area, and its size. */
203 static char *purebeg
;
204 static size_t pure_size
;
206 /* Number of bytes of pure storage used before pure storage overflowed.
207 If this is non-zero, this implies that an overflow occurred. */
209 static size_t pure_bytes_used_before_overflow
;
211 /* Value is non-zero if P points into pure space. */
213 #define PURE_POINTER_P(P) \
214 (((PNTR_COMPARISON_TYPE) (P) \
215 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
216 && ((PNTR_COMPARISON_TYPE) (P) \
217 >= (PNTR_COMPARISON_TYPE) purebeg))
219 /* Index in pure at which next pure object will be allocated.. */
221 EMACS_INT pure_bytes_used
;
223 /* If nonzero, this is a warning delivered by malloc and not yet
226 char *pending_malloc_warning
;
228 /* Pre-computed signal argument for use when memory is exhausted. */
230 Lisp_Object Vmemory_signal_data
;
232 /* Maximum amount of C stack to save when a GC happens. */
234 #ifndef MAX_SAVE_STACK
235 #define MAX_SAVE_STACK 16000
238 /* Buffer in which we save a copy of the C stack at each GC. */
243 /* Non-zero means ignore malloc warnings. Set during initialization.
244 Currently not used. */
248 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
250 /* Hook run after GC has finished. */
252 Lisp_Object Vpost_gc_hook
, Qpost_gc_hook
;
254 Lisp_Object Vgc_elapsed
; /* accumulated elapsed time in GC */
255 EMACS_INT gcs_done
; /* accumulated GCs */
257 static void mark_buffer
P_ ((Lisp_Object
));
258 extern void mark_kboards
P_ ((void));
259 static void gc_sweep
P_ ((void));
260 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
261 static void mark_face_cache
P_ ((struct face_cache
*));
263 #ifdef HAVE_WINDOW_SYSTEM
264 static void mark_image
P_ ((struct image
*));
265 static void mark_image_cache
P_ ((struct frame
*));
266 #endif /* HAVE_WINDOW_SYSTEM */
268 static struct Lisp_String
*allocate_string
P_ ((void));
269 static void compact_small_strings
P_ ((void));
270 static void free_large_strings
P_ ((void));
271 static void sweep_strings
P_ ((void));
273 extern int message_enable_multibyte
;
275 /* When scanning the C stack for live Lisp objects, Emacs keeps track
276 of what memory allocated via lisp_malloc is intended for what
277 purpose. This enumeration specifies the type of memory. */
288 /* Keep the following vector-like types together, with
289 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
290 first. Or change the code of live_vector_p, for instance. */
298 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
300 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
301 #include <stdio.h> /* For fprintf. */
304 /* A unique object in pure space used to make some Lisp objects
305 on free lists recognizable in O(1). */
309 #ifdef GC_MALLOC_CHECK
311 enum mem_type allocated_mem_type
;
312 int dont_register_blocks
;
314 #endif /* GC_MALLOC_CHECK */
316 /* A node in the red-black tree describing allocated memory containing
317 Lisp data. Each such block is recorded with its start and end
318 address when it is allocated, and removed from the tree when it
321 A red-black tree is a balanced binary tree with the following
324 1. Every node is either red or black.
325 2. Every leaf is black.
326 3. If a node is red, then both of its children are black.
327 4. Every simple path from a node to a descendant leaf contains
328 the same number of black nodes.
329 5. The root is always black.
331 When nodes are inserted into the tree, or deleted from the tree,
332 the tree is "fixed" so that these properties are always true.
334 A red-black tree with N internal nodes has height at most 2
335 log(N+1). Searches, insertions and deletions are done in O(log N).
336 Please see a text book about data structures for a detailed
337 description of red-black trees. Any book worth its salt should
342 /* Children of this node. These pointers are never NULL. When there
343 is no child, the value is MEM_NIL, which points to a dummy node. */
344 struct mem_node
*left
, *right
;
346 /* The parent of this node. In the root node, this is NULL. */
347 struct mem_node
*parent
;
349 /* Start and end of allocated region. */
353 enum {MEM_BLACK
, MEM_RED
} color
;
359 /* Base address of stack. Set in main. */
361 Lisp_Object
*stack_base
;
363 /* Root of the tree describing allocated Lisp memory. */
365 static struct mem_node
*mem_root
;
367 /* Lowest and highest known address in the heap. */
369 static void *min_heap_address
, *max_heap_address
;
371 /* Sentinel node of the tree. */
373 static struct mem_node mem_z
;
374 #define MEM_NIL &mem_z
376 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
377 static struct Lisp_Vector
*allocate_vectorlike
P_ ((EMACS_INT
, enum mem_type
));
378 static void lisp_free
P_ ((POINTER_TYPE
*));
379 static void mark_stack
P_ ((void));
380 static int live_vector_p
P_ ((struct mem_node
*, void *));
381 static int live_buffer_p
P_ ((struct mem_node
*, void *));
382 static int live_string_p
P_ ((struct mem_node
*, void *));
383 static int live_cons_p
P_ ((struct mem_node
*, void *));
384 static int live_symbol_p
P_ ((struct mem_node
*, void *));
385 static int live_float_p
P_ ((struct mem_node
*, void *));
386 static int live_misc_p
P_ ((struct mem_node
*, void *));
387 static void mark_maybe_object
P_ ((Lisp_Object
));
388 static void mark_memory
P_ ((void *, void *));
389 static void mem_init
P_ ((void));
390 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
391 static void mem_insert_fixup
P_ ((struct mem_node
*));
392 static void mem_rotate_left
P_ ((struct mem_node
*));
393 static void mem_rotate_right
P_ ((struct mem_node
*));
394 static void mem_delete
P_ ((struct mem_node
*));
395 static void mem_delete_fixup
P_ ((struct mem_node
*));
396 static INLINE
struct mem_node
*mem_find
P_ ((void *));
398 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
399 static void check_gcpros
P_ ((void));
402 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
404 /* Recording what needs to be marked for gc. */
406 struct gcpro
*gcprolist
;
408 /* Addresses of staticpro'd variables. Initialize it to a nonzero
409 value; otherwise some compilers put it into BSS. */
411 #define NSTATICS 1280
412 Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
414 /* Index of next unused slot in staticvec. */
418 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
421 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
422 ALIGNMENT must be a power of 2. */
424 #define ALIGN(ptr, ALIGNMENT) \
425 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
426 & ~((ALIGNMENT) - 1)))
430 /************************************************************************
432 ************************************************************************/
434 /* Function malloc calls this if it finds we are near exhausting storage. */
440 pending_malloc_warning
= str
;
444 /* Display an already-pending malloc warning. */
447 display_malloc_warning ()
449 call3 (intern ("display-warning"),
451 build_string (pending_malloc_warning
),
452 intern ("emergency"));
453 pending_malloc_warning
= 0;
457 #ifdef DOUG_LEA_MALLOC
458 # define BYTES_USED (mallinfo ().arena)
460 # define BYTES_USED _bytes_used
464 /* Called if malloc returns zero. */
471 #ifndef SYSTEM_MALLOC
472 bytes_used_when_full
= BYTES_USED
;
475 /* The first time we get here, free the spare memory. */
482 /* This used to call error, but if we've run out of memory, we could
483 get infinite recursion trying to build the string. */
485 Fsignal (Qnil
, Vmemory_signal_data
);
489 /* Called if we can't allocate relocatable space for a buffer. */
492 buffer_memory_full ()
494 /* If buffers use the relocating allocator, no need to free
495 spare_memory, because we may have plenty of malloc space left
496 that we could get, and if we don't, the malloc that fails will
497 itself cause spare_memory to be freed. If buffers don't use the
498 relocating allocator, treat this like any other failing
507 /* This used to call error, but if we've run out of memory, we could
508 get infinite recursion trying to build the string. */
510 Fsignal (Qnil
, Vmemory_signal_data
);
514 /* Like malloc but check for no memory and block interrupt input.. */
520 register POINTER_TYPE
*val
;
523 val
= (POINTER_TYPE
*) malloc (size
);
532 /* Like realloc but check for no memory and block interrupt input.. */
535 xrealloc (block
, size
)
539 register POINTER_TYPE
*val
;
542 /* We must call malloc explicitly when BLOCK is 0, since some
543 reallocs don't do this. */
545 val
= (POINTER_TYPE
*) malloc (size
);
547 val
= (POINTER_TYPE
*) realloc (block
, size
);
550 if (!val
&& size
) memory_full ();
555 /* Like free but block interrupt input. */
567 /* Like strdup, but uses xmalloc. */
573 size_t len
= strlen (s
) + 1;
574 char *p
= (char *) xmalloc (len
);
580 /* Like malloc but used for allocating Lisp data. NBYTES is the
581 number of bytes to allocate, TYPE describes the intended use of the
582 allcated memory block (for strings, for conses, ...). */
584 static void *lisp_malloc_loser
;
586 static POINTER_TYPE
*
587 lisp_malloc (nbytes
, type
)
595 #ifdef GC_MALLOC_CHECK
596 allocated_mem_type
= type
;
599 val
= (void *) malloc (nbytes
);
602 /* If the memory just allocated cannot be addressed thru a Lisp
603 object's pointer, and it needs to be,
604 that's equivalent to running out of memory. */
605 if (val
&& type
!= MEM_TYPE_NON_LISP
)
608 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
609 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
611 lisp_malloc_loser
= val
;
618 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
619 if (val
&& type
!= MEM_TYPE_NON_LISP
)
620 mem_insert (val
, (char *) val
+ nbytes
, type
);
629 /* Free BLOCK. This must be called to free memory allocated with a
630 call to lisp_malloc. */
638 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
639 mem_delete (mem_find (block
));
644 /* Allocation of aligned blocks of memory to store Lisp data. */
645 /* The entry point is lisp_align_malloc which returns blocks of at most */
646 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
649 /* BLOCK_ALIGN has to be a power of 2. */
650 #define BLOCK_ALIGN (1 << 10)
652 /* Padding to leave at the end of a malloc'd block. This is to give
653 malloc a chance to minimize the amount of memory wasted to alignment.
654 It should be tuned to the particular malloc library used.
655 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
656 posix_memalign on the other hand would ideally prefer a value of 4
657 because otherwise, there's 1020 bytes wasted between each ablocks.
658 But testing shows that those 1020 will most of the time be efficiently
659 used by malloc to place other objects, so a value of 0 is still preferable
660 unless you have a lot of cons&floats and virtually nothing else. */
661 #define BLOCK_PADDING 0
662 #define BLOCK_BYTES \
663 (BLOCK_ALIGN - sizeof (struct aligned_block *) - BLOCK_PADDING)
665 /* Internal data structures and constants. */
667 #define ABLOCKS_SIZE 16
669 /* An aligned block of memory. */
674 char payload
[BLOCK_BYTES
];
675 struct ablock
*next_free
;
677 /* `abase' is the aligned base of the ablocks. */
678 /* It is overloaded to hold the virtual `busy' field that counts
679 the number of used ablock in the parent ablocks.
680 The first ablock has the `busy' field, the others have the `abase'
681 field. To tell the difference, we assume that pointers will have
682 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
683 is used to tell whether the real base of the parent ablocks is `abase'
684 (if not, the word before the first ablock holds a pointer to the
686 struct ablocks
*abase
;
687 /* The padding of all but the last ablock is unused. The padding of
688 the last ablock in an ablocks is not allocated. */
690 char padding
[BLOCK_PADDING
];
694 /* A bunch of consecutive aligned blocks. */
697 struct ablock blocks
[ABLOCKS_SIZE
];
700 /* Size of the block requested from malloc or memalign. */
701 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
703 #define ABLOCK_ABASE(block) \
704 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
705 ? (struct ablocks *)(block) \
708 /* Virtual `busy' field. */
709 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
711 /* Pointer to the (not necessarily aligned) malloc block. */
712 #ifdef HAVE_POSIX_MEMALIGN
713 #define ABLOCKS_BASE(abase) (abase)
715 #define ABLOCKS_BASE(abase) \
716 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
719 /* The list of free ablock. */
720 static struct ablock
*free_ablock
;
722 /* Allocate an aligned block of nbytes.
723 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
724 smaller or equal to BLOCK_BYTES. */
725 static POINTER_TYPE
*
726 lisp_align_malloc (nbytes
, type
)
731 struct ablocks
*abase
;
733 eassert (nbytes
<= BLOCK_BYTES
);
737 #ifdef GC_MALLOC_CHECK
738 allocated_mem_type
= type
;
744 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
746 #ifdef DOUG_LEA_MALLOC
747 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
748 because mapped region contents are not preserved in
750 mallopt (M_MMAP_MAX
, 0);
753 #ifdef HAVE_POSIX_MEMALIGN
755 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
756 abase
= err
? (base
= NULL
) : base
;
759 base
= malloc (ABLOCKS_BYTES
);
760 abase
= ALIGN (base
, BLOCK_ALIGN
);
768 aligned
= (base
== abase
);
770 ((void**)abase
)[-1] = base
;
772 #ifdef DOUG_LEA_MALLOC
773 /* Back to a reasonable maximum of mmap'ed areas. */
774 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
778 /* If the memory just allocated cannot be addressed thru a Lisp
779 object's pointer, and it needs to be, that's equivalent to
780 running out of memory. */
781 if (type
!= MEM_TYPE_NON_LISP
)
784 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
786 if ((char *) XCONS (tem
) != end
)
788 lisp_malloc_loser
= base
;
796 /* Initialize the blocks and put them on the free list.
797 Is `base' was not properly aligned, we can't use the last block. */
798 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
800 abase
->blocks
[i
].abase
= abase
;
801 abase
->blocks
[i
].x
.next_free
= free_ablock
;
802 free_ablock
= &abase
->blocks
[i
];
804 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
806 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
807 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
808 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
809 eassert (ABLOCKS_BASE (abase
) == base
);
810 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
813 abase
= ABLOCK_ABASE (free_ablock
);
814 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
816 free_ablock
= free_ablock
->x
.next_free
;
818 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
819 if (val
&& type
!= MEM_TYPE_NON_LISP
)
820 mem_insert (val
, (char *) val
+ nbytes
, type
);
827 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
832 lisp_align_free (block
)
835 struct ablock
*ablock
= block
;
836 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
839 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
840 mem_delete (mem_find (block
));
842 /* Put on free list. */
843 ablock
->x
.next_free
= free_ablock
;
844 free_ablock
= ablock
;
845 /* Update busy count. */
846 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
848 if (2 > (long) ABLOCKS_BUSY (abase
))
849 { /* All the blocks are free. */
850 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
851 struct ablock
**tem
= &free_ablock
;
852 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
856 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
859 *tem
= (*tem
)->x
.next_free
;
862 tem
= &(*tem
)->x
.next_free
;
864 eassert ((aligned
& 1) == aligned
);
865 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
866 free (ABLOCKS_BASE (abase
));
871 /* Return a new buffer structure allocated from the heap with
872 a call to lisp_malloc. */
878 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
884 /* Arranging to disable input signals while we're in malloc.
886 This only works with GNU malloc. To help out systems which can't
887 use GNU malloc, all the calls to malloc, realloc, and free
888 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
889 pairs; unfortunately, we have no idea what C library functions
890 might call malloc, so we can't really protect them unless you're
891 using GNU malloc. Fortunately, most of the major operating systems
892 can use GNU malloc. */
894 #ifndef SYSTEM_MALLOC
895 #ifndef DOUG_LEA_MALLOC
896 extern void * (*__malloc_hook
) P_ ((size_t));
897 extern void * (*__realloc_hook
) P_ ((void *, size_t));
898 extern void (*__free_hook
) P_ ((void *));
899 /* Else declared in malloc.h, perhaps with an extra arg. */
900 #endif /* DOUG_LEA_MALLOC */
901 static void * (*old_malloc_hook
) ();
902 static void * (*old_realloc_hook
) ();
903 static void (*old_free_hook
) ();
905 /* This function is used as the hook for free to call. */
908 emacs_blocked_free (ptr
)
913 #ifdef GC_MALLOC_CHECK
919 if (m
== MEM_NIL
|| m
->start
!= ptr
)
922 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
927 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
931 #endif /* GC_MALLOC_CHECK */
933 __free_hook
= old_free_hook
;
936 /* If we released our reserve (due to running out of memory),
937 and we have a fair amount free once again,
938 try to set aside another reserve in case we run out once more. */
939 if (spare_memory
== 0
940 /* Verify there is enough space that even with the malloc
941 hysteresis this call won't run out again.
942 The code here is correct as long as SPARE_MEMORY
943 is substantially larger than the block size malloc uses. */
944 && (bytes_used_when_full
945 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
946 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
948 __free_hook
= emacs_blocked_free
;
953 /* If we released our reserve (due to running out of memory),
954 and we have a fair amount free once again,
955 try to set aside another reserve in case we run out once more.
957 This is called when a relocatable block is freed in ralloc.c. */
960 refill_memory_reserve ()
962 if (spare_memory
== 0)
963 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
967 /* This function is the malloc hook that Emacs uses. */
970 emacs_blocked_malloc (size
)
976 __malloc_hook
= old_malloc_hook
;
977 #ifdef DOUG_LEA_MALLOC
978 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
980 __malloc_extra_blocks
= malloc_hysteresis
;
983 value
= (void *) malloc (size
);
985 #ifdef GC_MALLOC_CHECK
987 struct mem_node
*m
= mem_find (value
);
990 fprintf (stderr
, "Malloc returned %p which is already in use\n",
992 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
993 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
998 if (!dont_register_blocks
)
1000 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1001 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1004 #endif /* GC_MALLOC_CHECK */
1006 __malloc_hook
= emacs_blocked_malloc
;
1009 /* fprintf (stderr, "%p malloc\n", value); */
1014 /* This function is the realloc hook that Emacs uses. */
1017 emacs_blocked_realloc (ptr
, size
)
1024 __realloc_hook
= old_realloc_hook
;
1026 #ifdef GC_MALLOC_CHECK
1029 struct mem_node
*m
= mem_find (ptr
);
1030 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1033 "Realloc of %p which wasn't allocated with malloc\n",
1041 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1043 /* Prevent malloc from registering blocks. */
1044 dont_register_blocks
= 1;
1045 #endif /* GC_MALLOC_CHECK */
1047 value
= (void *) realloc (ptr
, size
);
1049 #ifdef GC_MALLOC_CHECK
1050 dont_register_blocks
= 0;
1053 struct mem_node
*m
= mem_find (value
);
1056 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1060 /* Can't handle zero size regions in the red-black tree. */
1061 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1064 /* fprintf (stderr, "%p <- realloc\n", value); */
1065 #endif /* GC_MALLOC_CHECK */
1067 __realloc_hook
= emacs_blocked_realloc
;
1074 /* Called from main to set up malloc to use our hooks. */
1077 uninterrupt_malloc ()
1079 if (__free_hook
!= emacs_blocked_free
)
1080 old_free_hook
= __free_hook
;
1081 __free_hook
= emacs_blocked_free
;
1083 if (__malloc_hook
!= emacs_blocked_malloc
)
1084 old_malloc_hook
= __malloc_hook
;
1085 __malloc_hook
= emacs_blocked_malloc
;
1087 if (__realloc_hook
!= emacs_blocked_realloc
)
1088 old_realloc_hook
= __realloc_hook
;
1089 __realloc_hook
= emacs_blocked_realloc
;
1092 #endif /* not SYSTEM_MALLOC */
1096 /***********************************************************************
1098 ***********************************************************************/
1100 /* Number of intervals allocated in an interval_block structure.
1101 The 1020 is 1024 minus malloc overhead. */
1103 #define INTERVAL_BLOCK_SIZE \
1104 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1106 /* Intervals are allocated in chunks in form of an interval_block
1109 struct interval_block
1111 /* Place `intervals' first, to preserve alignment. */
1112 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1113 struct interval_block
*next
;
1116 /* Current interval block. Its `next' pointer points to older
1119 struct interval_block
*interval_block
;
1121 /* Index in interval_block above of the next unused interval
1124 static int interval_block_index
;
1126 /* Number of free and live intervals. */
1128 static int total_free_intervals
, total_intervals
;
1130 /* List of free intervals. */
1132 INTERVAL interval_free_list
;
1134 /* Total number of interval blocks now in use. */
1136 int n_interval_blocks
;
1139 /* Initialize interval allocation. */
1144 interval_block
= NULL
;
1145 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1146 interval_free_list
= 0;
1147 n_interval_blocks
= 0;
1151 /* Return a new interval. */
1158 if (interval_free_list
)
1160 val
= interval_free_list
;
1161 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1165 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1167 register struct interval_block
*newi
;
1169 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1172 newi
->next
= interval_block
;
1173 interval_block
= newi
;
1174 interval_block_index
= 0;
1175 n_interval_blocks
++;
1177 val
= &interval_block
->intervals
[interval_block_index
++];
1179 consing_since_gc
+= sizeof (struct interval
);
1181 RESET_INTERVAL (val
);
1187 /* Mark Lisp objects in interval I. */
1190 mark_interval (i
, dummy
)
1191 register INTERVAL i
;
1194 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1196 mark_object (i
->plist
);
1200 /* Mark the interval tree rooted in TREE. Don't call this directly;
1201 use the macro MARK_INTERVAL_TREE instead. */
1204 mark_interval_tree (tree
)
1205 register INTERVAL tree
;
1207 /* No need to test if this tree has been marked already; this
1208 function is always called through the MARK_INTERVAL_TREE macro,
1209 which takes care of that. */
1211 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1215 /* Mark the interval tree rooted in I. */
1217 #define MARK_INTERVAL_TREE(i) \
1219 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1220 mark_interval_tree (i); \
1224 #define UNMARK_BALANCE_INTERVALS(i) \
1226 if (! NULL_INTERVAL_P (i)) \
1227 (i) = balance_intervals (i); \
1231 /* Number support. If NO_UNION_TYPE isn't in effect, we
1232 can't create number objects in macros. */
1240 obj
.s
.type
= Lisp_Int
;
1245 /***********************************************************************
1247 ***********************************************************************/
1249 /* Lisp_Strings are allocated in string_block structures. When a new
1250 string_block is allocated, all the Lisp_Strings it contains are
1251 added to a free-list string_free_list. When a new Lisp_String is
1252 needed, it is taken from that list. During the sweep phase of GC,
1253 string_blocks that are entirely free are freed, except two which
1256 String data is allocated from sblock structures. Strings larger
1257 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1258 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1260 Sblocks consist internally of sdata structures, one for each
1261 Lisp_String. The sdata structure points to the Lisp_String it
1262 belongs to. The Lisp_String points back to the `u.data' member of
1263 its sdata structure.
1265 When a Lisp_String is freed during GC, it is put back on
1266 string_free_list, and its `data' member and its sdata's `string'
1267 pointer is set to null. The size of the string is recorded in the
1268 `u.nbytes' member of the sdata. So, sdata structures that are no
1269 longer used, can be easily recognized, and it's easy to compact the
1270 sblocks of small strings which we do in compact_small_strings. */
1272 /* Size in bytes of an sblock structure used for small strings. This
1273 is 8192 minus malloc overhead. */
1275 #define SBLOCK_SIZE 8188
1277 /* Strings larger than this are considered large strings. String data
1278 for large strings is allocated from individual sblocks. */
1280 #define LARGE_STRING_BYTES 1024
1282 /* Structure describing string memory sub-allocated from an sblock.
1283 This is where the contents of Lisp strings are stored. */
1287 /* Back-pointer to the string this sdata belongs to. If null, this
1288 structure is free, and the NBYTES member of the union below
1289 contains the string's byte size (the same value that STRING_BYTES
1290 would return if STRING were non-null). If non-null, STRING_BYTES
1291 (STRING) is the size of the data, and DATA contains the string's
1293 struct Lisp_String
*string
;
1295 #ifdef GC_CHECK_STRING_BYTES
1298 unsigned char data
[1];
1300 #define SDATA_NBYTES(S) (S)->nbytes
1301 #define SDATA_DATA(S) (S)->data
1303 #else /* not GC_CHECK_STRING_BYTES */
1307 /* When STRING in non-null. */
1308 unsigned char data
[1];
1310 /* When STRING is null. */
1315 #define SDATA_NBYTES(S) (S)->u.nbytes
1316 #define SDATA_DATA(S) (S)->u.data
1318 #endif /* not GC_CHECK_STRING_BYTES */
1322 /* Structure describing a block of memory which is sub-allocated to
1323 obtain string data memory for strings. Blocks for small strings
1324 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1325 as large as needed. */
1330 struct sblock
*next
;
1332 /* Pointer to the next free sdata block. This points past the end
1333 of the sblock if there isn't any space left in this block. */
1334 struct sdata
*next_free
;
1336 /* Start of data. */
1337 struct sdata first_data
;
1340 /* Number of Lisp strings in a string_block structure. The 1020 is
1341 1024 minus malloc overhead. */
1343 #define STRING_BLOCK_SIZE \
1344 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1346 /* Structure describing a block from which Lisp_String structures
1351 /* Place `strings' first, to preserve alignment. */
1352 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1353 struct string_block
*next
;
1356 /* Head and tail of the list of sblock structures holding Lisp string
1357 data. We always allocate from current_sblock. The NEXT pointers
1358 in the sblock structures go from oldest_sblock to current_sblock. */
1360 static struct sblock
*oldest_sblock
, *current_sblock
;
1362 /* List of sblocks for large strings. */
1364 static struct sblock
*large_sblocks
;
1366 /* List of string_block structures, and how many there are. */
1368 static struct string_block
*string_blocks
;
1369 static int n_string_blocks
;
1371 /* Free-list of Lisp_Strings. */
1373 static struct Lisp_String
*string_free_list
;
1375 /* Number of live and free Lisp_Strings. */
1377 static int total_strings
, total_free_strings
;
1379 /* Number of bytes used by live strings. */
1381 static int total_string_size
;
1383 /* Given a pointer to a Lisp_String S which is on the free-list
1384 string_free_list, return a pointer to its successor in the
1387 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1389 /* Return a pointer to the sdata structure belonging to Lisp string S.
1390 S must be live, i.e. S->data must not be null. S->data is actually
1391 a pointer to the `u.data' member of its sdata structure; the
1392 structure starts at a constant offset in front of that. */
1394 #ifdef GC_CHECK_STRING_BYTES
1396 #define SDATA_OF_STRING(S) \
1397 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1398 - sizeof (EMACS_INT)))
1400 #else /* not GC_CHECK_STRING_BYTES */
1402 #define SDATA_OF_STRING(S) \
1403 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1405 #endif /* not GC_CHECK_STRING_BYTES */
1407 /* Value is the size of an sdata structure large enough to hold NBYTES
1408 bytes of string data. The value returned includes a terminating
1409 NUL byte, the size of the sdata structure, and padding. */
1411 #ifdef GC_CHECK_STRING_BYTES
1413 #define SDATA_SIZE(NBYTES) \
1414 ((sizeof (struct Lisp_String *) \
1416 + sizeof (EMACS_INT) \
1417 + sizeof (EMACS_INT) - 1) \
1418 & ~(sizeof (EMACS_INT) - 1))
1420 #else /* not GC_CHECK_STRING_BYTES */
1422 #define SDATA_SIZE(NBYTES) \
1423 ((sizeof (struct Lisp_String *) \
1425 + sizeof (EMACS_INT) - 1) \
1426 & ~(sizeof (EMACS_INT) - 1))
1428 #endif /* not GC_CHECK_STRING_BYTES */
1430 /* Initialize string allocation. Called from init_alloc_once. */
1435 total_strings
= total_free_strings
= total_string_size
= 0;
1436 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1437 string_blocks
= NULL
;
1438 n_string_blocks
= 0;
1439 string_free_list
= NULL
;
1443 #ifdef GC_CHECK_STRING_BYTES
1445 static int check_string_bytes_count
;
1447 void check_string_bytes
P_ ((int));
1448 void check_sblock
P_ ((struct sblock
*));
1450 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1453 /* Like GC_STRING_BYTES, but with debugging check. */
1457 struct Lisp_String
*s
;
1459 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1460 if (!PURE_POINTER_P (s
)
1462 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1467 /* Check validity of Lisp strings' string_bytes member in B. */
1473 struct sdata
*from
, *end
, *from_end
;
1477 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1479 /* Compute the next FROM here because copying below may
1480 overwrite data we need to compute it. */
1483 /* Check that the string size recorded in the string is the
1484 same as the one recorded in the sdata structure. */
1486 CHECK_STRING_BYTES (from
->string
);
1489 nbytes
= GC_STRING_BYTES (from
->string
);
1491 nbytes
= SDATA_NBYTES (from
);
1493 nbytes
= SDATA_SIZE (nbytes
);
1494 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1499 /* Check validity of Lisp strings' string_bytes member. ALL_P
1500 non-zero means check all strings, otherwise check only most
1501 recently allocated strings. Used for hunting a bug. */
1504 check_string_bytes (all_p
)
1511 for (b
= large_sblocks
; b
; b
= b
->next
)
1513 struct Lisp_String
*s
= b
->first_data
.string
;
1515 CHECK_STRING_BYTES (s
);
1518 for (b
= oldest_sblock
; b
; b
= b
->next
)
1522 check_sblock (current_sblock
);
1525 #endif /* GC_CHECK_STRING_BYTES */
1528 /* Return a new Lisp_String. */
1530 static struct Lisp_String
*
1533 struct Lisp_String
*s
;
1535 /* If the free-list is empty, allocate a new string_block, and
1536 add all the Lisp_Strings in it to the free-list. */
1537 if (string_free_list
== NULL
)
1539 struct string_block
*b
;
1542 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1543 bzero (b
, sizeof *b
);
1544 b
->next
= string_blocks
;
1548 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1551 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1552 string_free_list
= s
;
1555 total_free_strings
+= STRING_BLOCK_SIZE
;
1558 /* Pop a Lisp_String off the free-list. */
1559 s
= string_free_list
;
1560 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1562 /* Probably not strictly necessary, but play it safe. */
1563 bzero (s
, sizeof *s
);
1565 --total_free_strings
;
1568 consing_since_gc
+= sizeof *s
;
1570 #ifdef GC_CHECK_STRING_BYTES
1577 if (++check_string_bytes_count
== 200)
1579 check_string_bytes_count
= 0;
1580 check_string_bytes (1);
1583 check_string_bytes (0);
1585 #endif /* GC_CHECK_STRING_BYTES */
1591 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1592 plus a NUL byte at the end. Allocate an sdata structure for S, and
1593 set S->data to its `u.data' member. Store a NUL byte at the end of
1594 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1595 S->data if it was initially non-null. */
1598 allocate_string_data (s
, nchars
, nbytes
)
1599 struct Lisp_String
*s
;
1602 struct sdata
*data
, *old_data
;
1604 int needed
, old_nbytes
;
1606 /* Determine the number of bytes needed to store NBYTES bytes
1608 needed
= SDATA_SIZE (nbytes
);
1610 if (nbytes
> LARGE_STRING_BYTES
)
1612 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1614 #ifdef DOUG_LEA_MALLOC
1615 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1616 because mapped region contents are not preserved in
1619 In case you think of allowing it in a dumped Emacs at the
1620 cost of not being able to re-dump, there's another reason:
1621 mmap'ed data typically have an address towards the top of the
1622 address space, which won't fit into an EMACS_INT (at least on
1623 32-bit systems with the current tagging scheme). --fx */
1624 mallopt (M_MMAP_MAX
, 0);
1627 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1629 #ifdef DOUG_LEA_MALLOC
1630 /* Back to a reasonable maximum of mmap'ed areas. */
1631 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1634 b
->next_free
= &b
->first_data
;
1635 b
->first_data
.string
= NULL
;
1636 b
->next
= large_sblocks
;
1639 else if (current_sblock
== NULL
1640 || (((char *) current_sblock
+ SBLOCK_SIZE
1641 - (char *) current_sblock
->next_free
)
1644 /* Not enough room in the current sblock. */
1645 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1646 b
->next_free
= &b
->first_data
;
1647 b
->first_data
.string
= NULL
;
1651 current_sblock
->next
= b
;
1659 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1660 old_nbytes
= GC_STRING_BYTES (s
);
1662 data
= b
->next_free
;
1664 s
->data
= SDATA_DATA (data
);
1665 #ifdef GC_CHECK_STRING_BYTES
1666 SDATA_NBYTES (data
) = nbytes
;
1669 s
->size_byte
= nbytes
;
1670 s
->data
[nbytes
] = '\0';
1671 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1673 /* If S had already data assigned, mark that as free by setting its
1674 string back-pointer to null, and recording the size of the data
1678 SDATA_NBYTES (old_data
) = old_nbytes
;
1679 old_data
->string
= NULL
;
1682 consing_since_gc
+= needed
;
1686 /* Sweep and compact strings. */
1691 struct string_block
*b
, *next
;
1692 struct string_block
*live_blocks
= NULL
;
1694 string_free_list
= NULL
;
1695 total_strings
= total_free_strings
= 0;
1696 total_string_size
= 0;
1698 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1699 for (b
= string_blocks
; b
; b
= next
)
1702 struct Lisp_String
*free_list_before
= string_free_list
;
1706 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1708 struct Lisp_String
*s
= b
->strings
+ i
;
1712 /* String was not on free-list before. */
1713 if (STRING_MARKED_P (s
))
1715 /* String is live; unmark it and its intervals. */
1718 if (!NULL_INTERVAL_P (s
->intervals
))
1719 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1722 total_string_size
+= STRING_BYTES (s
);
1726 /* String is dead. Put it on the free-list. */
1727 struct sdata
*data
= SDATA_OF_STRING (s
);
1729 /* Save the size of S in its sdata so that we know
1730 how large that is. Reset the sdata's string
1731 back-pointer so that we know it's free. */
1732 #ifdef GC_CHECK_STRING_BYTES
1733 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1736 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1738 data
->string
= NULL
;
1740 /* Reset the strings's `data' member so that we
1744 /* Put the string on the free-list. */
1745 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1746 string_free_list
= s
;
1752 /* S was on the free-list before. Put it there again. */
1753 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1754 string_free_list
= s
;
1759 /* Free blocks that contain free Lisp_Strings only, except
1760 the first two of them. */
1761 if (nfree
== STRING_BLOCK_SIZE
1762 && total_free_strings
> STRING_BLOCK_SIZE
)
1766 string_free_list
= free_list_before
;
1770 total_free_strings
+= nfree
;
1771 b
->next
= live_blocks
;
1776 string_blocks
= live_blocks
;
1777 free_large_strings ();
1778 compact_small_strings ();
1782 /* Free dead large strings. */
1785 free_large_strings ()
1787 struct sblock
*b
, *next
;
1788 struct sblock
*live_blocks
= NULL
;
1790 for (b
= large_sblocks
; b
; b
= next
)
1794 if (b
->first_data
.string
== NULL
)
1798 b
->next
= live_blocks
;
1803 large_sblocks
= live_blocks
;
1807 /* Compact data of small strings. Free sblocks that don't contain
1808 data of live strings after compaction. */
1811 compact_small_strings ()
1813 struct sblock
*b
, *tb
, *next
;
1814 struct sdata
*from
, *to
, *end
, *tb_end
;
1815 struct sdata
*to_end
, *from_end
;
1817 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1818 to, and TB_END is the end of TB. */
1820 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1821 to
= &tb
->first_data
;
1823 /* Step through the blocks from the oldest to the youngest. We
1824 expect that old blocks will stabilize over time, so that less
1825 copying will happen this way. */
1826 for (b
= oldest_sblock
; b
; b
= b
->next
)
1829 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1831 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1833 /* Compute the next FROM here because copying below may
1834 overwrite data we need to compute it. */
1837 #ifdef GC_CHECK_STRING_BYTES
1838 /* Check that the string size recorded in the string is the
1839 same as the one recorded in the sdata structure. */
1841 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1843 #endif /* GC_CHECK_STRING_BYTES */
1846 nbytes
= GC_STRING_BYTES (from
->string
);
1848 nbytes
= SDATA_NBYTES (from
);
1850 nbytes
= SDATA_SIZE (nbytes
);
1851 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1853 /* FROM->string non-null means it's alive. Copy its data. */
1856 /* If TB is full, proceed with the next sblock. */
1857 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1858 if (to_end
> tb_end
)
1862 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1863 to
= &tb
->first_data
;
1864 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1867 /* Copy, and update the string's `data' pointer. */
1870 xassert (tb
!= b
|| to
<= from
);
1871 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1872 to
->string
->data
= SDATA_DATA (to
);
1875 /* Advance past the sdata we copied to. */
1881 /* The rest of the sblocks following TB don't contain live data, so
1882 we can free them. */
1883 for (b
= tb
->next
; b
; b
= next
)
1891 current_sblock
= tb
;
1895 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1896 doc
: /* Return a newly created string of length LENGTH, with each element being INIT.
1897 Both LENGTH and INIT must be numbers. */)
1899 Lisp_Object length
, init
;
1901 register Lisp_Object val
;
1902 register unsigned char *p
, *end
;
1905 CHECK_NATNUM (length
);
1906 CHECK_NUMBER (init
);
1909 if (SINGLE_BYTE_CHAR_P (c
))
1911 nbytes
= XINT (length
);
1912 val
= make_uninit_string (nbytes
);
1914 end
= p
+ SCHARS (val
);
1920 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1921 int len
= CHAR_STRING (c
, str
);
1923 nbytes
= len
* XINT (length
);
1924 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1929 bcopy (str
, p
, len
);
1939 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1940 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
1941 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
1943 Lisp_Object length
, init
;
1945 register Lisp_Object val
;
1946 struct Lisp_Bool_Vector
*p
;
1948 int length_in_chars
, length_in_elts
, bits_per_value
;
1950 CHECK_NATNUM (length
);
1952 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
1954 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1955 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
1956 / BOOL_VECTOR_BITS_PER_CHAR
);
1958 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1959 slot `size' of the struct Lisp_Bool_Vector. */
1960 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1961 p
= XBOOL_VECTOR (val
);
1963 /* Get rid of any bits that would cause confusion. */
1965 XSETBOOL_VECTOR (val
, p
);
1966 p
->size
= XFASTINT (length
);
1968 real_init
= (NILP (init
) ? 0 : -1);
1969 for (i
= 0; i
< length_in_chars
; i
++)
1970 p
->data
[i
] = real_init
;
1972 /* Clear the extraneous bits in the last byte. */
1973 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
1974 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1975 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
1981 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1982 of characters from the contents. This string may be unibyte or
1983 multibyte, depending on the contents. */
1986 make_string (contents
, nbytes
)
1987 const char *contents
;
1990 register Lisp_Object val
;
1991 int nchars
, multibyte_nbytes
;
1993 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1994 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1995 /* CONTENTS contains no multibyte sequences or contains an invalid
1996 multibyte sequence. We must make unibyte string. */
1997 val
= make_unibyte_string (contents
, nbytes
);
1999 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2004 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2007 make_unibyte_string (contents
, length
)
2008 const char *contents
;
2011 register Lisp_Object val
;
2012 val
= make_uninit_string (length
);
2013 bcopy (contents
, SDATA (val
), length
);
2014 STRING_SET_UNIBYTE (val
);
2019 /* Make a multibyte string from NCHARS characters occupying NBYTES
2020 bytes at CONTENTS. */
2023 make_multibyte_string (contents
, nchars
, nbytes
)
2024 const char *contents
;
2027 register Lisp_Object val
;
2028 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2029 bcopy (contents
, SDATA (val
), nbytes
);
2034 /* Make a string from NCHARS characters occupying NBYTES bytes at
2035 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2038 make_string_from_bytes (contents
, nchars
, nbytes
)
2039 const char *contents
;
2042 register Lisp_Object val
;
2043 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2044 bcopy (contents
, SDATA (val
), nbytes
);
2045 if (SBYTES (val
) == SCHARS (val
))
2046 STRING_SET_UNIBYTE (val
);
2051 /* Make a string from NCHARS characters occupying NBYTES bytes at
2052 CONTENTS. The argument MULTIBYTE controls whether to label the
2053 string as multibyte. If NCHARS is negative, it counts the number of
2054 characters by itself. */
2057 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2058 const char *contents
;
2062 register Lisp_Object val
;
2067 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2071 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2072 bcopy (contents
, SDATA (val
), nbytes
);
2074 STRING_SET_UNIBYTE (val
);
2079 /* Make a string from the data at STR, treating it as multibyte if the
2086 return make_string (str
, strlen (str
));
2090 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2091 occupying LENGTH bytes. */
2094 make_uninit_string (length
)
2098 val
= make_uninit_multibyte_string (length
, length
);
2099 STRING_SET_UNIBYTE (val
);
2104 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2105 which occupy NBYTES bytes. */
2108 make_uninit_multibyte_string (nchars
, nbytes
)
2112 struct Lisp_String
*s
;
2117 s
= allocate_string ();
2118 allocate_string_data (s
, nchars
, nbytes
);
2119 XSETSTRING (string
, s
);
2120 string_chars_consed
+= nbytes
;
2126 /***********************************************************************
2128 ***********************************************************************/
2130 /* We store float cells inside of float_blocks, allocating a new
2131 float_block with malloc whenever necessary. Float cells reclaimed
2132 by GC are put on a free list to be reallocated before allocating
2133 any new float cells from the latest float_block. */
2135 #define FLOAT_BLOCK_SIZE \
2136 (((BLOCK_BYTES - sizeof (struct float_block *) \
2137 /* The compiler might add padding at the end. */ \
2138 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2139 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2141 #define GETMARKBIT(block,n) \
2142 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2143 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2146 #define SETMARKBIT(block,n) \
2147 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2148 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2150 #define UNSETMARKBIT(block,n) \
2151 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2152 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2154 #define FLOAT_BLOCK(fptr) \
2155 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2157 #define FLOAT_INDEX(fptr) \
2158 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2162 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2163 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2164 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2165 struct float_block
*next
;
2168 #define FLOAT_MARKED_P(fptr) \
2169 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2171 #define FLOAT_MARK(fptr) \
2172 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2174 #define FLOAT_UNMARK(fptr) \
2175 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2177 /* Current float_block. */
2179 struct float_block
*float_block
;
2181 /* Index of first unused Lisp_Float in the current float_block. */
2183 int float_block_index
;
2185 /* Total number of float blocks now in use. */
2189 /* Free-list of Lisp_Floats. */
2191 struct Lisp_Float
*float_free_list
;
2194 /* Initialize float allocation. */
2200 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2201 float_free_list
= 0;
2206 /* Explicitly free a float cell by putting it on the free-list. */
2210 struct Lisp_Float
*ptr
;
2212 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
2213 float_free_list
= ptr
;
2217 /* Return a new float object with value FLOAT_VALUE. */
2220 make_float (float_value
)
2223 register Lisp_Object val
;
2225 if (float_free_list
)
2227 /* We use the data field for chaining the free list
2228 so that we won't use the same field that has the mark bit. */
2229 XSETFLOAT (val
, float_free_list
);
2230 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
2234 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2236 register struct float_block
*new;
2238 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2240 new->next
= float_block
;
2241 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2243 float_block_index
= 0;
2246 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2247 float_block_index
++;
2250 XFLOAT_DATA (val
) = float_value
;
2251 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2252 consing_since_gc
+= sizeof (struct Lisp_Float
);
2259 /***********************************************************************
2261 ***********************************************************************/
2263 /* We store cons cells inside of cons_blocks, allocating a new
2264 cons_block with malloc whenever necessary. Cons cells reclaimed by
2265 GC are put on a free list to be reallocated before allocating
2266 any new cons cells from the latest cons_block. */
2268 #define CONS_BLOCK_SIZE \
2269 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2270 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2272 #define CONS_BLOCK(fptr) \
2273 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2275 #define CONS_INDEX(fptr) \
2276 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2280 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2281 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2282 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2283 struct cons_block
*next
;
2286 #define CONS_MARKED_P(fptr) \
2287 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2289 #define CONS_MARK(fptr) \
2290 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2292 #define CONS_UNMARK(fptr) \
2293 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2295 /* Current cons_block. */
2297 struct cons_block
*cons_block
;
2299 /* Index of first unused Lisp_Cons in the current block. */
2301 int cons_block_index
;
2303 /* Free-list of Lisp_Cons structures. */
2305 struct Lisp_Cons
*cons_free_list
;
2307 /* Total number of cons blocks now in use. */
2312 /* Initialize cons allocation. */
2318 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2324 /* Explicitly free a cons cell by putting it on the free-list. */
2328 struct Lisp_Cons
*ptr
;
2330 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2334 cons_free_list
= ptr
;
2338 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2339 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2341 Lisp_Object car
, cdr
;
2343 register Lisp_Object val
;
2347 /* We use the cdr for chaining the free list
2348 so that we won't use the same field that has the mark bit. */
2349 XSETCONS (val
, cons_free_list
);
2350 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2354 if (cons_block_index
== CONS_BLOCK_SIZE
)
2356 register struct cons_block
*new;
2357 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2359 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2360 new->next
= cons_block
;
2362 cons_block_index
= 0;
2365 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2371 eassert (!CONS_MARKED_P (XCONS (val
)));
2372 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2373 cons_cells_consed
++;
2378 /* Make a list of 2, 3, 4 or 5 specified objects. */
2382 Lisp_Object arg1
, arg2
;
2384 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2389 list3 (arg1
, arg2
, arg3
)
2390 Lisp_Object arg1
, arg2
, arg3
;
2392 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2397 list4 (arg1
, arg2
, arg3
, arg4
)
2398 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2400 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2405 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2406 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2408 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2409 Fcons (arg5
, Qnil
)))));
2413 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2414 doc
: /* Return a newly created list with specified arguments as elements.
2415 Any number of arguments, even zero arguments, are allowed.
2416 usage: (list &rest OBJECTS) */)
2419 register Lisp_Object
*args
;
2421 register Lisp_Object val
;
2427 val
= Fcons (args
[nargs
], val
);
2433 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2434 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2436 register Lisp_Object length
, init
;
2438 register Lisp_Object val
;
2441 CHECK_NATNUM (length
);
2442 size
= XFASTINT (length
);
2447 val
= Fcons (init
, val
);
2452 val
= Fcons (init
, val
);
2457 val
= Fcons (init
, val
);
2462 val
= Fcons (init
, val
);
2467 val
= Fcons (init
, val
);
2482 /***********************************************************************
2484 ***********************************************************************/
2486 /* Singly-linked list of all vectors. */
2488 struct Lisp_Vector
*all_vectors
;
2490 /* Total number of vector-like objects now in use. */
2495 /* Value is a pointer to a newly allocated Lisp_Vector structure
2496 with room for LEN Lisp_Objects. */
2498 static struct Lisp_Vector
*
2499 allocate_vectorlike (len
, type
)
2503 struct Lisp_Vector
*p
;
2506 #ifdef DOUG_LEA_MALLOC
2507 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2508 because mapped region contents are not preserved in
2511 mallopt (M_MMAP_MAX
, 0);
2515 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2516 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2518 #ifdef DOUG_LEA_MALLOC
2519 /* Back to a reasonable maximum of mmap'ed areas. */
2521 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2525 consing_since_gc
+= nbytes
;
2526 vector_cells_consed
+= len
;
2528 p
->next
= all_vectors
;
2535 /* Allocate a vector with NSLOTS slots. */
2537 struct Lisp_Vector
*
2538 allocate_vector (nslots
)
2541 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2547 /* Allocate other vector-like structures. */
2549 struct Lisp_Hash_Table
*
2550 allocate_hash_table ()
2552 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2553 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2557 for (i
= 0; i
< len
; ++i
)
2558 v
->contents
[i
] = Qnil
;
2560 return (struct Lisp_Hash_Table
*) v
;
2567 EMACS_INT len
= VECSIZE (struct window
);
2568 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2571 for (i
= 0; i
< len
; ++i
)
2572 v
->contents
[i
] = Qnil
;
2575 return (struct window
*) v
;
2582 EMACS_INT len
= VECSIZE (struct frame
);
2583 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2586 for (i
= 0; i
< len
; ++i
)
2587 v
->contents
[i
] = make_number (0);
2589 return (struct frame
*) v
;
2593 struct Lisp_Process
*
2596 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2597 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2600 for (i
= 0; i
< len
; ++i
)
2601 v
->contents
[i
] = Qnil
;
2604 return (struct Lisp_Process
*) v
;
2608 struct Lisp_Vector
*
2609 allocate_other_vector (len
)
2612 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2615 for (i
= 0; i
< len
; ++i
)
2616 v
->contents
[i
] = Qnil
;
2623 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2624 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2625 See also the function `vector'. */)
2627 register Lisp_Object length
, init
;
2630 register EMACS_INT sizei
;
2632 register struct Lisp_Vector
*p
;
2634 CHECK_NATNUM (length
);
2635 sizei
= XFASTINT (length
);
2637 p
= allocate_vector (sizei
);
2638 for (index
= 0; index
< sizei
; index
++)
2639 p
->contents
[index
] = init
;
2641 XSETVECTOR (vector
, p
);
2646 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2647 doc
: /* Return a newly created char-table, with purpose PURPOSE.
2648 Each element is initialized to INIT, which defaults to nil.
2649 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
2650 The property's value should be an integer between 0 and 10. */)
2652 register Lisp_Object purpose
, init
;
2656 CHECK_SYMBOL (purpose
);
2657 n
= Fget (purpose
, Qchar_table_extra_slots
);
2659 if (XINT (n
) < 0 || XINT (n
) > 10)
2660 args_out_of_range (n
, Qnil
);
2661 /* Add 2 to the size for the defalt and parent slots. */
2662 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2664 XCHAR_TABLE (vector
)->top
= Qt
;
2665 XCHAR_TABLE (vector
)->parent
= Qnil
;
2666 XCHAR_TABLE (vector
)->purpose
= purpose
;
2667 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2672 /* Return a newly created sub char table with default value DEFALT.
2673 Since a sub char table does not appear as a top level Emacs Lisp
2674 object, we don't need a Lisp interface to make it. */
2677 make_sub_char_table (defalt
)
2681 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2682 XCHAR_TABLE (vector
)->top
= Qnil
;
2683 XCHAR_TABLE (vector
)->defalt
= defalt
;
2684 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2689 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2690 doc
: /* Return a newly created vector with specified arguments as elements.
2691 Any number of arguments, even zero arguments, are allowed.
2692 usage: (vector &rest OBJECTS) */)
2697 register Lisp_Object len
, val
;
2699 register struct Lisp_Vector
*p
;
2701 XSETFASTINT (len
, nargs
);
2702 val
= Fmake_vector (len
, Qnil
);
2704 for (index
= 0; index
< nargs
; index
++)
2705 p
->contents
[index
] = args
[index
];
2710 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2711 doc
: /* Create a byte-code object with specified arguments as elements.
2712 The arguments should be the arglist, bytecode-string, constant vector,
2713 stack size, (optional) doc string, and (optional) interactive spec.
2714 The first four arguments are required; at most six have any
2716 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2721 register Lisp_Object len
, val
;
2723 register struct Lisp_Vector
*p
;
2725 XSETFASTINT (len
, nargs
);
2726 if (!NILP (Vpurify_flag
))
2727 val
= make_pure_vector ((EMACS_INT
) nargs
);
2729 val
= Fmake_vector (len
, Qnil
);
2731 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2732 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2733 earlier because they produced a raw 8-bit string for byte-code
2734 and now such a byte-code string is loaded as multibyte while
2735 raw 8-bit characters converted to multibyte form. Thus, now we
2736 must convert them back to the original unibyte form. */
2737 args
[1] = Fstring_as_unibyte (args
[1]);
2740 for (index
= 0; index
< nargs
; index
++)
2742 if (!NILP (Vpurify_flag
))
2743 args
[index
] = Fpurecopy (args
[index
]);
2744 p
->contents
[index
] = args
[index
];
2746 XSETCOMPILED (val
, p
);
2752 /***********************************************************************
2754 ***********************************************************************/
2756 /* Each symbol_block is just under 1020 bytes long, since malloc
2757 really allocates in units of powers of two and uses 4 bytes for its
2760 #define SYMBOL_BLOCK_SIZE \
2761 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2765 /* Place `symbols' first, to preserve alignment. */
2766 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2767 struct symbol_block
*next
;
2770 /* Current symbol block and index of first unused Lisp_Symbol
2773 struct symbol_block
*symbol_block
;
2774 int symbol_block_index
;
2776 /* List of free symbols. */
2778 struct Lisp_Symbol
*symbol_free_list
;
2780 /* Total number of symbol blocks now in use. */
2782 int n_symbol_blocks
;
2785 /* Initialize symbol allocation. */
2790 symbol_block
= NULL
;
2791 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
2792 symbol_free_list
= 0;
2793 n_symbol_blocks
= 0;
2797 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2798 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
2799 Its value and function definition are void, and its property list is nil. */)
2803 register Lisp_Object val
;
2804 register struct Lisp_Symbol
*p
;
2806 CHECK_STRING (name
);
2808 if (symbol_free_list
)
2810 XSETSYMBOL (val
, symbol_free_list
);
2811 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2815 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2817 struct symbol_block
*new;
2818 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2820 new->next
= symbol_block
;
2822 symbol_block_index
= 0;
2825 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
2826 symbol_block_index
++;
2832 p
->value
= Qunbound
;
2833 p
->function
= Qunbound
;
2836 p
->interned
= SYMBOL_UNINTERNED
;
2838 p
->indirect_variable
= 0;
2839 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2846 /***********************************************************************
2847 Marker (Misc) Allocation
2848 ***********************************************************************/
2850 /* Allocation of markers and other objects that share that structure.
2851 Works like allocation of conses. */
2853 #define MARKER_BLOCK_SIZE \
2854 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2858 /* Place `markers' first, to preserve alignment. */
2859 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2860 struct marker_block
*next
;
2863 struct marker_block
*marker_block
;
2864 int marker_block_index
;
2866 union Lisp_Misc
*marker_free_list
;
2868 /* Total number of marker blocks now in use. */
2870 int n_marker_blocks
;
2875 marker_block
= NULL
;
2876 marker_block_index
= MARKER_BLOCK_SIZE
;
2877 marker_free_list
= 0;
2878 n_marker_blocks
= 0;
2881 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2888 if (marker_free_list
)
2890 XSETMISC (val
, marker_free_list
);
2891 marker_free_list
= marker_free_list
->u_free
.chain
;
2895 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2897 struct marker_block
*new;
2898 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2900 new->next
= marker_block
;
2902 marker_block_index
= 0;
2905 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
2906 marker_block_index
++;
2909 consing_since_gc
+= sizeof (union Lisp_Misc
);
2910 misc_objects_consed
++;
2911 XMARKER (val
)->gcmarkbit
= 0;
2915 /* Return a Lisp_Misc_Save_Value object containing POINTER and
2916 INTEGER. This is used to package C values to call record_unwind_protect.
2917 The unwind function can get the C values back using XSAVE_VALUE. */
2920 make_save_value (pointer
, integer
)
2924 register Lisp_Object val
;
2925 register struct Lisp_Save_Value
*p
;
2927 val
= allocate_misc ();
2928 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
2929 p
= XSAVE_VALUE (val
);
2930 p
->pointer
= pointer
;
2931 p
->integer
= integer
;
2935 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2936 doc
: /* Return a newly allocated marker which does not point at any place. */)
2939 register Lisp_Object val
;
2940 register struct Lisp_Marker
*p
;
2942 val
= allocate_misc ();
2943 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2949 p
->insertion_type
= 0;
2953 /* Put MARKER back on the free list after using it temporarily. */
2956 free_marker (marker
)
2959 unchain_marker (XMARKER (marker
));
2961 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2962 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2963 marker_free_list
= XMISC (marker
);
2965 total_free_markers
++;
2969 /* Return a newly created vector or string with specified arguments as
2970 elements. If all the arguments are characters that can fit
2971 in a string of events, make a string; otherwise, make a vector.
2973 Any number of arguments, even zero arguments, are allowed. */
2976 make_event_array (nargs
, args
)
2982 for (i
= 0; i
< nargs
; i
++)
2983 /* The things that fit in a string
2984 are characters that are in 0...127,
2985 after discarding the meta bit and all the bits above it. */
2986 if (!INTEGERP (args
[i
])
2987 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2988 return Fvector (nargs
, args
);
2990 /* Since the loop exited, we know that all the things in it are
2991 characters, so we can make a string. */
2995 result
= Fmake_string (make_number (nargs
), make_number (0));
2996 for (i
= 0; i
< nargs
; i
++)
2998 SSET (result
, i
, XINT (args
[i
]));
2999 /* Move the meta bit to the right place for a string char. */
3000 if (XINT (args
[i
]) & CHAR_META
)
3001 SSET (result
, i
, SREF (result
, i
) | 0x80);
3010 /************************************************************************
3012 ************************************************************************/
3014 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3016 /* Conservative C stack marking requires a method to identify possibly
3017 live Lisp objects given a pointer value. We do this by keeping
3018 track of blocks of Lisp data that are allocated in a red-black tree
3019 (see also the comment of mem_node which is the type of nodes in
3020 that tree). Function lisp_malloc adds information for an allocated
3021 block to the red-black tree with calls to mem_insert, and function
3022 lisp_free removes it with mem_delete. Functions live_string_p etc
3023 call mem_find to lookup information about a given pointer in the
3024 tree, and use that to determine if the pointer points to a Lisp
3027 /* Initialize this part of alloc.c. */
3032 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3033 mem_z
.parent
= NULL
;
3034 mem_z
.color
= MEM_BLACK
;
3035 mem_z
.start
= mem_z
.end
= NULL
;
3040 /* Value is a pointer to the mem_node containing START. Value is
3041 MEM_NIL if there is no node in the tree containing START. */
3043 static INLINE
struct mem_node
*
3049 if (start
< min_heap_address
|| start
> max_heap_address
)
3052 /* Make the search always successful to speed up the loop below. */
3053 mem_z
.start
= start
;
3054 mem_z
.end
= (char *) start
+ 1;
3057 while (start
< p
->start
|| start
>= p
->end
)
3058 p
= start
< p
->start
? p
->left
: p
->right
;
3063 /* Insert a new node into the tree for a block of memory with start
3064 address START, end address END, and type TYPE. Value is a
3065 pointer to the node that was inserted. */
3067 static struct mem_node
*
3068 mem_insert (start
, end
, type
)
3072 struct mem_node
*c
, *parent
, *x
;
3074 if (start
< min_heap_address
)
3075 min_heap_address
= start
;
3076 if (end
> max_heap_address
)
3077 max_heap_address
= end
;
3079 /* See where in the tree a node for START belongs. In this
3080 particular application, it shouldn't happen that a node is already
3081 present. For debugging purposes, let's check that. */
3085 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3087 while (c
!= MEM_NIL
)
3089 if (start
>= c
->start
&& start
< c
->end
)
3092 c
= start
< c
->start
? c
->left
: c
->right
;
3095 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3097 while (c
!= MEM_NIL
)
3100 c
= start
< c
->start
? c
->left
: c
->right
;
3103 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3105 /* Create a new node. */
3106 #ifdef GC_MALLOC_CHECK
3107 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3111 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3117 x
->left
= x
->right
= MEM_NIL
;
3120 /* Insert it as child of PARENT or install it as root. */
3123 if (start
< parent
->start
)
3131 /* Re-establish red-black tree properties. */
3132 mem_insert_fixup (x
);
3138 /* Re-establish the red-black properties of the tree, and thereby
3139 balance the tree, after node X has been inserted; X is always red. */
3142 mem_insert_fixup (x
)
3145 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3147 /* X is red and its parent is red. This is a violation of
3148 red-black tree property #3. */
3150 if (x
->parent
== x
->parent
->parent
->left
)
3152 /* We're on the left side of our grandparent, and Y is our
3154 struct mem_node
*y
= x
->parent
->parent
->right
;
3156 if (y
->color
== MEM_RED
)
3158 /* Uncle and parent are red but should be black because
3159 X is red. Change the colors accordingly and proceed
3160 with the grandparent. */
3161 x
->parent
->color
= MEM_BLACK
;
3162 y
->color
= MEM_BLACK
;
3163 x
->parent
->parent
->color
= MEM_RED
;
3164 x
= x
->parent
->parent
;
3168 /* Parent and uncle have different colors; parent is
3169 red, uncle is black. */
3170 if (x
== x
->parent
->right
)
3173 mem_rotate_left (x
);
3176 x
->parent
->color
= MEM_BLACK
;
3177 x
->parent
->parent
->color
= MEM_RED
;
3178 mem_rotate_right (x
->parent
->parent
);
3183 /* This is the symmetrical case of above. */
3184 struct mem_node
*y
= x
->parent
->parent
->left
;
3186 if (y
->color
== MEM_RED
)
3188 x
->parent
->color
= MEM_BLACK
;
3189 y
->color
= MEM_BLACK
;
3190 x
->parent
->parent
->color
= MEM_RED
;
3191 x
= x
->parent
->parent
;
3195 if (x
== x
->parent
->left
)
3198 mem_rotate_right (x
);
3201 x
->parent
->color
= MEM_BLACK
;
3202 x
->parent
->parent
->color
= MEM_RED
;
3203 mem_rotate_left (x
->parent
->parent
);
3208 /* The root may have been changed to red due to the algorithm. Set
3209 it to black so that property #5 is satisfied. */
3210 mem_root
->color
= MEM_BLACK
;
3226 /* Turn y's left sub-tree into x's right sub-tree. */
3229 if (y
->left
!= MEM_NIL
)
3230 y
->left
->parent
= x
;
3232 /* Y's parent was x's parent. */
3234 y
->parent
= x
->parent
;
3236 /* Get the parent to point to y instead of x. */
3239 if (x
== x
->parent
->left
)
3240 x
->parent
->left
= y
;
3242 x
->parent
->right
= y
;
3247 /* Put x on y's left. */
3261 mem_rotate_right (x
)
3264 struct mem_node
*y
= x
->left
;
3267 if (y
->right
!= MEM_NIL
)
3268 y
->right
->parent
= x
;
3271 y
->parent
= x
->parent
;
3274 if (x
== x
->parent
->right
)
3275 x
->parent
->right
= y
;
3277 x
->parent
->left
= y
;
3288 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3294 struct mem_node
*x
, *y
;
3296 if (!z
|| z
== MEM_NIL
)
3299 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3304 while (y
->left
!= MEM_NIL
)
3308 if (y
->left
!= MEM_NIL
)
3313 x
->parent
= y
->parent
;
3316 if (y
== y
->parent
->left
)
3317 y
->parent
->left
= x
;
3319 y
->parent
->right
= x
;
3326 z
->start
= y
->start
;
3331 if (y
->color
== MEM_BLACK
)
3332 mem_delete_fixup (x
);
3334 #ifdef GC_MALLOC_CHECK
3342 /* Re-establish the red-black properties of the tree, after a
3346 mem_delete_fixup (x
)
3349 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3351 if (x
== x
->parent
->left
)
3353 struct mem_node
*w
= x
->parent
->right
;
3355 if (w
->color
== MEM_RED
)
3357 w
->color
= MEM_BLACK
;
3358 x
->parent
->color
= MEM_RED
;
3359 mem_rotate_left (x
->parent
);
3360 w
= x
->parent
->right
;
3363 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3370 if (w
->right
->color
== MEM_BLACK
)
3372 w
->left
->color
= MEM_BLACK
;
3374 mem_rotate_right (w
);
3375 w
= x
->parent
->right
;
3377 w
->color
= x
->parent
->color
;
3378 x
->parent
->color
= MEM_BLACK
;
3379 w
->right
->color
= MEM_BLACK
;
3380 mem_rotate_left (x
->parent
);
3386 struct mem_node
*w
= x
->parent
->left
;
3388 if (w
->color
== MEM_RED
)
3390 w
->color
= MEM_BLACK
;
3391 x
->parent
->color
= MEM_RED
;
3392 mem_rotate_right (x
->parent
);
3393 w
= x
->parent
->left
;
3396 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3403 if (w
->left
->color
== MEM_BLACK
)
3405 w
->right
->color
= MEM_BLACK
;
3407 mem_rotate_left (w
);
3408 w
= x
->parent
->left
;
3411 w
->color
= x
->parent
->color
;
3412 x
->parent
->color
= MEM_BLACK
;
3413 w
->left
->color
= MEM_BLACK
;
3414 mem_rotate_right (x
->parent
);
3420 x
->color
= MEM_BLACK
;
3424 /* Value is non-zero if P is a pointer to a live Lisp string on
3425 the heap. M is a pointer to the mem_block for P. */
3428 live_string_p (m
, p
)
3432 if (m
->type
== MEM_TYPE_STRING
)
3434 struct string_block
*b
= (struct string_block
*) m
->start
;
3435 int offset
= (char *) p
- (char *) &b
->strings
[0];
3437 /* P must point to the start of a Lisp_String structure, and it
3438 must not be on the free-list. */
3440 && offset
% sizeof b
->strings
[0] == 0
3441 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3442 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3449 /* Value is non-zero if P is a pointer to a live Lisp cons on
3450 the heap. M is a pointer to the mem_block for P. */
3457 if (m
->type
== MEM_TYPE_CONS
)
3459 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3460 int offset
= (char *) p
- (char *) &b
->conses
[0];
3462 /* P must point to the start of a Lisp_Cons, not be
3463 one of the unused cells in the current cons block,
3464 and not be on the free-list. */
3466 && offset
% sizeof b
->conses
[0] == 0
3467 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3469 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3470 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3477 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3478 the heap. M is a pointer to the mem_block for P. */
3481 live_symbol_p (m
, p
)
3485 if (m
->type
== MEM_TYPE_SYMBOL
)
3487 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3488 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3490 /* P must point to the start of a Lisp_Symbol, not be
3491 one of the unused cells in the current symbol block,
3492 and not be on the free-list. */
3494 && offset
% sizeof b
->symbols
[0] == 0
3495 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3496 && (b
!= symbol_block
3497 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3498 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3505 /* Value is non-zero if P is a pointer to a live Lisp float on
3506 the heap. M is a pointer to the mem_block for P. */
3513 if (m
->type
== MEM_TYPE_FLOAT
)
3515 struct float_block
*b
= (struct float_block
*) m
->start
;
3516 int offset
= (char *) p
- (char *) &b
->floats
[0];
3518 /* P must point to the start of a Lisp_Float and not be
3519 one of the unused cells in the current float block. */
3521 && offset
% sizeof b
->floats
[0] == 0
3522 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3523 && (b
!= float_block
3524 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3531 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3532 the heap. M is a pointer to the mem_block for P. */
3539 if (m
->type
== MEM_TYPE_MISC
)
3541 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3542 int offset
= (char *) p
- (char *) &b
->markers
[0];
3544 /* P must point to the start of a Lisp_Misc, not be
3545 one of the unused cells in the current misc block,
3546 and not be on the free-list. */
3548 && offset
% sizeof b
->markers
[0] == 0
3549 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3550 && (b
!= marker_block
3551 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3552 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3559 /* Value is non-zero if P is a pointer to a live vector-like object.
3560 M is a pointer to the mem_block for P. */
3563 live_vector_p (m
, p
)
3567 return (p
== m
->start
3568 && m
->type
>= MEM_TYPE_VECTOR
3569 && m
->type
<= MEM_TYPE_WINDOW
);
3573 /* Value is non-zero if P is a pointer to a live buffer. M is a
3574 pointer to the mem_block for P. */
3577 live_buffer_p (m
, p
)
3581 /* P must point to the start of the block, and the buffer
3582 must not have been killed. */
3583 return (m
->type
== MEM_TYPE_BUFFER
3585 && !NILP (((struct buffer
*) p
)->name
));
3588 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3592 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3594 /* Array of objects that are kept alive because the C stack contains
3595 a pattern that looks like a reference to them . */
3597 #define MAX_ZOMBIES 10
3598 static Lisp_Object zombies
[MAX_ZOMBIES
];
3600 /* Number of zombie objects. */
3602 static int nzombies
;
3604 /* Number of garbage collections. */
3608 /* Average percentage of zombies per collection. */
3610 static double avg_zombies
;
3612 /* Max. number of live and zombie objects. */
3614 static int max_live
, max_zombies
;
3616 /* Average number of live objects per GC. */
3618 static double avg_live
;
3620 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3621 doc
: /* Show information about live and zombie objects. */)
3624 Lisp_Object args
[8], zombie_list
= Qnil
;
3626 for (i
= 0; i
< nzombies
; i
++)
3627 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3628 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3629 args
[1] = make_number (ngcs
);
3630 args
[2] = make_float (avg_live
);
3631 args
[3] = make_float (avg_zombies
);
3632 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3633 args
[5] = make_number (max_live
);
3634 args
[6] = make_number (max_zombies
);
3635 args
[7] = zombie_list
;
3636 return Fmessage (8, args
);
3639 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3642 /* Mark OBJ if we can prove it's a Lisp_Object. */
3645 mark_maybe_object (obj
)
3648 void *po
= (void *) XPNTR (obj
);
3649 struct mem_node
*m
= mem_find (po
);
3655 switch (XGCTYPE (obj
))
3658 mark_p
= (live_string_p (m
, po
)
3659 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3663 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
3667 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
3671 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
3674 case Lisp_Vectorlike
:
3675 /* Note: can't check GC_BUFFERP before we know it's a
3676 buffer because checking that dereferences the pointer
3677 PO which might point anywhere. */
3678 if (live_vector_p (m
, po
))
3679 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
3680 else if (live_buffer_p (m
, po
))
3681 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
3685 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
3689 case Lisp_Type_Limit
:
3695 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3696 if (nzombies
< MAX_ZOMBIES
)
3697 zombies
[nzombies
] = obj
;
3706 /* If P points to Lisp data, mark that as live if it isn't already
3710 mark_maybe_pointer (p
)
3715 /* Quickly rule out some values which can't point to Lisp data. We
3716 assume that Lisp data is aligned on even addresses. */
3717 if ((EMACS_INT
) p
& 1)
3723 Lisp_Object obj
= Qnil
;
3727 case MEM_TYPE_NON_LISP
:
3728 /* Nothing to do; not a pointer to Lisp memory. */
3731 case MEM_TYPE_BUFFER
:
3732 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
3733 XSETVECTOR (obj
, p
);
3737 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
3741 case MEM_TYPE_STRING
:
3742 if (live_string_p (m
, p
)
3743 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
3744 XSETSTRING (obj
, p
);
3748 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
3752 case MEM_TYPE_SYMBOL
:
3753 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
3754 XSETSYMBOL (obj
, p
);
3757 case MEM_TYPE_FLOAT
:
3758 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
3762 case MEM_TYPE_VECTOR
:
3763 case MEM_TYPE_PROCESS
:
3764 case MEM_TYPE_HASH_TABLE
:
3765 case MEM_TYPE_FRAME
:
3766 case MEM_TYPE_WINDOW
:
3767 if (live_vector_p (m
, p
))
3770 XSETVECTOR (tem
, p
);
3771 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
3786 /* Mark Lisp objects referenced from the address range START..END. */
3789 mark_memory (start
, end
)
3795 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3799 /* Make START the pointer to the start of the memory region,
3800 if it isn't already. */
3808 /* Mark Lisp_Objects. */
3809 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3810 mark_maybe_object (*p
);
3812 /* Mark Lisp data pointed to. This is necessary because, in some
3813 situations, the C compiler optimizes Lisp objects away, so that
3814 only a pointer to them remains. Example:
3816 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
3819 Lisp_Object obj = build_string ("test");
3820 struct Lisp_String *s = XSTRING (obj);
3821 Fgarbage_collect ();
3822 fprintf (stderr, "test `%s'\n", s->data);
3826 Here, `obj' isn't really used, and the compiler optimizes it
3827 away. The only reference to the life string is through the
3830 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
3831 mark_maybe_pointer (*pp
);
3834 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
3835 the GCC system configuration. In gcc 3.2, the only systems for
3836 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
3837 by others?) and ns32k-pc532-min. */
3839 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3841 static int setjmp_tested_p
, longjmps_done
;
3843 #define SETJMP_WILL_LIKELY_WORK "\
3845 Emacs garbage collector has been changed to use conservative stack\n\
3846 marking. Emacs has determined that the method it uses to do the\n\
3847 marking will likely work on your system, but this isn't sure.\n\
3849 If you are a system-programmer, or can get the help of a local wizard\n\
3850 who is, please take a look at the function mark_stack in alloc.c, and\n\
3851 verify that the methods used are appropriate for your system.\n\
3853 Please mail the result to <emacs-devel@gnu.org>.\n\
3856 #define SETJMP_WILL_NOT_WORK "\
3858 Emacs garbage collector has been changed to use conservative stack\n\
3859 marking. Emacs has determined that the default method it uses to do the\n\
3860 marking will not work on your system. We will need a system-dependent\n\
3861 solution for your system.\n\
3863 Please take a look at the function mark_stack in alloc.c, and\n\
3864 try to find a way to make it work on your system.\n\
3866 Note that you may get false negatives, depending on the compiler.\n\
3867 In particular, you need to use -O with GCC for this test.\n\
3869 Please mail the result to <emacs-devel@gnu.org>.\n\
3873 /* Perform a quick check if it looks like setjmp saves registers in a
3874 jmp_buf. Print a message to stderr saying so. When this test
3875 succeeds, this is _not_ a proof that setjmp is sufficient for
3876 conservative stack marking. Only the sources or a disassembly
3887 /* Arrange for X to be put in a register. */
3893 if (longjmps_done
== 1)
3895 /* Came here after the longjmp at the end of the function.
3897 If x == 1, the longjmp has restored the register to its
3898 value before the setjmp, and we can hope that setjmp
3899 saves all such registers in the jmp_buf, although that
3902 For other values of X, either something really strange is
3903 taking place, or the setjmp just didn't save the register. */
3906 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3909 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3916 if (longjmps_done
== 1)
3920 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3923 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3925 /* Abort if anything GCPRO'd doesn't survive the GC. */
3933 for (p
= gcprolist
; p
; p
= p
->next
)
3934 for (i
= 0; i
< p
->nvars
; ++i
)
3935 if (!survives_gc_p (p
->var
[i
]))
3936 /* FIXME: It's not necessarily a bug. It might just be that the
3937 GCPRO is unnecessary or should release the object sooner. */
3941 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3948 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3949 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3951 fprintf (stderr
, " %d = ", i
);
3952 debug_print (zombies
[i
]);
3956 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3959 /* Mark live Lisp objects on the C stack.
3961 There are several system-dependent problems to consider when
3962 porting this to new architectures:
3966 We have to mark Lisp objects in CPU registers that can hold local
3967 variables or are used to pass parameters.
3969 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3970 something that either saves relevant registers on the stack, or
3971 calls mark_maybe_object passing it each register's contents.
3973 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3974 implementation assumes that calling setjmp saves registers we need
3975 to see in a jmp_buf which itself lies on the stack. This doesn't
3976 have to be true! It must be verified for each system, possibly
3977 by taking a look at the source code of setjmp.
3981 Architectures differ in the way their processor stack is organized.
3982 For example, the stack might look like this
3985 | Lisp_Object | size = 4
3987 | something else | size = 2
3989 | Lisp_Object | size = 4
3993 In such a case, not every Lisp_Object will be aligned equally. To
3994 find all Lisp_Object on the stack it won't be sufficient to walk
3995 the stack in steps of 4 bytes. Instead, two passes will be
3996 necessary, one starting at the start of the stack, and a second
3997 pass starting at the start of the stack + 2. Likewise, if the
3998 minimal alignment of Lisp_Objects on the stack is 1, four passes
3999 would be necessary, each one starting with one byte more offset
4000 from the stack start.
4002 The current code assumes by default that Lisp_Objects are aligned
4003 equally on the stack. */
4010 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4013 /* This trick flushes the register windows so that all the state of
4014 the process is contained in the stack. */
4015 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4016 needed on ia64 too. See mach_dep.c, where it also says inline
4017 assembler doesn't work with relevant proprietary compilers. */
4022 /* Save registers that we need to see on the stack. We need to see
4023 registers used to hold register variables and registers used to
4025 #ifdef GC_SAVE_REGISTERS_ON_STACK
4026 GC_SAVE_REGISTERS_ON_STACK (end
);
4027 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4029 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4030 setjmp will definitely work, test it
4031 and print a message with the result
4033 if (!setjmp_tested_p
)
4035 setjmp_tested_p
= 1;
4038 #endif /* GC_SETJMP_WORKS */
4041 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4042 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4044 /* This assumes that the stack is a contiguous region in memory. If
4045 that's not the case, something has to be done here to iterate
4046 over the stack segments. */
4047 #ifndef GC_LISP_OBJECT_ALIGNMENT
4049 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4051 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4054 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4055 mark_memory ((char *) stack_base
+ i
, end
);
4057 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4063 #endif /* GC_MARK_STACK != 0 */
4067 /***********************************************************************
4068 Pure Storage Management
4069 ***********************************************************************/
4071 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4072 pointer to it. TYPE is the Lisp type for which the memory is
4073 allocated. TYPE < 0 means it's not used for a Lisp object.
4075 If store_pure_type_info is set and TYPE is >= 0, the type of
4076 the allocated object is recorded in pure_types. */
4078 static POINTER_TYPE
*
4079 pure_alloc (size
, type
)
4083 POINTER_TYPE
*result
;
4085 size_t alignment
= (1 << GCTYPEBITS
);
4087 size_t alignment
= sizeof (EMACS_INT
);
4089 /* Give Lisp_Floats an extra alignment. */
4090 if (type
== Lisp_Float
)
4092 #if defined __GNUC__ && __GNUC__ >= 2
4093 alignment
= __alignof (struct Lisp_Float
);
4095 alignment
= sizeof (struct Lisp_Float
);
4101 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4102 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4104 if (pure_bytes_used
<= pure_size
)
4107 /* Don't allocate a large amount here,
4108 because it might get mmap'd and then its address
4109 might not be usable. */
4110 purebeg
= (char *) xmalloc (10000);
4112 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4113 pure_bytes_used
= 0;
4118 /* Print a warning if PURESIZE is too small. */
4123 if (pure_bytes_used_before_overflow
)
4124 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4125 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4129 /* Return a string allocated in pure space. DATA is a buffer holding
4130 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4131 non-zero means make the result string multibyte.
4133 Must get an error if pure storage is full, since if it cannot hold
4134 a large string it may be able to hold conses that point to that
4135 string; then the string is not protected from gc. */
4138 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4144 struct Lisp_String
*s
;
4146 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4147 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4149 s
->size_byte
= multibyte
? nbytes
: -1;
4150 bcopy (data
, s
->data
, nbytes
);
4151 s
->data
[nbytes
] = '\0';
4152 s
->intervals
= NULL_INTERVAL
;
4153 XSETSTRING (string
, s
);
4158 /* Return a cons allocated from pure space. Give it pure copies
4159 of CAR as car and CDR as cdr. */
4162 pure_cons (car
, cdr
)
4163 Lisp_Object car
, cdr
;
4165 register Lisp_Object
new;
4166 struct Lisp_Cons
*p
;
4168 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4170 XSETCAR (new, Fpurecopy (car
));
4171 XSETCDR (new, Fpurecopy (cdr
));
4176 /* Value is a float object with value NUM allocated from pure space. */
4179 make_pure_float (num
)
4182 register Lisp_Object
new;
4183 struct Lisp_Float
*p
;
4185 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4187 XFLOAT_DATA (new) = num
;
4192 /* Return a vector with room for LEN Lisp_Objects allocated from
4196 make_pure_vector (len
)
4200 struct Lisp_Vector
*p
;
4201 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4203 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4204 XSETVECTOR (new, p
);
4205 XVECTOR (new)->size
= len
;
4210 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4211 doc
: /* Make a copy of OBJECT in pure storage.
4212 Recursively copies contents of vectors and cons cells.
4213 Does not copy symbols. Copies strings without text properties. */)
4215 register Lisp_Object obj
;
4217 if (NILP (Vpurify_flag
))
4220 if (PURE_POINTER_P (XPNTR (obj
)))
4224 return pure_cons (XCAR (obj
), XCDR (obj
));
4225 else if (FLOATP (obj
))
4226 return make_pure_float (XFLOAT_DATA (obj
));
4227 else if (STRINGP (obj
))
4228 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4230 STRING_MULTIBYTE (obj
));
4231 else if (COMPILEDP (obj
) || VECTORP (obj
))
4233 register struct Lisp_Vector
*vec
;
4237 size
= XVECTOR (obj
)->size
;
4238 if (size
& PSEUDOVECTOR_FLAG
)
4239 size
&= PSEUDOVECTOR_SIZE_MASK
;
4240 vec
= XVECTOR (make_pure_vector (size
));
4241 for (i
= 0; i
< size
; i
++)
4242 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4243 if (COMPILEDP (obj
))
4244 XSETCOMPILED (obj
, vec
);
4246 XSETVECTOR (obj
, vec
);
4249 else if (MARKERP (obj
))
4250 error ("Attempt to copy a marker to pure storage");
4257 /***********************************************************************
4259 ***********************************************************************/
4261 /* Put an entry in staticvec, pointing at the variable with address
4265 staticpro (varaddress
)
4266 Lisp_Object
*varaddress
;
4268 staticvec
[staticidx
++] = varaddress
;
4269 if (staticidx
>= NSTATICS
)
4277 struct catchtag
*next
;
4282 struct backtrace
*next
;
4283 Lisp_Object
*function
;
4284 Lisp_Object
*args
; /* Points to vector of args. */
4285 int nargs
; /* Length of vector. */
4286 /* If nargs is UNEVALLED, args points to slot holding list of
4293 /***********************************************************************
4295 ***********************************************************************/
4297 /* Temporarily prevent garbage collection. */
4300 inhibit_garbage_collection ()
4302 int count
= SPECPDL_INDEX ();
4303 int nbits
= min (VALBITS
, BITS_PER_INT
);
4305 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4310 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4311 doc
: /* Reclaim storage for Lisp objects no longer needed.
4312 Garbage collection happens automatically if you cons more than
4313 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4314 `garbage-collect' normally returns a list with info on amount of space in use:
4315 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4316 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4317 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4318 (USED-STRINGS . FREE-STRINGS))
4319 However, if there was overflow in pure space, `garbage-collect'
4320 returns nil, because real GC can't be done. */)
4323 register struct specbinding
*bind
;
4324 struct catchtag
*catch;
4325 struct handler
*handler
;
4326 register struct backtrace
*backlist
;
4327 char stack_top_variable
;
4330 Lisp_Object total
[8];
4331 int count
= SPECPDL_INDEX ();
4332 EMACS_TIME t1
, t2
, t3
;
4337 EMACS_GET_TIME (t1
);
4339 /* Can't GC if pure storage overflowed because we can't determine
4340 if something is a pure object or not. */
4341 if (pure_bytes_used_before_overflow
)
4344 /* In case user calls debug_print during GC,
4345 don't let that cause a recursive GC. */
4346 consing_since_gc
= 0;
4348 /* Save what's currently displayed in the echo area. */
4349 message_p
= push_message ();
4350 record_unwind_protect (pop_message_unwind
, Qnil
);
4352 /* Save a copy of the contents of the stack, for debugging. */
4353 #if MAX_SAVE_STACK > 0
4354 if (NILP (Vpurify_flag
))
4356 i
= &stack_top_variable
- stack_bottom
;
4358 if (i
< MAX_SAVE_STACK
)
4360 if (stack_copy
== 0)
4361 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4362 else if (stack_copy_size
< i
)
4363 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4366 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4367 bcopy (stack_bottom
, stack_copy
, i
);
4369 bcopy (&stack_top_variable
, stack_copy
, i
);
4373 #endif /* MAX_SAVE_STACK > 0 */
4375 if (garbage_collection_messages
)
4376 message1_nolog ("Garbage collecting...");
4380 shrink_regexp_cache ();
4382 /* Don't keep undo information around forever. */
4384 register struct buffer
*nextb
= all_buffers
;
4388 /* If a buffer's undo list is Qt, that means that undo is
4389 turned off in that buffer. Calling truncate_undo_list on
4390 Qt tends to return NULL, which effectively turns undo back on.
4391 So don't call truncate_undo_list if undo_list is Qt. */
4392 if (! EQ (nextb
->undo_list
, Qt
))
4394 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
4397 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4398 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4400 /* If a buffer's gap size is more than 10% of the buffer
4401 size, or larger than 2000 bytes, then shrink it
4402 accordingly. Keep a minimum size of 20 bytes. */
4403 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4405 if (nextb
->text
->gap_size
> size
)
4407 struct buffer
*save_current
= current_buffer
;
4408 current_buffer
= nextb
;
4409 make_gap (-(nextb
->text
->gap_size
- size
));
4410 current_buffer
= save_current
;
4414 nextb
= nextb
->next
;
4420 /* clear_marks (); */
4422 /* Mark all the special slots that serve as the roots of accessibility. */
4424 for (i
= 0; i
< staticidx
; i
++)
4425 mark_object (*staticvec
[i
]);
4427 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4428 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4432 register struct gcpro
*tail
;
4433 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4434 for (i
= 0; i
< tail
->nvars
; i
++)
4435 mark_object (tail
->var
[i
]);
4440 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4442 mark_object (bind
->symbol
);
4443 mark_object (bind
->old_value
);
4445 for (catch = catchlist
; catch; catch = catch->next
)
4447 mark_object (catch->tag
);
4448 mark_object (catch->val
);
4450 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4452 mark_object (handler
->handler
);
4453 mark_object (handler
->var
);
4455 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
4457 mark_object (*backlist
->function
);
4459 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
4462 i
= backlist
->nargs
- 1;
4464 mark_object (backlist
->args
[i
]);
4468 /* Look thru every buffer's undo list
4469 for elements that update markers that were not marked,
4472 register struct buffer
*nextb
= all_buffers
;
4476 /* If a buffer's undo list is Qt, that means that undo is
4477 turned off in that buffer. Calling truncate_undo_list on
4478 Qt tends to return NULL, which effectively turns undo back on.
4479 So don't call truncate_undo_list if undo_list is Qt. */
4480 if (! EQ (nextb
->undo_list
, Qt
))
4482 Lisp_Object tail
, prev
;
4483 tail
= nextb
->undo_list
;
4485 while (CONSP (tail
))
4487 if (GC_CONSP (XCAR (tail
))
4488 && GC_MARKERP (XCAR (XCAR (tail
)))
4489 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
4492 nextb
->undo_list
= tail
= XCDR (tail
);
4496 XSETCDR (prev
, tail
);
4507 nextb
= nextb
->next
;
4511 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4517 extern void xg_mark_data ();
4524 /* Clear the mark bits that we set in certain root slots. */
4526 unmark_byte_stack ();
4527 VECTOR_UNMARK (&buffer_defaults
);
4528 VECTOR_UNMARK (&buffer_local_symbols
);
4530 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4536 /* clear_marks (); */
4539 consing_since_gc
= 0;
4540 if (gc_cons_threshold
< 10000)
4541 gc_cons_threshold
= 10000;
4543 if (garbage_collection_messages
)
4545 if (message_p
|| minibuf_level
> 0)
4548 message1_nolog ("Garbage collecting...done");
4551 unbind_to (count
, Qnil
);
4553 total
[0] = Fcons (make_number (total_conses
),
4554 make_number (total_free_conses
));
4555 total
[1] = Fcons (make_number (total_symbols
),
4556 make_number (total_free_symbols
));
4557 total
[2] = Fcons (make_number (total_markers
),
4558 make_number (total_free_markers
));
4559 total
[3] = make_number (total_string_size
);
4560 total
[4] = make_number (total_vector_size
);
4561 total
[5] = Fcons (make_number (total_floats
),
4562 make_number (total_free_floats
));
4563 total
[6] = Fcons (make_number (total_intervals
),
4564 make_number (total_free_intervals
));
4565 total
[7] = Fcons (make_number (total_strings
),
4566 make_number (total_free_strings
));
4568 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4570 /* Compute average percentage of zombies. */
4573 for (i
= 0; i
< 7; ++i
)
4574 if (CONSP (total
[i
]))
4575 nlive
+= XFASTINT (XCAR (total
[i
]));
4577 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4578 max_live
= max (nlive
, max_live
);
4579 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4580 max_zombies
= max (nzombies
, max_zombies
);
4585 if (!NILP (Vpost_gc_hook
))
4587 int count
= inhibit_garbage_collection ();
4588 safe_run_hooks (Qpost_gc_hook
);
4589 unbind_to (count
, Qnil
);
4592 /* Accumulate statistics. */
4593 EMACS_GET_TIME (t2
);
4594 EMACS_SUB_TIME (t3
, t2
, t1
);
4595 if (FLOATP (Vgc_elapsed
))
4596 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
4598 EMACS_USECS (t3
) * 1.0e-6);
4601 return Flist (sizeof total
/ sizeof *total
, total
);
4605 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4606 only interesting objects referenced from glyphs are strings. */
4609 mark_glyph_matrix (matrix
)
4610 struct glyph_matrix
*matrix
;
4612 struct glyph_row
*row
= matrix
->rows
;
4613 struct glyph_row
*end
= row
+ matrix
->nrows
;
4615 for (; row
< end
; ++row
)
4619 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
4621 struct glyph
*glyph
= row
->glyphs
[area
];
4622 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
4624 for (; glyph
< end_glyph
; ++glyph
)
4625 if (GC_STRINGP (glyph
->object
)
4626 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
4627 mark_object (glyph
->object
);
4633 /* Mark Lisp faces in the face cache C. */
4637 struct face_cache
*c
;
4642 for (i
= 0; i
< c
->used
; ++i
)
4644 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
4648 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
4649 mark_object (face
->lface
[j
]);
4656 #ifdef HAVE_WINDOW_SYSTEM
4658 /* Mark Lisp objects in image IMG. */
4664 mark_object (img
->spec
);
4666 if (!NILP (img
->data
.lisp_val
))
4667 mark_object (img
->data
.lisp_val
);
4671 /* Mark Lisp objects in image cache of frame F. It's done this way so
4672 that we don't have to include xterm.h here. */
4675 mark_image_cache (f
)
4678 forall_images_in_image_cache (f
, mark_image
);
4681 #endif /* HAVE_X_WINDOWS */
4685 /* Mark reference to a Lisp_Object.
4686 If the object referred to has not been seen yet, recursively mark
4687 all the references contained in it. */
4689 #define LAST_MARKED_SIZE 500
4690 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
4691 int last_marked_index
;
4693 /* For debugging--call abort when we cdr down this many
4694 links of a list, in mark_object. In debugging,
4695 the call to abort will hit a breakpoint.
4696 Normally this is zero and the check never goes off. */
4697 int mark_object_loop_halt
;
4703 register Lisp_Object obj
= arg
;
4704 #ifdef GC_CHECK_MARKED_OBJECTS
4712 if (PURE_POINTER_P (XPNTR (obj
)))
4715 last_marked
[last_marked_index
++] = obj
;
4716 if (last_marked_index
== LAST_MARKED_SIZE
)
4717 last_marked_index
= 0;
4719 /* Perform some sanity checks on the objects marked here. Abort if
4720 we encounter an object we know is bogus. This increases GC time
4721 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4722 #ifdef GC_CHECK_MARKED_OBJECTS
4724 po
= (void *) XPNTR (obj
);
4726 /* Check that the object pointed to by PO is known to be a Lisp
4727 structure allocated from the heap. */
4728 #define CHECK_ALLOCATED() \
4730 m = mem_find (po); \
4735 /* Check that the object pointed to by PO is live, using predicate
4737 #define CHECK_LIVE(LIVEP) \
4739 if (!LIVEP (m, po)) \
4743 /* Check both of the above conditions. */
4744 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4746 CHECK_ALLOCATED (); \
4747 CHECK_LIVE (LIVEP); \
4750 #else /* not GC_CHECK_MARKED_OBJECTS */
4752 #define CHECK_ALLOCATED() (void) 0
4753 #define CHECK_LIVE(LIVEP) (void) 0
4754 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4756 #endif /* not GC_CHECK_MARKED_OBJECTS */
4758 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4762 register struct Lisp_String
*ptr
= XSTRING (obj
);
4763 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4764 MARK_INTERVAL_TREE (ptr
->intervals
);
4766 #ifdef GC_CHECK_STRING_BYTES
4767 /* Check that the string size recorded in the string is the
4768 same as the one recorded in the sdata structure. */
4769 CHECK_STRING_BYTES (ptr
);
4770 #endif /* GC_CHECK_STRING_BYTES */
4774 case Lisp_Vectorlike
:
4775 #ifdef GC_CHECK_MARKED_OBJECTS
4777 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4778 && po
!= &buffer_defaults
4779 && po
!= &buffer_local_symbols
)
4781 #endif /* GC_CHECK_MARKED_OBJECTS */
4783 if (GC_BUFFERP (obj
))
4785 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
4787 #ifdef GC_CHECK_MARKED_OBJECTS
4788 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4791 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4796 #endif /* GC_CHECK_MARKED_OBJECTS */
4800 else if (GC_SUBRP (obj
))
4802 else if (GC_COMPILEDP (obj
))
4803 /* We could treat this just like a vector, but it is better to
4804 save the COMPILED_CONSTANTS element for last and avoid
4807 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4808 register EMACS_INT size
= ptr
->size
;
4811 if (VECTOR_MARKED_P (ptr
))
4812 break; /* Already marked */
4814 CHECK_LIVE (live_vector_p
);
4815 VECTOR_MARK (ptr
); /* Else mark it */
4816 size
&= PSEUDOVECTOR_SIZE_MASK
;
4817 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4819 if (i
!= COMPILED_CONSTANTS
)
4820 mark_object (ptr
->contents
[i
]);
4822 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
4825 else if (GC_FRAMEP (obj
))
4827 register struct frame
*ptr
= XFRAME (obj
);
4829 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4830 VECTOR_MARK (ptr
); /* Else mark it */
4832 CHECK_LIVE (live_vector_p
);
4833 mark_object (ptr
->name
);
4834 mark_object (ptr
->icon_name
);
4835 mark_object (ptr
->title
);
4836 mark_object (ptr
->focus_frame
);
4837 mark_object (ptr
->selected_window
);
4838 mark_object (ptr
->minibuffer_window
);
4839 mark_object (ptr
->param_alist
);
4840 mark_object (ptr
->scroll_bars
);
4841 mark_object (ptr
->condemned_scroll_bars
);
4842 mark_object (ptr
->menu_bar_items
);
4843 mark_object (ptr
->face_alist
);
4844 mark_object (ptr
->menu_bar_vector
);
4845 mark_object (ptr
->buffer_predicate
);
4846 mark_object (ptr
->buffer_list
);
4847 mark_object (ptr
->menu_bar_window
);
4848 mark_object (ptr
->tool_bar_window
);
4849 mark_face_cache (ptr
->face_cache
);
4850 #ifdef HAVE_WINDOW_SYSTEM
4851 mark_image_cache (ptr
);
4852 mark_object (ptr
->tool_bar_items
);
4853 mark_object (ptr
->desired_tool_bar_string
);
4854 mark_object (ptr
->current_tool_bar_string
);
4855 #endif /* HAVE_WINDOW_SYSTEM */
4857 else if (GC_BOOL_VECTOR_P (obj
))
4859 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4861 if (VECTOR_MARKED_P (ptr
))
4862 break; /* Already marked */
4863 CHECK_LIVE (live_vector_p
);
4864 VECTOR_MARK (ptr
); /* Else mark it */
4866 else if (GC_WINDOWP (obj
))
4868 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4869 struct window
*w
= XWINDOW (obj
);
4872 /* Stop if already marked. */
4873 if (VECTOR_MARKED_P (ptr
))
4877 CHECK_LIVE (live_vector_p
);
4880 /* There is no Lisp data above The member CURRENT_MATRIX in
4881 struct WINDOW. Stop marking when that slot is reached. */
4883 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4885 mark_object (ptr
->contents
[i
]);
4887 /* Mark glyphs for leaf windows. Marking window matrices is
4888 sufficient because frame matrices use the same glyph
4890 if (NILP (w
->hchild
)
4892 && w
->current_matrix
)
4894 mark_glyph_matrix (w
->current_matrix
);
4895 mark_glyph_matrix (w
->desired_matrix
);
4898 else if (GC_HASH_TABLE_P (obj
))
4900 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4902 /* Stop if already marked. */
4903 if (VECTOR_MARKED_P (h
))
4907 CHECK_LIVE (live_vector_p
);
4910 /* Mark contents. */
4911 /* Do not mark next_free or next_weak.
4912 Being in the next_weak chain
4913 should not keep the hash table alive.
4914 No need to mark `count' since it is an integer. */
4915 mark_object (h
->test
);
4916 mark_object (h
->weak
);
4917 mark_object (h
->rehash_size
);
4918 mark_object (h
->rehash_threshold
);
4919 mark_object (h
->hash
);
4920 mark_object (h
->next
);
4921 mark_object (h
->index
);
4922 mark_object (h
->user_hash_function
);
4923 mark_object (h
->user_cmp_function
);
4925 /* If hash table is not weak, mark all keys and values.
4926 For weak tables, mark only the vector. */
4927 if (GC_NILP (h
->weak
))
4928 mark_object (h
->key_and_value
);
4930 VECTOR_MARK (XVECTOR (h
->key_and_value
));
4934 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4935 register EMACS_INT size
= ptr
->size
;
4938 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4939 CHECK_LIVE (live_vector_p
);
4940 VECTOR_MARK (ptr
); /* Else mark it */
4941 if (size
& PSEUDOVECTOR_FLAG
)
4942 size
&= PSEUDOVECTOR_SIZE_MASK
;
4944 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4945 mark_object (ptr
->contents
[i
]);
4951 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4952 struct Lisp_Symbol
*ptrx
;
4954 if (ptr
->gcmarkbit
) break;
4955 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4957 mark_object (ptr
->value
);
4958 mark_object (ptr
->function
);
4959 mark_object (ptr
->plist
);
4961 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
4962 MARK_STRING (XSTRING (ptr
->xname
));
4963 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
4965 /* Note that we do not mark the obarray of the symbol.
4966 It is safe not to do so because nothing accesses that
4967 slot except to check whether it is nil. */
4971 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4972 XSETSYMBOL (obj
, ptrx
);
4979 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4980 if (XMARKER (obj
)->gcmarkbit
)
4982 XMARKER (obj
)->gcmarkbit
= 1;
4983 switch (XMISCTYPE (obj
))
4985 case Lisp_Misc_Buffer_Local_Value
:
4986 case Lisp_Misc_Some_Buffer_Local_Value
:
4988 register struct Lisp_Buffer_Local_Value
*ptr
4989 = XBUFFER_LOCAL_VALUE (obj
);
4990 /* If the cdr is nil, avoid recursion for the car. */
4991 if (EQ (ptr
->cdr
, Qnil
))
4993 obj
= ptr
->realvalue
;
4996 mark_object (ptr
->realvalue
);
4997 mark_object (ptr
->buffer
);
4998 mark_object (ptr
->frame
);
5003 case Lisp_Misc_Marker
:
5004 /* DO NOT mark thru the marker's chain.
5005 The buffer's markers chain does not preserve markers from gc;
5006 instead, markers are removed from the chain when freed by gc. */
5007 case Lisp_Misc_Intfwd
:
5008 case Lisp_Misc_Boolfwd
:
5009 case Lisp_Misc_Objfwd
:
5010 case Lisp_Misc_Buffer_Objfwd
:
5011 case Lisp_Misc_Kboard_Objfwd
:
5012 /* Don't bother with Lisp_Buffer_Objfwd,
5013 since all markable slots in current buffer marked anyway. */
5014 /* Don't need to do Lisp_Objfwd, since the places they point
5015 are protected with staticpro. */
5016 case Lisp_Misc_Save_Value
:
5019 case Lisp_Misc_Overlay
:
5021 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5022 mark_object (ptr
->start
);
5023 mark_object (ptr
->end
);
5024 mark_object (ptr
->plist
);
5027 XSETMISC (obj
, ptr
->next
);
5040 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5041 if (CONS_MARKED_P (ptr
)) break;
5042 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5044 /* If the cdr is nil, avoid recursion for the car. */
5045 if (EQ (ptr
->cdr
, Qnil
))
5051 mark_object (ptr
->car
);
5054 if (cdr_count
== mark_object_loop_halt
)
5060 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5061 FLOAT_MARK (XFLOAT (obj
));
5072 #undef CHECK_ALLOCATED
5073 #undef CHECK_ALLOCATED_AND_LIVE
5076 /* Mark the pointers in a buffer structure. */
5082 register struct buffer
*buffer
= XBUFFER (buf
);
5083 register Lisp_Object
*ptr
, tmp
;
5084 Lisp_Object base_buffer
;
5086 VECTOR_MARK (buffer
);
5088 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5090 if (CONSP (buffer
->undo_list
))
5093 tail
= buffer
->undo_list
;
5095 /* We mark the undo list specially because
5096 its pointers to markers should be weak. */
5098 while (CONSP (tail
))
5100 register struct Lisp_Cons
*ptr
= XCONS (tail
);
5102 if (CONS_MARKED_P (ptr
))
5105 if (GC_CONSP (ptr
->car
)
5106 && !CONS_MARKED_P (XCONS (ptr
->car
))
5107 && GC_MARKERP (XCAR (ptr
->car
)))
5109 CONS_MARK (XCONS (ptr
->car
));
5110 mark_object (XCDR (ptr
->car
));
5113 mark_object (ptr
->car
);
5115 if (CONSP (ptr
->cdr
))
5121 mark_object (XCDR (tail
));
5124 mark_object (buffer
->undo_list
);
5126 if (buffer
->overlays_before
)
5128 XSETMISC (tmp
, buffer
->overlays_before
);
5131 if (buffer
->overlays_after
)
5133 XSETMISC (tmp
, buffer
->overlays_after
);
5137 for (ptr
= &buffer
->name
;
5138 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5142 /* If this is an indirect buffer, mark its base buffer. */
5143 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5145 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5146 mark_buffer (base_buffer
);
5151 /* Value is non-zero if OBJ will survive the current GC because it's
5152 either marked or does not need to be marked to survive. */
5160 switch (XGCTYPE (obj
))
5167 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5171 survives_p
= XMARKER (obj
)->gcmarkbit
;
5175 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5178 case Lisp_Vectorlike
:
5179 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5183 survives_p
= CONS_MARKED_P (XCONS (obj
));
5187 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5194 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5199 /* Sweep: find all structures not marked, and free them. */
5204 /* Remove or mark entries in weak hash tables.
5205 This must be done before any object is unmarked. */
5206 sweep_weak_hash_tables ();
5209 #ifdef GC_CHECK_STRING_BYTES
5210 if (!noninteractive
)
5211 check_string_bytes (1);
5214 /* Put all unmarked conses on free list */
5216 register struct cons_block
*cblk
;
5217 struct cons_block
**cprev
= &cons_block
;
5218 register int lim
= cons_block_index
;
5219 register int num_free
= 0, num_used
= 0;
5223 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5227 for (i
= 0; i
< lim
; i
++)
5228 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5231 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
5232 cons_free_list
= &cblk
->conses
[i
];
5234 cons_free_list
->car
= Vdead
;
5240 CONS_UNMARK (&cblk
->conses
[i
]);
5242 lim
= CONS_BLOCK_SIZE
;
5243 /* If this block contains only free conses and we have already
5244 seen more than two blocks worth of free conses then deallocate
5246 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5248 *cprev
= cblk
->next
;
5249 /* Unhook from the free list. */
5250 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
5251 lisp_align_free (cblk
);
5256 num_free
+= this_free
;
5257 cprev
= &cblk
->next
;
5260 total_conses
= num_used
;
5261 total_free_conses
= num_free
;
5264 /* Put all unmarked floats on free list */
5266 register struct float_block
*fblk
;
5267 struct float_block
**fprev
= &float_block
;
5268 register int lim
= float_block_index
;
5269 register int num_free
= 0, num_used
= 0;
5271 float_free_list
= 0;
5273 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5277 for (i
= 0; i
< lim
; i
++)
5278 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5281 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
5282 float_free_list
= &fblk
->floats
[i
];
5287 FLOAT_UNMARK (&fblk
->floats
[i
]);
5289 lim
= FLOAT_BLOCK_SIZE
;
5290 /* If this block contains only free floats and we have already
5291 seen more than two blocks worth of free floats then deallocate
5293 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5295 *fprev
= fblk
->next
;
5296 /* Unhook from the free list. */
5297 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5298 lisp_align_free (fblk
);
5303 num_free
+= this_free
;
5304 fprev
= &fblk
->next
;
5307 total_floats
= num_used
;
5308 total_free_floats
= num_free
;
5311 /* Put all unmarked intervals on free list */
5313 register struct interval_block
*iblk
;
5314 struct interval_block
**iprev
= &interval_block
;
5315 register int lim
= interval_block_index
;
5316 register int num_free
= 0, num_used
= 0;
5318 interval_free_list
= 0;
5320 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5325 for (i
= 0; i
< lim
; i
++)
5327 if (!iblk
->intervals
[i
].gcmarkbit
)
5329 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5330 interval_free_list
= &iblk
->intervals
[i
];
5336 iblk
->intervals
[i
].gcmarkbit
= 0;
5339 lim
= INTERVAL_BLOCK_SIZE
;
5340 /* If this block contains only free intervals and we have already
5341 seen more than two blocks worth of free intervals then
5342 deallocate this block. */
5343 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5345 *iprev
= iblk
->next
;
5346 /* Unhook from the free list. */
5347 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5349 n_interval_blocks
--;
5353 num_free
+= this_free
;
5354 iprev
= &iblk
->next
;
5357 total_intervals
= num_used
;
5358 total_free_intervals
= num_free
;
5361 /* Put all unmarked symbols on free list */
5363 register struct symbol_block
*sblk
;
5364 struct symbol_block
**sprev
= &symbol_block
;
5365 register int lim
= symbol_block_index
;
5366 register int num_free
= 0, num_used
= 0;
5368 symbol_free_list
= NULL
;
5370 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5373 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5374 struct Lisp_Symbol
*end
= sym
+ lim
;
5376 for (; sym
< end
; ++sym
)
5378 /* Check if the symbol was created during loadup. In such a case
5379 it might be pointed to by pure bytecode which we don't trace,
5380 so we conservatively assume that it is live. */
5381 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5383 if (!sym
->gcmarkbit
&& !pure_p
)
5385 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5386 symbol_free_list
= sym
;
5388 symbol_free_list
->function
= Vdead
;
5396 UNMARK_STRING (XSTRING (sym
->xname
));
5401 lim
= SYMBOL_BLOCK_SIZE
;
5402 /* If this block contains only free symbols and we have already
5403 seen more than two blocks worth of free symbols then deallocate
5405 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5407 *sprev
= sblk
->next
;
5408 /* Unhook from the free list. */
5409 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5415 num_free
+= this_free
;
5416 sprev
= &sblk
->next
;
5419 total_symbols
= num_used
;
5420 total_free_symbols
= num_free
;
5423 /* Put all unmarked misc's on free list.
5424 For a marker, first unchain it from the buffer it points into. */
5426 register struct marker_block
*mblk
;
5427 struct marker_block
**mprev
= &marker_block
;
5428 register int lim
= marker_block_index
;
5429 register int num_free
= 0, num_used
= 0;
5431 marker_free_list
= 0;
5433 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5438 for (i
= 0; i
< lim
; i
++)
5440 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5442 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5443 unchain_marker (&mblk
->markers
[i
].u_marker
);
5444 /* Set the type of the freed object to Lisp_Misc_Free.
5445 We could leave the type alone, since nobody checks it,
5446 but this might catch bugs faster. */
5447 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5448 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5449 marker_free_list
= &mblk
->markers
[i
];
5455 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5458 lim
= MARKER_BLOCK_SIZE
;
5459 /* If this block contains only free markers and we have already
5460 seen more than two blocks worth of free markers then deallocate
5462 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5464 *mprev
= mblk
->next
;
5465 /* Unhook from the free list. */
5466 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5472 num_free
+= this_free
;
5473 mprev
= &mblk
->next
;
5477 total_markers
= num_used
;
5478 total_free_markers
= num_free
;
5481 /* Free all unmarked buffers */
5483 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5486 if (!VECTOR_MARKED_P (buffer
))
5489 prev
->next
= buffer
->next
;
5491 all_buffers
= buffer
->next
;
5492 next
= buffer
->next
;
5498 VECTOR_UNMARK (buffer
);
5499 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5500 prev
= buffer
, buffer
= buffer
->next
;
5504 /* Free all unmarked vectors */
5506 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5507 total_vector_size
= 0;
5510 if (!VECTOR_MARKED_P (vector
))
5513 prev
->next
= vector
->next
;
5515 all_vectors
= vector
->next
;
5516 next
= vector
->next
;
5524 VECTOR_UNMARK (vector
);
5525 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5526 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5528 total_vector_size
+= vector
->size
;
5529 prev
= vector
, vector
= vector
->next
;
5533 #ifdef GC_CHECK_STRING_BYTES
5534 if (!noninteractive
)
5535 check_string_bytes (1);
5542 /* Debugging aids. */
5544 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5545 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
5546 This may be helpful in debugging Emacs's memory usage.
5547 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
5552 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5557 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5558 doc
: /* Return a list of counters that measure how much consing there has been.
5559 Each of these counters increments for a certain kind of object.
5560 The counters wrap around from the largest positive integer to zero.
5561 Garbage collection does not decrease them.
5562 The elements of the value are as follows:
5563 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
5564 All are in units of 1 = one object consed
5565 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
5567 MISCS include overlays, markers, and some internal types.
5568 Frames, windows, buffers, and subprocesses count as vectors
5569 (but the contents of a buffer's text do not count here). */)
5572 Lisp_Object consed
[8];
5574 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
5575 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
5576 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
5577 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
5578 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
5579 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
5580 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
5581 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
5583 return Flist (8, consed
);
5586 int suppress_checking
;
5588 die (msg
, file
, line
)
5593 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5598 /* Initialization */
5603 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5605 pure_size
= PURESIZE
;
5606 pure_bytes_used
= 0;
5607 pure_bytes_used_before_overflow
= 0;
5609 /* Initialize the list of free aligned blocks. */
5612 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5614 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5618 ignore_warnings
= 1;
5619 #ifdef DOUG_LEA_MALLOC
5620 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5621 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5622 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5632 malloc_hysteresis
= 32;
5634 malloc_hysteresis
= 0;
5637 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5639 ignore_warnings
= 0;
5641 byte_stack_list
= 0;
5643 consing_since_gc
= 0;
5644 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5645 #ifdef VIRT_ADDR_VARIES
5646 malloc_sbrk_unused
= 1<<22; /* A large number */
5647 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5648 #endif /* VIRT_ADDR_VARIES */
5655 byte_stack_list
= 0;
5657 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5658 setjmp_tested_p
= longjmps_done
= 0;
5661 Vgc_elapsed
= make_float (0.0);
5668 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5669 doc
: /* *Number of bytes of consing between garbage collections.
5670 Garbage collection can happen automatically once this many bytes have been
5671 allocated since the last garbage collection. All data types count.
5673 Garbage collection happens automatically only when `eval' is called.
5675 By binding this temporarily to a large number, you can effectively
5676 prevent garbage collection during a part of the program. */);
5678 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5679 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
5681 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5682 doc
: /* Number of cons cells that have been consed so far. */);
5684 DEFVAR_INT ("floats-consed", &floats_consed
,
5685 doc
: /* Number of floats that have been consed so far. */);
5687 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5688 doc
: /* Number of vector cells that have been consed so far. */);
5690 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5691 doc
: /* Number of symbols that have been consed so far. */);
5693 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5694 doc
: /* Number of string characters that have been consed so far. */);
5696 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5697 doc
: /* Number of miscellaneous objects that have been consed so far. */);
5699 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5700 doc
: /* Number of intervals that have been consed so far. */);
5702 DEFVAR_INT ("strings-consed", &strings_consed
,
5703 doc
: /* Number of strings that have been consed so far. */);
5705 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5706 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
5707 This means that certain objects should be allocated in shared (pure) space. */);
5709 DEFVAR_INT ("undo-limit", &undo_limit
,
5710 doc
: /* Keep no more undo information once it exceeds this size.
5711 This limit is applied when garbage collection happens.
5712 The size is counted as the number of bytes occupied,
5713 which includes both saved text and other data. */);
5716 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5717 doc
: /* Don't keep more than this much size of undo information.
5718 A command which pushes past this size is itself forgotten.
5719 This limit is applied when garbage collection happens.
5720 The size is counted as the number of bytes occupied,
5721 which includes both saved text and other data. */);
5722 undo_strong_limit
= 30000;
5724 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5725 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
5726 garbage_collection_messages
= 0;
5728 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
5729 doc
: /* Hook run after garbage collection has finished. */);
5730 Vpost_gc_hook
= Qnil
;
5731 Qpost_gc_hook
= intern ("post-gc-hook");
5732 staticpro (&Qpost_gc_hook
);
5734 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
5735 doc
: /* Precomputed `signal' argument for memory-full error. */);
5736 /* We build this in advance because if we wait until we need it, we might
5737 not be able to allocate the memory to hold it. */
5740 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
5742 DEFVAR_LISP ("memory-full", &Vmemory_full
,
5743 doc
: /* Non-nil means we are handling a memory-full error. */);
5744 Vmemory_full
= Qnil
;
5746 staticpro (&Qgc_cons_threshold
);
5747 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5749 staticpro (&Qchar_table_extra_slots
);
5750 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5752 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
5753 doc
: /* Accumulated time elapsed in garbage collections.
5754 The time is in seconds as a floating point value. */);
5755 DEFVAR_INT ("gcs-done", &gcs_done
,
5756 doc
: /* Accumulated number of garbage collections done. */);
5761 defsubr (&Smake_byte_code
);
5762 defsubr (&Smake_list
);
5763 defsubr (&Smake_vector
);
5764 defsubr (&Smake_char_table
);
5765 defsubr (&Smake_string
);
5766 defsubr (&Smake_bool_vector
);
5767 defsubr (&Smake_symbol
);
5768 defsubr (&Smake_marker
);
5769 defsubr (&Spurecopy
);
5770 defsubr (&Sgarbage_collect
);
5771 defsubr (&Smemory_limit
);
5772 defsubr (&Smemory_use_counts
);
5774 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5775 defsubr (&Sgc_status
);
5779 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
5780 (do not change this comment) */