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 INIT in each element.
1897 LENGTH must be an integer.
1898 INIT must be an integer that represents a character. */)
1900 Lisp_Object length
, init
;
1902 register Lisp_Object val
;
1903 register unsigned char *p
, *end
;
1906 CHECK_NATNUM (length
);
1907 CHECK_NUMBER (init
);
1910 if (SINGLE_BYTE_CHAR_P (c
))
1912 nbytes
= XINT (length
);
1913 val
= make_uninit_string (nbytes
);
1915 end
= p
+ SCHARS (val
);
1921 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1922 int len
= CHAR_STRING (c
, str
);
1924 nbytes
= len
* XINT (length
);
1925 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1930 bcopy (str
, p
, len
);
1940 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1941 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
1942 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
1944 Lisp_Object length
, init
;
1946 register Lisp_Object val
;
1947 struct Lisp_Bool_Vector
*p
;
1949 int length_in_chars
, length_in_elts
, bits_per_value
;
1951 CHECK_NATNUM (length
);
1953 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
1955 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1956 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
1957 / BOOL_VECTOR_BITS_PER_CHAR
);
1959 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1960 slot `size' of the struct Lisp_Bool_Vector. */
1961 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1962 p
= XBOOL_VECTOR (val
);
1964 /* Get rid of any bits that would cause confusion. */
1966 XSETBOOL_VECTOR (val
, p
);
1967 p
->size
= XFASTINT (length
);
1969 real_init
= (NILP (init
) ? 0 : -1);
1970 for (i
= 0; i
< length_in_chars
; i
++)
1971 p
->data
[i
] = real_init
;
1973 /* Clear the extraneous bits in the last byte. */
1974 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
1975 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1976 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
1982 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1983 of characters from the contents. This string may be unibyte or
1984 multibyte, depending on the contents. */
1987 make_string (contents
, nbytes
)
1988 const char *contents
;
1991 register Lisp_Object val
;
1992 int nchars
, multibyte_nbytes
;
1994 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1995 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1996 /* CONTENTS contains no multibyte sequences or contains an invalid
1997 multibyte sequence. We must make unibyte string. */
1998 val
= make_unibyte_string (contents
, nbytes
);
2000 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2005 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2008 make_unibyte_string (contents
, length
)
2009 const char *contents
;
2012 register Lisp_Object val
;
2013 val
= make_uninit_string (length
);
2014 bcopy (contents
, SDATA (val
), length
);
2015 STRING_SET_UNIBYTE (val
);
2020 /* Make a multibyte string from NCHARS characters occupying NBYTES
2021 bytes at CONTENTS. */
2024 make_multibyte_string (contents
, nchars
, nbytes
)
2025 const char *contents
;
2028 register Lisp_Object val
;
2029 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2030 bcopy (contents
, SDATA (val
), nbytes
);
2035 /* Make a string from NCHARS characters occupying NBYTES bytes at
2036 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2039 make_string_from_bytes (contents
, nchars
, nbytes
)
2040 const char *contents
;
2043 register Lisp_Object val
;
2044 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2045 bcopy (contents
, SDATA (val
), nbytes
);
2046 if (SBYTES (val
) == SCHARS (val
))
2047 STRING_SET_UNIBYTE (val
);
2052 /* Make a string from NCHARS characters occupying NBYTES bytes at
2053 CONTENTS. The argument MULTIBYTE controls whether to label the
2054 string as multibyte. If NCHARS is negative, it counts the number of
2055 characters by itself. */
2058 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2059 const char *contents
;
2063 register Lisp_Object val
;
2068 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2072 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2073 bcopy (contents
, SDATA (val
), nbytes
);
2075 STRING_SET_UNIBYTE (val
);
2080 /* Make a string from the data at STR, treating it as multibyte if the
2087 return make_string (str
, strlen (str
));
2091 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2092 occupying LENGTH bytes. */
2095 make_uninit_string (length
)
2099 val
= make_uninit_multibyte_string (length
, length
);
2100 STRING_SET_UNIBYTE (val
);
2105 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2106 which occupy NBYTES bytes. */
2109 make_uninit_multibyte_string (nchars
, nbytes
)
2113 struct Lisp_String
*s
;
2118 s
= allocate_string ();
2119 allocate_string_data (s
, nchars
, nbytes
);
2120 XSETSTRING (string
, s
);
2121 string_chars_consed
+= nbytes
;
2127 /***********************************************************************
2129 ***********************************************************************/
2131 /* We store float cells inside of float_blocks, allocating a new
2132 float_block with malloc whenever necessary. Float cells reclaimed
2133 by GC are put on a free list to be reallocated before allocating
2134 any new float cells from the latest float_block. */
2136 #define FLOAT_BLOCK_SIZE \
2137 (((BLOCK_BYTES - sizeof (struct float_block *) \
2138 /* The compiler might add padding at the end. */ \
2139 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2140 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2142 #define GETMARKBIT(block,n) \
2143 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2144 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2147 #define SETMARKBIT(block,n) \
2148 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2149 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2151 #define UNSETMARKBIT(block,n) \
2152 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2153 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2155 #define FLOAT_BLOCK(fptr) \
2156 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2158 #define FLOAT_INDEX(fptr) \
2159 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2163 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2164 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2165 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2166 struct float_block
*next
;
2169 #define FLOAT_MARKED_P(fptr) \
2170 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2172 #define FLOAT_MARK(fptr) \
2173 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2175 #define FLOAT_UNMARK(fptr) \
2176 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2178 /* Current float_block. */
2180 struct float_block
*float_block
;
2182 /* Index of first unused Lisp_Float in the current float_block. */
2184 int float_block_index
;
2186 /* Total number of float blocks now in use. */
2190 /* Free-list of Lisp_Floats. */
2192 struct Lisp_Float
*float_free_list
;
2195 /* Initialize float allocation. */
2201 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2202 float_free_list
= 0;
2207 /* Explicitly free a float cell by putting it on the free-list. */
2211 struct Lisp_Float
*ptr
;
2213 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
2214 float_free_list
= ptr
;
2218 /* Return a new float object with value FLOAT_VALUE. */
2221 make_float (float_value
)
2224 register Lisp_Object val
;
2226 if (float_free_list
)
2228 /* We use the data field for chaining the free list
2229 so that we won't use the same field that has the mark bit. */
2230 XSETFLOAT (val
, float_free_list
);
2231 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
2235 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2237 register struct float_block
*new;
2239 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2241 new->next
= float_block
;
2242 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2244 float_block_index
= 0;
2247 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2248 float_block_index
++;
2251 XFLOAT_DATA (val
) = float_value
;
2252 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2253 consing_since_gc
+= sizeof (struct Lisp_Float
);
2260 /***********************************************************************
2262 ***********************************************************************/
2264 /* We store cons cells inside of cons_blocks, allocating a new
2265 cons_block with malloc whenever necessary. Cons cells reclaimed by
2266 GC are put on a free list to be reallocated before allocating
2267 any new cons cells from the latest cons_block. */
2269 #define CONS_BLOCK_SIZE \
2270 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2271 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2273 #define CONS_BLOCK(fptr) \
2274 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2276 #define CONS_INDEX(fptr) \
2277 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2281 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2282 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2283 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2284 struct cons_block
*next
;
2287 #define CONS_MARKED_P(fptr) \
2288 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2290 #define CONS_MARK(fptr) \
2291 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2293 #define CONS_UNMARK(fptr) \
2294 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2296 /* Current cons_block. */
2298 struct cons_block
*cons_block
;
2300 /* Index of first unused Lisp_Cons in the current block. */
2302 int cons_block_index
;
2304 /* Free-list of Lisp_Cons structures. */
2306 struct Lisp_Cons
*cons_free_list
;
2308 /* Total number of cons blocks now in use. */
2313 /* Initialize cons allocation. */
2319 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2325 /* Explicitly free a cons cell by putting it on the free-list. */
2329 struct Lisp_Cons
*ptr
;
2331 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2335 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 /* Marker blocks which should be freed at end of GC. */
2870 struct marker_block
*marker_blocks_pending_free
;
2872 /* Total number of marker blocks now in use. */
2874 int n_marker_blocks
;
2879 marker_block
= NULL
;
2880 marker_block_index
= MARKER_BLOCK_SIZE
;
2881 marker_free_list
= 0;
2882 marker_blocks_pending_free
= 0;
2883 n_marker_blocks
= 0;
2886 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2893 if (marker_free_list
)
2895 XSETMISC (val
, marker_free_list
);
2896 marker_free_list
= marker_free_list
->u_free
.chain
;
2900 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2902 struct marker_block
*new;
2903 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2905 new->next
= marker_block
;
2907 marker_block_index
= 0;
2910 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
2911 marker_block_index
++;
2914 consing_since_gc
+= sizeof (union Lisp_Misc
);
2915 misc_objects_consed
++;
2916 XMARKER (val
)->gcmarkbit
= 0;
2920 /* Return a Lisp_Misc_Save_Value object containing POINTER and
2921 INTEGER. This is used to package C values to call record_unwind_protect.
2922 The unwind function can get the C values back using XSAVE_VALUE. */
2925 make_save_value (pointer
, integer
)
2929 register Lisp_Object val
;
2930 register struct Lisp_Save_Value
*p
;
2932 val
= allocate_misc ();
2933 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
2934 p
= XSAVE_VALUE (val
);
2935 p
->pointer
= pointer
;
2936 p
->integer
= integer
;
2940 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2941 doc
: /* Return a newly allocated marker which does not point at any place. */)
2944 register Lisp_Object val
;
2945 register struct Lisp_Marker
*p
;
2947 val
= allocate_misc ();
2948 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2954 p
->insertion_type
= 0;
2958 /* Put MARKER back on the free list after using it temporarily. */
2961 free_marker (marker
)
2964 unchain_marker (XMARKER (marker
));
2966 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2967 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2968 marker_free_list
= XMISC (marker
);
2970 total_free_markers
++;
2974 /* Return a newly created vector or string with specified arguments as
2975 elements. If all the arguments are characters that can fit
2976 in a string of events, make a string; otherwise, make a vector.
2978 Any number of arguments, even zero arguments, are allowed. */
2981 make_event_array (nargs
, args
)
2987 for (i
= 0; i
< nargs
; i
++)
2988 /* The things that fit in a string
2989 are characters that are in 0...127,
2990 after discarding the meta bit and all the bits above it. */
2991 if (!INTEGERP (args
[i
])
2992 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2993 return Fvector (nargs
, args
);
2995 /* Since the loop exited, we know that all the things in it are
2996 characters, so we can make a string. */
3000 result
= Fmake_string (make_number (nargs
), make_number (0));
3001 for (i
= 0; i
< nargs
; i
++)
3003 SSET (result
, i
, XINT (args
[i
]));
3004 /* Move the meta bit to the right place for a string char. */
3005 if (XINT (args
[i
]) & CHAR_META
)
3006 SSET (result
, i
, SREF (result
, i
) | 0x80);
3015 /************************************************************************
3017 ************************************************************************/
3019 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3021 /* Conservative C stack marking requires a method to identify possibly
3022 live Lisp objects given a pointer value. We do this by keeping
3023 track of blocks of Lisp data that are allocated in a red-black tree
3024 (see also the comment of mem_node which is the type of nodes in
3025 that tree). Function lisp_malloc adds information for an allocated
3026 block to the red-black tree with calls to mem_insert, and function
3027 lisp_free removes it with mem_delete. Functions live_string_p etc
3028 call mem_find to lookup information about a given pointer in the
3029 tree, and use that to determine if the pointer points to a Lisp
3032 /* Initialize this part of alloc.c. */
3037 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3038 mem_z
.parent
= NULL
;
3039 mem_z
.color
= MEM_BLACK
;
3040 mem_z
.start
= mem_z
.end
= NULL
;
3045 /* Value is a pointer to the mem_node containing START. Value is
3046 MEM_NIL if there is no node in the tree containing START. */
3048 static INLINE
struct mem_node
*
3054 if (start
< min_heap_address
|| start
> max_heap_address
)
3057 /* Make the search always successful to speed up the loop below. */
3058 mem_z
.start
= start
;
3059 mem_z
.end
= (char *) start
+ 1;
3062 while (start
< p
->start
|| start
>= p
->end
)
3063 p
= start
< p
->start
? p
->left
: p
->right
;
3068 /* Insert a new node into the tree for a block of memory with start
3069 address START, end address END, and type TYPE. Value is a
3070 pointer to the node that was inserted. */
3072 static struct mem_node
*
3073 mem_insert (start
, end
, type
)
3077 struct mem_node
*c
, *parent
, *x
;
3079 if (start
< min_heap_address
)
3080 min_heap_address
= start
;
3081 if (end
> max_heap_address
)
3082 max_heap_address
= end
;
3084 /* See where in the tree a node for START belongs. In this
3085 particular application, it shouldn't happen that a node is already
3086 present. For debugging purposes, let's check that. */
3090 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3092 while (c
!= MEM_NIL
)
3094 if (start
>= c
->start
&& start
< c
->end
)
3097 c
= start
< c
->start
? c
->left
: c
->right
;
3100 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3102 while (c
!= MEM_NIL
)
3105 c
= start
< c
->start
? c
->left
: c
->right
;
3108 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3110 /* Create a new node. */
3111 #ifdef GC_MALLOC_CHECK
3112 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3116 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3122 x
->left
= x
->right
= MEM_NIL
;
3125 /* Insert it as child of PARENT or install it as root. */
3128 if (start
< parent
->start
)
3136 /* Re-establish red-black tree properties. */
3137 mem_insert_fixup (x
);
3143 /* Re-establish the red-black properties of the tree, and thereby
3144 balance the tree, after node X has been inserted; X is always red. */
3147 mem_insert_fixup (x
)
3150 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3152 /* X is red and its parent is red. This is a violation of
3153 red-black tree property #3. */
3155 if (x
->parent
== x
->parent
->parent
->left
)
3157 /* We're on the left side of our grandparent, and Y is our
3159 struct mem_node
*y
= x
->parent
->parent
->right
;
3161 if (y
->color
== MEM_RED
)
3163 /* Uncle and parent are red but should be black because
3164 X is red. Change the colors accordingly and proceed
3165 with the grandparent. */
3166 x
->parent
->color
= MEM_BLACK
;
3167 y
->color
= MEM_BLACK
;
3168 x
->parent
->parent
->color
= MEM_RED
;
3169 x
= x
->parent
->parent
;
3173 /* Parent and uncle have different colors; parent is
3174 red, uncle is black. */
3175 if (x
== x
->parent
->right
)
3178 mem_rotate_left (x
);
3181 x
->parent
->color
= MEM_BLACK
;
3182 x
->parent
->parent
->color
= MEM_RED
;
3183 mem_rotate_right (x
->parent
->parent
);
3188 /* This is the symmetrical case of above. */
3189 struct mem_node
*y
= x
->parent
->parent
->left
;
3191 if (y
->color
== MEM_RED
)
3193 x
->parent
->color
= MEM_BLACK
;
3194 y
->color
= MEM_BLACK
;
3195 x
->parent
->parent
->color
= MEM_RED
;
3196 x
= x
->parent
->parent
;
3200 if (x
== x
->parent
->left
)
3203 mem_rotate_right (x
);
3206 x
->parent
->color
= MEM_BLACK
;
3207 x
->parent
->parent
->color
= MEM_RED
;
3208 mem_rotate_left (x
->parent
->parent
);
3213 /* The root may have been changed to red due to the algorithm. Set
3214 it to black so that property #5 is satisfied. */
3215 mem_root
->color
= MEM_BLACK
;
3231 /* Turn y's left sub-tree into x's right sub-tree. */
3234 if (y
->left
!= MEM_NIL
)
3235 y
->left
->parent
= x
;
3237 /* Y's parent was x's parent. */
3239 y
->parent
= x
->parent
;
3241 /* Get the parent to point to y instead of x. */
3244 if (x
== x
->parent
->left
)
3245 x
->parent
->left
= y
;
3247 x
->parent
->right
= y
;
3252 /* Put x on y's left. */
3266 mem_rotate_right (x
)
3269 struct mem_node
*y
= x
->left
;
3272 if (y
->right
!= MEM_NIL
)
3273 y
->right
->parent
= x
;
3276 y
->parent
= x
->parent
;
3279 if (x
== x
->parent
->right
)
3280 x
->parent
->right
= y
;
3282 x
->parent
->left
= y
;
3293 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3299 struct mem_node
*x
, *y
;
3301 if (!z
|| z
== MEM_NIL
)
3304 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3309 while (y
->left
!= MEM_NIL
)
3313 if (y
->left
!= MEM_NIL
)
3318 x
->parent
= y
->parent
;
3321 if (y
== y
->parent
->left
)
3322 y
->parent
->left
= x
;
3324 y
->parent
->right
= x
;
3331 z
->start
= y
->start
;
3336 if (y
->color
== MEM_BLACK
)
3337 mem_delete_fixup (x
);
3339 #ifdef GC_MALLOC_CHECK
3347 /* Re-establish the red-black properties of the tree, after a
3351 mem_delete_fixup (x
)
3354 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3356 if (x
== x
->parent
->left
)
3358 struct mem_node
*w
= x
->parent
->right
;
3360 if (w
->color
== MEM_RED
)
3362 w
->color
= MEM_BLACK
;
3363 x
->parent
->color
= MEM_RED
;
3364 mem_rotate_left (x
->parent
);
3365 w
= x
->parent
->right
;
3368 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3375 if (w
->right
->color
== MEM_BLACK
)
3377 w
->left
->color
= MEM_BLACK
;
3379 mem_rotate_right (w
);
3380 w
= x
->parent
->right
;
3382 w
->color
= x
->parent
->color
;
3383 x
->parent
->color
= MEM_BLACK
;
3384 w
->right
->color
= MEM_BLACK
;
3385 mem_rotate_left (x
->parent
);
3391 struct mem_node
*w
= x
->parent
->left
;
3393 if (w
->color
== MEM_RED
)
3395 w
->color
= MEM_BLACK
;
3396 x
->parent
->color
= MEM_RED
;
3397 mem_rotate_right (x
->parent
);
3398 w
= x
->parent
->left
;
3401 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3408 if (w
->left
->color
== MEM_BLACK
)
3410 w
->right
->color
= MEM_BLACK
;
3412 mem_rotate_left (w
);
3413 w
= x
->parent
->left
;
3416 w
->color
= x
->parent
->color
;
3417 x
->parent
->color
= MEM_BLACK
;
3418 w
->left
->color
= MEM_BLACK
;
3419 mem_rotate_right (x
->parent
);
3425 x
->color
= MEM_BLACK
;
3429 /* Value is non-zero if P is a pointer to a live Lisp string on
3430 the heap. M is a pointer to the mem_block for P. */
3433 live_string_p (m
, p
)
3437 if (m
->type
== MEM_TYPE_STRING
)
3439 struct string_block
*b
= (struct string_block
*) m
->start
;
3440 int offset
= (char *) p
- (char *) &b
->strings
[0];
3442 /* P must point to the start of a Lisp_String structure, and it
3443 must not be on the free-list. */
3445 && offset
% sizeof b
->strings
[0] == 0
3446 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3447 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3454 /* Value is non-zero if P is a pointer to a live Lisp cons on
3455 the heap. M is a pointer to the mem_block for P. */
3462 if (m
->type
== MEM_TYPE_CONS
)
3464 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3465 int offset
= (char *) p
- (char *) &b
->conses
[0];
3467 /* P must point to the start of a Lisp_Cons, not be
3468 one of the unused cells in the current cons block,
3469 and not be on the free-list. */
3471 && offset
% sizeof b
->conses
[0] == 0
3472 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3474 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3475 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3482 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3483 the heap. M is a pointer to the mem_block for P. */
3486 live_symbol_p (m
, p
)
3490 if (m
->type
== MEM_TYPE_SYMBOL
)
3492 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3493 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3495 /* P must point to the start of a Lisp_Symbol, not be
3496 one of the unused cells in the current symbol block,
3497 and not be on the free-list. */
3499 && offset
% sizeof b
->symbols
[0] == 0
3500 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3501 && (b
!= symbol_block
3502 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3503 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3510 /* Value is non-zero if P is a pointer to a live Lisp float on
3511 the heap. M is a pointer to the mem_block for P. */
3518 if (m
->type
== MEM_TYPE_FLOAT
)
3520 struct float_block
*b
= (struct float_block
*) m
->start
;
3521 int offset
= (char *) p
- (char *) &b
->floats
[0];
3523 /* P must point to the start of a Lisp_Float and not be
3524 one of the unused cells in the current float block. */
3526 && offset
% sizeof b
->floats
[0] == 0
3527 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3528 && (b
!= float_block
3529 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3536 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3537 the heap. M is a pointer to the mem_block for P. */
3544 if (m
->type
== MEM_TYPE_MISC
)
3546 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3547 int offset
= (char *) p
- (char *) &b
->markers
[0];
3549 /* P must point to the start of a Lisp_Misc, not be
3550 one of the unused cells in the current misc block,
3551 and not be on the free-list. */
3553 && offset
% sizeof b
->markers
[0] == 0
3554 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3555 && (b
!= marker_block
3556 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3557 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3564 /* Value is non-zero if P is a pointer to a live vector-like object.
3565 M is a pointer to the mem_block for P. */
3568 live_vector_p (m
, p
)
3572 return (p
== m
->start
3573 && m
->type
>= MEM_TYPE_VECTOR
3574 && m
->type
<= MEM_TYPE_WINDOW
);
3578 /* Value is non-zero if P is a pointer to a live buffer. M is a
3579 pointer to the mem_block for P. */
3582 live_buffer_p (m
, p
)
3586 /* P must point to the start of the block, and the buffer
3587 must not have been killed. */
3588 return (m
->type
== MEM_TYPE_BUFFER
3590 && !NILP (((struct buffer
*) p
)->name
));
3593 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3597 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3599 /* Array of objects that are kept alive because the C stack contains
3600 a pattern that looks like a reference to them . */
3602 #define MAX_ZOMBIES 10
3603 static Lisp_Object zombies
[MAX_ZOMBIES
];
3605 /* Number of zombie objects. */
3607 static int nzombies
;
3609 /* Number of garbage collections. */
3613 /* Average percentage of zombies per collection. */
3615 static double avg_zombies
;
3617 /* Max. number of live and zombie objects. */
3619 static int max_live
, max_zombies
;
3621 /* Average number of live objects per GC. */
3623 static double avg_live
;
3625 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3626 doc
: /* Show information about live and zombie objects. */)
3629 Lisp_Object args
[8], zombie_list
= Qnil
;
3631 for (i
= 0; i
< nzombies
; i
++)
3632 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3633 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3634 args
[1] = make_number (ngcs
);
3635 args
[2] = make_float (avg_live
);
3636 args
[3] = make_float (avg_zombies
);
3637 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3638 args
[5] = make_number (max_live
);
3639 args
[6] = make_number (max_zombies
);
3640 args
[7] = zombie_list
;
3641 return Fmessage (8, args
);
3644 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3647 /* Mark OBJ if we can prove it's a Lisp_Object. */
3650 mark_maybe_object (obj
)
3653 void *po
= (void *) XPNTR (obj
);
3654 struct mem_node
*m
= mem_find (po
);
3660 switch (XGCTYPE (obj
))
3663 mark_p
= (live_string_p (m
, po
)
3664 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3668 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
3672 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
3676 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
3679 case Lisp_Vectorlike
:
3680 /* Note: can't check GC_BUFFERP before we know it's a
3681 buffer because checking that dereferences the pointer
3682 PO which might point anywhere. */
3683 if (live_vector_p (m
, po
))
3684 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
3685 else if (live_buffer_p (m
, po
))
3686 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
3690 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
3694 case Lisp_Type_Limit
:
3700 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3701 if (nzombies
< MAX_ZOMBIES
)
3702 zombies
[nzombies
] = obj
;
3711 /* If P points to Lisp data, mark that as live if it isn't already
3715 mark_maybe_pointer (p
)
3720 /* Quickly rule out some values which can't point to Lisp data. We
3721 assume that Lisp data is aligned on even addresses. */
3722 if ((EMACS_INT
) p
& 1)
3728 Lisp_Object obj
= Qnil
;
3732 case MEM_TYPE_NON_LISP
:
3733 /* Nothing to do; not a pointer to Lisp memory. */
3736 case MEM_TYPE_BUFFER
:
3737 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
3738 XSETVECTOR (obj
, p
);
3742 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
3746 case MEM_TYPE_STRING
:
3747 if (live_string_p (m
, p
)
3748 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
3749 XSETSTRING (obj
, p
);
3753 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
3757 case MEM_TYPE_SYMBOL
:
3758 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
3759 XSETSYMBOL (obj
, p
);
3762 case MEM_TYPE_FLOAT
:
3763 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
3767 case MEM_TYPE_VECTOR
:
3768 case MEM_TYPE_PROCESS
:
3769 case MEM_TYPE_HASH_TABLE
:
3770 case MEM_TYPE_FRAME
:
3771 case MEM_TYPE_WINDOW
:
3772 if (live_vector_p (m
, p
))
3775 XSETVECTOR (tem
, p
);
3776 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
3791 /* Mark Lisp objects referenced from the address range START..END. */
3794 mark_memory (start
, end
)
3800 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3804 /* Make START the pointer to the start of the memory region,
3805 if it isn't already. */
3813 /* Mark Lisp_Objects. */
3814 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3815 mark_maybe_object (*p
);
3817 /* Mark Lisp data pointed to. This is necessary because, in some
3818 situations, the C compiler optimizes Lisp objects away, so that
3819 only a pointer to them remains. Example:
3821 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
3824 Lisp_Object obj = build_string ("test");
3825 struct Lisp_String *s = XSTRING (obj);
3826 Fgarbage_collect ();
3827 fprintf (stderr, "test `%s'\n", s->data);
3831 Here, `obj' isn't really used, and the compiler optimizes it
3832 away. The only reference to the life string is through the
3835 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
3836 mark_maybe_pointer (*pp
);
3839 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
3840 the GCC system configuration. In gcc 3.2, the only systems for
3841 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
3842 by others?) and ns32k-pc532-min. */
3844 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3846 static int setjmp_tested_p
, longjmps_done
;
3848 #define SETJMP_WILL_LIKELY_WORK "\
3850 Emacs garbage collector has been changed to use conservative stack\n\
3851 marking. Emacs has determined that the method it uses to do the\n\
3852 marking will likely work on your system, but this isn't sure.\n\
3854 If you are a system-programmer, or can get the help of a local wizard\n\
3855 who is, please take a look at the function mark_stack in alloc.c, and\n\
3856 verify that the methods used are appropriate for your system.\n\
3858 Please mail the result to <emacs-devel@gnu.org>.\n\
3861 #define SETJMP_WILL_NOT_WORK "\
3863 Emacs garbage collector has been changed to use conservative stack\n\
3864 marking. Emacs has determined that the default method it uses to do the\n\
3865 marking will not work on your system. We will need a system-dependent\n\
3866 solution for your system.\n\
3868 Please take a look at the function mark_stack in alloc.c, and\n\
3869 try to find a way to make it work on your system.\n\
3871 Note that you may get false negatives, depending on the compiler.\n\
3872 In particular, you need to use -O with GCC for this test.\n\
3874 Please mail the result to <emacs-devel@gnu.org>.\n\
3878 /* Perform a quick check if it looks like setjmp saves registers in a
3879 jmp_buf. Print a message to stderr saying so. When this test
3880 succeeds, this is _not_ a proof that setjmp is sufficient for
3881 conservative stack marking. Only the sources or a disassembly
3892 /* Arrange for X to be put in a register. */
3898 if (longjmps_done
== 1)
3900 /* Came here after the longjmp at the end of the function.
3902 If x == 1, the longjmp has restored the register to its
3903 value before the setjmp, and we can hope that setjmp
3904 saves all such registers in the jmp_buf, although that
3907 For other values of X, either something really strange is
3908 taking place, or the setjmp just didn't save the register. */
3911 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3914 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3921 if (longjmps_done
== 1)
3925 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3928 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3930 /* Abort if anything GCPRO'd doesn't survive the GC. */
3938 for (p
= gcprolist
; p
; p
= p
->next
)
3939 for (i
= 0; i
< p
->nvars
; ++i
)
3940 if (!survives_gc_p (p
->var
[i
]))
3941 /* FIXME: It's not necessarily a bug. It might just be that the
3942 GCPRO is unnecessary or should release the object sooner. */
3946 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3953 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3954 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3956 fprintf (stderr
, " %d = ", i
);
3957 debug_print (zombies
[i
]);
3961 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3964 /* Mark live Lisp objects on the C stack.
3966 There are several system-dependent problems to consider when
3967 porting this to new architectures:
3971 We have to mark Lisp objects in CPU registers that can hold local
3972 variables or are used to pass parameters.
3974 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3975 something that either saves relevant registers on the stack, or
3976 calls mark_maybe_object passing it each register's contents.
3978 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3979 implementation assumes that calling setjmp saves registers we need
3980 to see in a jmp_buf which itself lies on the stack. This doesn't
3981 have to be true! It must be verified for each system, possibly
3982 by taking a look at the source code of setjmp.
3986 Architectures differ in the way their processor stack is organized.
3987 For example, the stack might look like this
3990 | Lisp_Object | size = 4
3992 | something else | size = 2
3994 | Lisp_Object | size = 4
3998 In such a case, not every Lisp_Object will be aligned equally. To
3999 find all Lisp_Object on the stack it won't be sufficient to walk
4000 the stack in steps of 4 bytes. Instead, two passes will be
4001 necessary, one starting at the start of the stack, and a second
4002 pass starting at the start of the stack + 2. Likewise, if the
4003 minimal alignment of Lisp_Objects on the stack is 1, four passes
4004 would be necessary, each one starting with one byte more offset
4005 from the stack start.
4007 The current code assumes by default that Lisp_Objects are aligned
4008 equally on the stack. */
4015 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4018 /* This trick flushes the register windows so that all the state of
4019 the process is contained in the stack. */
4020 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4021 needed on ia64 too. See mach_dep.c, where it also says inline
4022 assembler doesn't work with relevant proprietary compilers. */
4027 /* Save registers that we need to see on the stack. We need to see
4028 registers used to hold register variables and registers used to
4030 #ifdef GC_SAVE_REGISTERS_ON_STACK
4031 GC_SAVE_REGISTERS_ON_STACK (end
);
4032 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4034 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4035 setjmp will definitely work, test it
4036 and print a message with the result
4038 if (!setjmp_tested_p
)
4040 setjmp_tested_p
= 1;
4043 #endif /* GC_SETJMP_WORKS */
4046 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4047 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4049 /* This assumes that the stack is a contiguous region in memory. If
4050 that's not the case, something has to be done here to iterate
4051 over the stack segments. */
4052 #ifndef GC_LISP_OBJECT_ALIGNMENT
4054 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4056 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4059 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4060 mark_memory ((char *) stack_base
+ i
, end
);
4062 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4068 #endif /* GC_MARK_STACK != 0 */
4072 /***********************************************************************
4073 Pure Storage Management
4074 ***********************************************************************/
4076 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4077 pointer to it. TYPE is the Lisp type for which the memory is
4078 allocated. TYPE < 0 means it's not used for a Lisp object.
4080 If store_pure_type_info is set and TYPE is >= 0, the type of
4081 the allocated object is recorded in pure_types. */
4083 static POINTER_TYPE
*
4084 pure_alloc (size
, type
)
4088 POINTER_TYPE
*result
;
4090 size_t alignment
= (1 << GCTYPEBITS
);
4092 size_t alignment
= sizeof (EMACS_INT
);
4094 /* Give Lisp_Floats an extra alignment. */
4095 if (type
== Lisp_Float
)
4097 #if defined __GNUC__ && __GNUC__ >= 2
4098 alignment
= __alignof (struct Lisp_Float
);
4100 alignment
= sizeof (struct Lisp_Float
);
4106 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4107 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4109 if (pure_bytes_used
<= pure_size
)
4112 /* Don't allocate a large amount here,
4113 because it might get mmap'd and then its address
4114 might not be usable. */
4115 purebeg
= (char *) xmalloc (10000);
4117 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4118 pure_bytes_used
= 0;
4123 /* Print a warning if PURESIZE is too small. */
4128 if (pure_bytes_used_before_overflow
)
4129 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4130 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4134 /* Return a string allocated in pure space. DATA is a buffer holding
4135 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4136 non-zero means make the result string multibyte.
4138 Must get an error if pure storage is full, since if it cannot hold
4139 a large string it may be able to hold conses that point to that
4140 string; then the string is not protected from gc. */
4143 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4149 struct Lisp_String
*s
;
4151 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4152 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4154 s
->size_byte
= multibyte
? nbytes
: -1;
4155 bcopy (data
, s
->data
, nbytes
);
4156 s
->data
[nbytes
] = '\0';
4157 s
->intervals
= NULL_INTERVAL
;
4158 XSETSTRING (string
, s
);
4163 /* Return a cons allocated from pure space. Give it pure copies
4164 of CAR as car and CDR as cdr. */
4167 pure_cons (car
, cdr
)
4168 Lisp_Object car
, cdr
;
4170 register Lisp_Object
new;
4171 struct Lisp_Cons
*p
;
4173 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4175 XSETCAR (new, Fpurecopy (car
));
4176 XSETCDR (new, Fpurecopy (cdr
));
4181 /* Value is a float object with value NUM allocated from pure space. */
4184 make_pure_float (num
)
4187 register Lisp_Object
new;
4188 struct Lisp_Float
*p
;
4190 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4192 XFLOAT_DATA (new) = num
;
4197 /* Return a vector with room for LEN Lisp_Objects allocated from
4201 make_pure_vector (len
)
4205 struct Lisp_Vector
*p
;
4206 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4208 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4209 XSETVECTOR (new, p
);
4210 XVECTOR (new)->size
= len
;
4215 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4216 doc
: /* Make a copy of OBJECT in pure storage.
4217 Recursively copies contents of vectors and cons cells.
4218 Does not copy symbols. Copies strings without text properties. */)
4220 register Lisp_Object obj
;
4222 if (NILP (Vpurify_flag
))
4225 if (PURE_POINTER_P (XPNTR (obj
)))
4229 return pure_cons (XCAR (obj
), XCDR (obj
));
4230 else if (FLOATP (obj
))
4231 return make_pure_float (XFLOAT_DATA (obj
));
4232 else if (STRINGP (obj
))
4233 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4235 STRING_MULTIBYTE (obj
));
4236 else if (COMPILEDP (obj
) || VECTORP (obj
))
4238 register struct Lisp_Vector
*vec
;
4242 size
= XVECTOR (obj
)->size
;
4243 if (size
& PSEUDOVECTOR_FLAG
)
4244 size
&= PSEUDOVECTOR_SIZE_MASK
;
4245 vec
= XVECTOR (make_pure_vector (size
));
4246 for (i
= 0; i
< size
; i
++)
4247 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4248 if (COMPILEDP (obj
))
4249 XSETCOMPILED (obj
, vec
);
4251 XSETVECTOR (obj
, vec
);
4254 else if (MARKERP (obj
))
4255 error ("Attempt to copy a marker to pure storage");
4262 /***********************************************************************
4264 ***********************************************************************/
4266 /* Put an entry in staticvec, pointing at the variable with address
4270 staticpro (varaddress
)
4271 Lisp_Object
*varaddress
;
4273 staticvec
[staticidx
++] = varaddress
;
4274 if (staticidx
>= NSTATICS
)
4282 struct catchtag
*next
;
4287 struct backtrace
*next
;
4288 Lisp_Object
*function
;
4289 Lisp_Object
*args
; /* Points to vector of args. */
4290 int nargs
; /* Length of vector. */
4291 /* If nargs is UNEVALLED, args points to slot holding list of
4294 /* Nonzero means call value of debugger when done with this operation. */
4300 /***********************************************************************
4302 ***********************************************************************/
4304 /* Temporarily prevent garbage collection. */
4307 inhibit_garbage_collection ()
4309 int count
= SPECPDL_INDEX ();
4310 int nbits
= min (VALBITS
, BITS_PER_INT
);
4312 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4317 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4318 doc
: /* Reclaim storage for Lisp objects no longer needed.
4319 Garbage collection happens automatically if you cons more than
4320 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4321 `garbage-collect' normally returns a list with info on amount of space in use:
4322 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4323 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4324 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4325 (USED-STRINGS . FREE-STRINGS))
4326 However, if there was overflow in pure space, `garbage-collect'
4327 returns nil, because real GC can't be done. */)
4330 register struct specbinding
*bind
;
4331 struct catchtag
*catch;
4332 struct handler
*handler
;
4333 register struct backtrace
*backlist
;
4334 char stack_top_variable
;
4337 Lisp_Object total
[8];
4338 int count
= SPECPDL_INDEX ();
4339 EMACS_TIME t1
, t2
, t3
;
4344 EMACS_GET_TIME (t1
);
4346 /* Can't GC if pure storage overflowed because we can't determine
4347 if something is a pure object or not. */
4348 if (pure_bytes_used_before_overflow
)
4351 /* In case user calls debug_print during GC,
4352 don't let that cause a recursive GC. */
4353 consing_since_gc
= 0;
4355 /* Save what's currently displayed in the echo area. */
4356 message_p
= push_message ();
4357 record_unwind_protect (pop_message_unwind
, Qnil
);
4359 /* Save a copy of the contents of the stack, for debugging. */
4360 #if MAX_SAVE_STACK > 0
4361 if (NILP (Vpurify_flag
))
4363 i
= &stack_top_variable
- stack_bottom
;
4365 if (i
< MAX_SAVE_STACK
)
4367 if (stack_copy
== 0)
4368 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4369 else if (stack_copy_size
< i
)
4370 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4373 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4374 bcopy (stack_bottom
, stack_copy
, i
);
4376 bcopy (&stack_top_variable
, stack_copy
, i
);
4380 #endif /* MAX_SAVE_STACK > 0 */
4382 if (garbage_collection_messages
)
4383 message1_nolog ("Garbage collecting...");
4387 shrink_regexp_cache ();
4389 /* Don't keep undo information around forever. */
4391 register struct buffer
*nextb
= all_buffers
;
4395 /* If a buffer's undo list is Qt, that means that undo is
4396 turned off in that buffer. Calling truncate_undo_list on
4397 Qt tends to return NULL, which effectively turns undo back on.
4398 So don't call truncate_undo_list if undo_list is Qt. */
4399 if (! EQ (nextb
->undo_list
, Qt
))
4401 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
4404 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4405 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4407 /* If a buffer's gap size is more than 10% of the buffer
4408 size, or larger than 2000 bytes, then shrink it
4409 accordingly. Keep a minimum size of 20 bytes. */
4410 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4412 if (nextb
->text
->gap_size
> size
)
4414 struct buffer
*save_current
= current_buffer
;
4415 current_buffer
= nextb
;
4416 make_gap (-(nextb
->text
->gap_size
- size
));
4417 current_buffer
= save_current
;
4421 nextb
= nextb
->next
;
4427 /* clear_marks (); */
4429 /* Mark all the special slots that serve as the roots of accessibility. */
4431 for (i
= 0; i
< staticidx
; i
++)
4432 mark_object (*staticvec
[i
]);
4434 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4435 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4439 register struct gcpro
*tail
;
4440 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4441 for (i
= 0; i
< tail
->nvars
; i
++)
4442 mark_object (tail
->var
[i
]);
4447 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4449 mark_object (bind
->symbol
);
4450 mark_object (bind
->old_value
);
4452 for (catch = catchlist
; catch; catch = catch->next
)
4454 mark_object (catch->tag
);
4455 mark_object (catch->val
);
4457 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4459 mark_object (handler
->handler
);
4460 mark_object (handler
->var
);
4462 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
4464 mark_object (*backlist
->function
);
4466 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
4469 i
= backlist
->nargs
- 1;
4471 mark_object (backlist
->args
[i
]);
4475 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4481 extern void xg_mark_data ();
4488 /* Look thru every buffer's undo list for elements that used to
4489 contain update markers that were changed to Lisp_Misc_Free
4490 objects and delete them. This may leave a few cons cells
4491 unchained, but we will get those on the next sweep. */
4493 register struct buffer
*nextb
= all_buffers
;
4497 /* If a buffer's undo list is Qt, that means that undo is
4498 turned off in that buffer. */
4499 if (! EQ (nextb
->undo_list
, Qt
))
4501 Lisp_Object tail
, prev
, elt
, car
;
4502 tail
= nextb
->undo_list
;
4504 while (CONSP (tail
))
4506 if ((elt
= XCAR (tail
), GC_CONSP (elt
))
4507 && (car
= XCAR (elt
), GC_MISCP (car
))
4508 && XMISCTYPE (car
) == Lisp_Misc_Free
)
4510 Lisp_Object cdr
= XCDR (tail
);
4511 /* Do not use free_cons here, as we don't know if
4512 anybody else has a pointer to these conses. */
4513 XSETCAR (elt
, Qnil
);
4514 XSETCDR (elt
, Qnil
);
4515 XSETCAR (tail
, Qnil
);
4516 XSETCDR (tail
, Qnil
);
4518 nextb
->undo_list
= tail
= cdr
;
4522 XSETCDR (prev
, tail
);
4533 nextb
= nextb
->next
;
4537 /* Undo lists have been cleaned up, so we can free marker blocks now. */
4540 struct marker_block
*mblk
;
4542 while ((mblk
= marker_blocks_pending_free
) != 0)
4544 marker_blocks_pending_free
= mblk
->next
;
4549 /* Clear the mark bits that we set in certain root slots. */
4551 unmark_byte_stack ();
4552 VECTOR_UNMARK (&buffer_defaults
);
4553 VECTOR_UNMARK (&buffer_local_symbols
);
4555 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4561 /* clear_marks (); */
4564 consing_since_gc
= 0;
4565 if (gc_cons_threshold
< 10000)
4566 gc_cons_threshold
= 10000;
4568 if (garbage_collection_messages
)
4570 if (message_p
|| minibuf_level
> 0)
4573 message1_nolog ("Garbage collecting...done");
4576 unbind_to (count
, Qnil
);
4578 total
[0] = Fcons (make_number (total_conses
),
4579 make_number (total_free_conses
));
4580 total
[1] = Fcons (make_number (total_symbols
),
4581 make_number (total_free_symbols
));
4582 total
[2] = Fcons (make_number (total_markers
),
4583 make_number (total_free_markers
));
4584 total
[3] = make_number (total_string_size
);
4585 total
[4] = make_number (total_vector_size
);
4586 total
[5] = Fcons (make_number (total_floats
),
4587 make_number (total_free_floats
));
4588 total
[6] = Fcons (make_number (total_intervals
),
4589 make_number (total_free_intervals
));
4590 total
[7] = Fcons (make_number (total_strings
),
4591 make_number (total_free_strings
));
4593 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4595 /* Compute average percentage of zombies. */
4598 for (i
= 0; i
< 7; ++i
)
4599 if (CONSP (total
[i
]))
4600 nlive
+= XFASTINT (XCAR (total
[i
]));
4602 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4603 max_live
= max (nlive
, max_live
);
4604 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4605 max_zombies
= max (nzombies
, max_zombies
);
4610 if (!NILP (Vpost_gc_hook
))
4612 int count
= inhibit_garbage_collection ();
4613 safe_run_hooks (Qpost_gc_hook
);
4614 unbind_to (count
, Qnil
);
4617 /* Accumulate statistics. */
4618 EMACS_GET_TIME (t2
);
4619 EMACS_SUB_TIME (t3
, t2
, t1
);
4620 if (FLOATP (Vgc_elapsed
))
4621 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
4623 EMACS_USECS (t3
) * 1.0e-6);
4626 return Flist (sizeof total
/ sizeof *total
, total
);
4630 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4631 only interesting objects referenced from glyphs are strings. */
4634 mark_glyph_matrix (matrix
)
4635 struct glyph_matrix
*matrix
;
4637 struct glyph_row
*row
= matrix
->rows
;
4638 struct glyph_row
*end
= row
+ matrix
->nrows
;
4640 for (; row
< end
; ++row
)
4644 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
4646 struct glyph
*glyph
= row
->glyphs
[area
];
4647 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
4649 for (; glyph
< end_glyph
; ++glyph
)
4650 if (GC_STRINGP (glyph
->object
)
4651 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
4652 mark_object (glyph
->object
);
4658 /* Mark Lisp faces in the face cache C. */
4662 struct face_cache
*c
;
4667 for (i
= 0; i
< c
->used
; ++i
)
4669 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
4673 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
4674 mark_object (face
->lface
[j
]);
4681 #ifdef HAVE_WINDOW_SYSTEM
4683 /* Mark Lisp objects in image IMG. */
4689 mark_object (img
->spec
);
4691 if (!NILP (img
->data
.lisp_val
))
4692 mark_object (img
->data
.lisp_val
);
4696 /* Mark Lisp objects in image cache of frame F. It's done this way so
4697 that we don't have to include xterm.h here. */
4700 mark_image_cache (f
)
4703 forall_images_in_image_cache (f
, mark_image
);
4706 #endif /* HAVE_X_WINDOWS */
4710 /* Mark reference to a Lisp_Object.
4711 If the object referred to has not been seen yet, recursively mark
4712 all the references contained in it. */
4714 #define LAST_MARKED_SIZE 500
4715 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
4716 int last_marked_index
;
4718 /* For debugging--call abort when we cdr down this many
4719 links of a list, in mark_object. In debugging,
4720 the call to abort will hit a breakpoint.
4721 Normally this is zero and the check never goes off. */
4722 int mark_object_loop_halt
;
4728 register Lisp_Object obj
= arg
;
4729 #ifdef GC_CHECK_MARKED_OBJECTS
4737 if (PURE_POINTER_P (XPNTR (obj
)))
4740 last_marked
[last_marked_index
++] = obj
;
4741 if (last_marked_index
== LAST_MARKED_SIZE
)
4742 last_marked_index
= 0;
4744 /* Perform some sanity checks on the objects marked here. Abort if
4745 we encounter an object we know is bogus. This increases GC time
4746 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4747 #ifdef GC_CHECK_MARKED_OBJECTS
4749 po
= (void *) XPNTR (obj
);
4751 /* Check that the object pointed to by PO is known to be a Lisp
4752 structure allocated from the heap. */
4753 #define CHECK_ALLOCATED() \
4755 m = mem_find (po); \
4760 /* Check that the object pointed to by PO is live, using predicate
4762 #define CHECK_LIVE(LIVEP) \
4764 if (!LIVEP (m, po)) \
4768 /* Check both of the above conditions. */
4769 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4771 CHECK_ALLOCATED (); \
4772 CHECK_LIVE (LIVEP); \
4775 #else /* not GC_CHECK_MARKED_OBJECTS */
4777 #define CHECK_ALLOCATED() (void) 0
4778 #define CHECK_LIVE(LIVEP) (void) 0
4779 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4781 #endif /* not GC_CHECK_MARKED_OBJECTS */
4783 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4787 register struct Lisp_String
*ptr
= XSTRING (obj
);
4788 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4789 MARK_INTERVAL_TREE (ptr
->intervals
);
4791 #ifdef GC_CHECK_STRING_BYTES
4792 /* Check that the string size recorded in the string is the
4793 same as the one recorded in the sdata structure. */
4794 CHECK_STRING_BYTES (ptr
);
4795 #endif /* GC_CHECK_STRING_BYTES */
4799 case Lisp_Vectorlike
:
4800 #ifdef GC_CHECK_MARKED_OBJECTS
4802 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4803 && po
!= &buffer_defaults
4804 && po
!= &buffer_local_symbols
)
4806 #endif /* GC_CHECK_MARKED_OBJECTS */
4808 if (GC_BUFFERP (obj
))
4810 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
4812 #ifdef GC_CHECK_MARKED_OBJECTS
4813 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4816 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4821 #endif /* GC_CHECK_MARKED_OBJECTS */
4825 else if (GC_SUBRP (obj
))
4827 else if (GC_COMPILEDP (obj
))
4828 /* We could treat this just like a vector, but it is better to
4829 save the COMPILED_CONSTANTS element for last and avoid
4832 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4833 register EMACS_INT size
= ptr
->size
;
4836 if (VECTOR_MARKED_P (ptr
))
4837 break; /* Already marked */
4839 CHECK_LIVE (live_vector_p
);
4840 VECTOR_MARK (ptr
); /* Else mark it */
4841 size
&= PSEUDOVECTOR_SIZE_MASK
;
4842 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4844 if (i
!= COMPILED_CONSTANTS
)
4845 mark_object (ptr
->contents
[i
]);
4847 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
4850 else if (GC_FRAMEP (obj
))
4852 register struct frame
*ptr
= XFRAME (obj
);
4854 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4855 VECTOR_MARK (ptr
); /* Else mark it */
4857 CHECK_LIVE (live_vector_p
);
4858 mark_object (ptr
->name
);
4859 mark_object (ptr
->icon_name
);
4860 mark_object (ptr
->title
);
4861 mark_object (ptr
->focus_frame
);
4862 mark_object (ptr
->selected_window
);
4863 mark_object (ptr
->minibuffer_window
);
4864 mark_object (ptr
->param_alist
);
4865 mark_object (ptr
->scroll_bars
);
4866 mark_object (ptr
->condemned_scroll_bars
);
4867 mark_object (ptr
->menu_bar_items
);
4868 mark_object (ptr
->face_alist
);
4869 mark_object (ptr
->menu_bar_vector
);
4870 mark_object (ptr
->buffer_predicate
);
4871 mark_object (ptr
->buffer_list
);
4872 mark_object (ptr
->menu_bar_window
);
4873 mark_object (ptr
->tool_bar_window
);
4874 mark_face_cache (ptr
->face_cache
);
4875 #ifdef HAVE_WINDOW_SYSTEM
4876 mark_image_cache (ptr
);
4877 mark_object (ptr
->tool_bar_items
);
4878 mark_object (ptr
->desired_tool_bar_string
);
4879 mark_object (ptr
->current_tool_bar_string
);
4880 #endif /* HAVE_WINDOW_SYSTEM */
4882 else if (GC_BOOL_VECTOR_P (obj
))
4884 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4886 if (VECTOR_MARKED_P (ptr
))
4887 break; /* Already marked */
4888 CHECK_LIVE (live_vector_p
);
4889 VECTOR_MARK (ptr
); /* Else mark it */
4891 else if (GC_WINDOWP (obj
))
4893 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4894 struct window
*w
= XWINDOW (obj
);
4897 /* Stop if already marked. */
4898 if (VECTOR_MARKED_P (ptr
))
4902 CHECK_LIVE (live_vector_p
);
4905 /* There is no Lisp data above The member CURRENT_MATRIX in
4906 struct WINDOW. Stop marking when that slot is reached. */
4908 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4910 mark_object (ptr
->contents
[i
]);
4912 /* Mark glyphs for leaf windows. Marking window matrices is
4913 sufficient because frame matrices use the same glyph
4915 if (NILP (w
->hchild
)
4917 && w
->current_matrix
)
4919 mark_glyph_matrix (w
->current_matrix
);
4920 mark_glyph_matrix (w
->desired_matrix
);
4923 else if (GC_HASH_TABLE_P (obj
))
4925 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4927 /* Stop if already marked. */
4928 if (VECTOR_MARKED_P (h
))
4932 CHECK_LIVE (live_vector_p
);
4935 /* Mark contents. */
4936 /* Do not mark next_free or next_weak.
4937 Being in the next_weak chain
4938 should not keep the hash table alive.
4939 No need to mark `count' since it is an integer. */
4940 mark_object (h
->test
);
4941 mark_object (h
->weak
);
4942 mark_object (h
->rehash_size
);
4943 mark_object (h
->rehash_threshold
);
4944 mark_object (h
->hash
);
4945 mark_object (h
->next
);
4946 mark_object (h
->index
);
4947 mark_object (h
->user_hash_function
);
4948 mark_object (h
->user_cmp_function
);
4950 /* If hash table is not weak, mark all keys and values.
4951 For weak tables, mark only the vector. */
4952 if (GC_NILP (h
->weak
))
4953 mark_object (h
->key_and_value
);
4955 VECTOR_MARK (XVECTOR (h
->key_and_value
));
4959 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4960 register EMACS_INT size
= ptr
->size
;
4963 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4964 CHECK_LIVE (live_vector_p
);
4965 VECTOR_MARK (ptr
); /* Else mark it */
4966 if (size
& PSEUDOVECTOR_FLAG
)
4967 size
&= PSEUDOVECTOR_SIZE_MASK
;
4969 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4970 mark_object (ptr
->contents
[i
]);
4976 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4977 struct Lisp_Symbol
*ptrx
;
4979 if (ptr
->gcmarkbit
) break;
4980 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4982 mark_object (ptr
->value
);
4983 mark_object (ptr
->function
);
4984 mark_object (ptr
->plist
);
4986 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
4987 MARK_STRING (XSTRING (ptr
->xname
));
4988 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
4990 /* Note that we do not mark the obarray of the symbol.
4991 It is safe not to do so because nothing accesses that
4992 slot except to check whether it is nil. */
4996 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4997 XSETSYMBOL (obj
, ptrx
);
5004 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5005 if (XMARKER (obj
)->gcmarkbit
)
5007 XMARKER (obj
)->gcmarkbit
= 1;
5008 switch (XMISCTYPE (obj
))
5010 case Lisp_Misc_Buffer_Local_Value
:
5011 case Lisp_Misc_Some_Buffer_Local_Value
:
5013 register struct Lisp_Buffer_Local_Value
*ptr
5014 = XBUFFER_LOCAL_VALUE (obj
);
5015 /* If the cdr is nil, avoid recursion for the car. */
5016 if (EQ (ptr
->cdr
, Qnil
))
5018 obj
= ptr
->realvalue
;
5021 mark_object (ptr
->realvalue
);
5022 mark_object (ptr
->buffer
);
5023 mark_object (ptr
->frame
);
5028 case Lisp_Misc_Marker
:
5029 /* DO NOT mark thru the marker's chain.
5030 The buffer's markers chain does not preserve markers from gc;
5031 instead, markers are removed from the chain when freed by gc. */
5032 case Lisp_Misc_Intfwd
:
5033 case Lisp_Misc_Boolfwd
:
5034 case Lisp_Misc_Objfwd
:
5035 case Lisp_Misc_Buffer_Objfwd
:
5036 case Lisp_Misc_Kboard_Objfwd
:
5037 /* Don't bother with Lisp_Buffer_Objfwd,
5038 since all markable slots in current buffer marked anyway. */
5039 /* Don't need to do Lisp_Objfwd, since the places they point
5040 are protected with staticpro. */
5041 case Lisp_Misc_Save_Value
:
5044 case Lisp_Misc_Overlay
:
5046 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5047 mark_object (ptr
->start
);
5048 mark_object (ptr
->end
);
5049 mark_object (ptr
->plist
);
5052 XSETMISC (obj
, ptr
->next
);
5065 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5066 if (CONS_MARKED_P (ptr
)) break;
5067 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5069 /* If the cdr is nil, avoid recursion for the car. */
5070 if (EQ (ptr
->cdr
, Qnil
))
5076 mark_object (ptr
->car
);
5079 if (cdr_count
== mark_object_loop_halt
)
5085 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5086 FLOAT_MARK (XFLOAT (obj
));
5097 #undef CHECK_ALLOCATED
5098 #undef CHECK_ALLOCATED_AND_LIVE
5101 /* Mark the pointers in a buffer structure. */
5107 register struct buffer
*buffer
= XBUFFER (buf
);
5108 register Lisp_Object
*ptr
, tmp
;
5109 Lisp_Object base_buffer
;
5111 VECTOR_MARK (buffer
);
5113 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5115 if (CONSP (buffer
->undo_list
))
5118 tail
= buffer
->undo_list
;
5120 /* We mark the undo list specially because
5121 its pointers to markers should be weak. */
5123 while (CONSP (tail
))
5125 register struct Lisp_Cons
*ptr
= XCONS (tail
);
5127 if (CONS_MARKED_P (ptr
))
5130 if (GC_CONSP (ptr
->car
)
5131 && !CONS_MARKED_P (XCONS (ptr
->car
))
5132 && GC_MARKERP (XCAR (ptr
->car
)))
5134 CONS_MARK (XCONS (ptr
->car
));
5135 mark_object (XCDR (ptr
->car
));
5138 mark_object (ptr
->car
);
5140 if (CONSP (ptr
->cdr
))
5146 mark_object (XCDR (tail
));
5149 mark_object (buffer
->undo_list
);
5151 if (buffer
->overlays_before
)
5153 XSETMISC (tmp
, buffer
->overlays_before
);
5156 if (buffer
->overlays_after
)
5158 XSETMISC (tmp
, buffer
->overlays_after
);
5162 for (ptr
= &buffer
->name
;
5163 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5167 /* If this is an indirect buffer, mark its base buffer. */
5168 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5170 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5171 mark_buffer (base_buffer
);
5176 /* Value is non-zero if OBJ will survive the current GC because it's
5177 either marked or does not need to be marked to survive. */
5185 switch (XGCTYPE (obj
))
5192 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5196 survives_p
= XMARKER (obj
)->gcmarkbit
;
5200 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5203 case Lisp_Vectorlike
:
5204 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5208 survives_p
= CONS_MARKED_P (XCONS (obj
));
5212 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5219 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5224 /* Sweep: find all structures not marked, and free them. */
5229 /* Put all unmarked conses on free list */
5231 register struct cons_block
*cblk
;
5232 struct cons_block
**cprev
= &cons_block
;
5233 register int lim
= cons_block_index
;
5234 register int num_free
= 0, num_used
= 0;
5238 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5242 for (i
= 0; i
< lim
; i
++)
5243 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5246 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
5247 cons_free_list
= &cblk
->conses
[i
];
5249 cons_free_list
->car
= Vdead
;
5255 CONS_UNMARK (&cblk
->conses
[i
]);
5257 lim
= CONS_BLOCK_SIZE
;
5258 /* If this block contains only free conses and we have already
5259 seen more than two blocks worth of free conses then deallocate
5261 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5263 *cprev
= cblk
->next
;
5264 /* Unhook from the free list. */
5265 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
5266 lisp_align_free (cblk
);
5271 num_free
+= this_free
;
5272 cprev
= &cblk
->next
;
5275 total_conses
= num_used
;
5276 total_free_conses
= num_free
;
5279 /* Remove or mark entries in weak hash tables.
5280 This must be done before any object is unmarked. */
5281 sweep_weak_hash_tables ();
5284 #ifdef GC_CHECK_STRING_BYTES
5285 if (!noninteractive
)
5286 check_string_bytes (1);
5289 /* Put all unmarked floats on free list */
5291 register struct float_block
*fblk
;
5292 struct float_block
**fprev
= &float_block
;
5293 register int lim
= float_block_index
;
5294 register int num_free
= 0, num_used
= 0;
5296 float_free_list
= 0;
5298 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5302 for (i
= 0; i
< lim
; i
++)
5303 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5306 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
5307 float_free_list
= &fblk
->floats
[i
];
5312 FLOAT_UNMARK (&fblk
->floats
[i
]);
5314 lim
= FLOAT_BLOCK_SIZE
;
5315 /* If this block contains only free floats and we have already
5316 seen more than two blocks worth of free floats then deallocate
5318 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5320 *fprev
= fblk
->next
;
5321 /* Unhook from the free list. */
5322 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5323 lisp_align_free (fblk
);
5328 num_free
+= this_free
;
5329 fprev
= &fblk
->next
;
5332 total_floats
= num_used
;
5333 total_free_floats
= num_free
;
5336 /* Put all unmarked intervals on free list */
5338 register struct interval_block
*iblk
;
5339 struct interval_block
**iprev
= &interval_block
;
5340 register int lim
= interval_block_index
;
5341 register int num_free
= 0, num_used
= 0;
5343 interval_free_list
= 0;
5345 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5350 for (i
= 0; i
< lim
; i
++)
5352 if (!iblk
->intervals
[i
].gcmarkbit
)
5354 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5355 interval_free_list
= &iblk
->intervals
[i
];
5361 iblk
->intervals
[i
].gcmarkbit
= 0;
5364 lim
= INTERVAL_BLOCK_SIZE
;
5365 /* If this block contains only free intervals and we have already
5366 seen more than two blocks worth of free intervals then
5367 deallocate this block. */
5368 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5370 *iprev
= iblk
->next
;
5371 /* Unhook from the free list. */
5372 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5374 n_interval_blocks
--;
5378 num_free
+= this_free
;
5379 iprev
= &iblk
->next
;
5382 total_intervals
= num_used
;
5383 total_free_intervals
= num_free
;
5386 /* Put all unmarked symbols on free list */
5388 register struct symbol_block
*sblk
;
5389 struct symbol_block
**sprev
= &symbol_block
;
5390 register int lim
= symbol_block_index
;
5391 register int num_free
= 0, num_used
= 0;
5393 symbol_free_list
= NULL
;
5395 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5398 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5399 struct Lisp_Symbol
*end
= sym
+ lim
;
5401 for (; sym
< end
; ++sym
)
5403 /* Check if the symbol was created during loadup. In such a case
5404 it might be pointed to by pure bytecode which we don't trace,
5405 so we conservatively assume that it is live. */
5406 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5408 if (!sym
->gcmarkbit
&& !pure_p
)
5410 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5411 symbol_free_list
= sym
;
5413 symbol_free_list
->function
= Vdead
;
5421 UNMARK_STRING (XSTRING (sym
->xname
));
5426 lim
= SYMBOL_BLOCK_SIZE
;
5427 /* If this block contains only free symbols and we have already
5428 seen more than two blocks worth of free symbols then deallocate
5430 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5432 *sprev
= sblk
->next
;
5433 /* Unhook from the free list. */
5434 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5440 num_free
+= this_free
;
5441 sprev
= &sblk
->next
;
5444 total_symbols
= num_used
;
5445 total_free_symbols
= num_free
;
5448 /* Put all unmarked misc's on free list.
5449 For a marker, first unchain it from the buffer it points into. */
5451 register struct marker_block
*mblk
;
5452 struct marker_block
**mprev
= &marker_block
;
5453 register int lim
= marker_block_index
;
5454 register int num_free
= 0, num_used
= 0;
5456 marker_free_list
= 0;
5457 marker_blocks_pending_free
= 0;
5459 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5464 for (i
= 0; i
< lim
; i
++)
5466 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5468 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5469 unchain_marker (&mblk
->markers
[i
].u_marker
);
5470 /* Set the type of the freed object to Lisp_Misc_Free.
5471 We could leave the type alone, since nobody checks it,
5472 but this might catch bugs faster. */
5473 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5474 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5475 marker_free_list
= &mblk
->markers
[i
];
5481 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5484 lim
= MARKER_BLOCK_SIZE
;
5485 /* If this block contains only free markers and we have already
5486 seen more than two blocks worth of free markers then deallocate
5488 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5490 *mprev
= mblk
->next
;
5491 /* Unhook from the free list. */
5492 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5495 /* It is not safe to free the marker block at this stage,
5496 since there may still be pointers to these markers from
5497 a buffer's undo list. KFS 2004-05-25. */
5498 mblk
->next
= marker_blocks_pending_free
;
5499 marker_blocks_pending_free
= mblk
;
5503 num_free
+= this_free
;
5504 mprev
= &mblk
->next
;
5508 total_markers
= num_used
;
5509 total_free_markers
= num_free
;
5512 /* Free all unmarked buffers */
5514 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5517 if (!VECTOR_MARKED_P (buffer
))
5520 prev
->next
= buffer
->next
;
5522 all_buffers
= buffer
->next
;
5523 next
= buffer
->next
;
5529 VECTOR_UNMARK (buffer
);
5530 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5531 prev
= buffer
, buffer
= buffer
->next
;
5535 /* Free all unmarked vectors */
5537 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5538 total_vector_size
= 0;
5541 if (!VECTOR_MARKED_P (vector
))
5544 prev
->next
= vector
->next
;
5546 all_vectors
= vector
->next
;
5547 next
= vector
->next
;
5555 VECTOR_UNMARK (vector
);
5556 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5557 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5559 total_vector_size
+= vector
->size
;
5560 prev
= vector
, vector
= vector
->next
;
5564 #ifdef GC_CHECK_STRING_BYTES
5565 if (!noninteractive
)
5566 check_string_bytes (1);
5573 /* Debugging aids. */
5575 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5576 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
5577 This may be helpful in debugging Emacs's memory usage.
5578 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
5583 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5588 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5589 doc
: /* Return a list of counters that measure how much consing there has been.
5590 Each of these counters increments for a certain kind of object.
5591 The counters wrap around from the largest positive integer to zero.
5592 Garbage collection does not decrease them.
5593 The elements of the value are as follows:
5594 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
5595 All are in units of 1 = one object consed
5596 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
5598 MISCS include overlays, markers, and some internal types.
5599 Frames, windows, buffers, and subprocesses count as vectors
5600 (but the contents of a buffer's text do not count here). */)
5603 Lisp_Object consed
[8];
5605 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
5606 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
5607 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
5608 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
5609 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
5610 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
5611 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
5612 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
5614 return Flist (8, consed
);
5617 int suppress_checking
;
5619 die (msg
, file
, line
)
5624 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5629 /* Initialization */
5634 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5636 pure_size
= PURESIZE
;
5637 pure_bytes_used
= 0;
5638 pure_bytes_used_before_overflow
= 0;
5640 /* Initialize the list of free aligned blocks. */
5643 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5645 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5649 ignore_warnings
= 1;
5650 #ifdef DOUG_LEA_MALLOC
5651 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5652 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5653 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5663 malloc_hysteresis
= 32;
5665 malloc_hysteresis
= 0;
5668 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5670 ignore_warnings
= 0;
5672 byte_stack_list
= 0;
5674 consing_since_gc
= 0;
5675 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5676 #ifdef VIRT_ADDR_VARIES
5677 malloc_sbrk_unused
= 1<<22; /* A large number */
5678 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5679 #endif /* VIRT_ADDR_VARIES */
5686 byte_stack_list
= 0;
5688 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5689 setjmp_tested_p
= longjmps_done
= 0;
5692 Vgc_elapsed
= make_float (0.0);
5699 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5700 doc
: /* *Number of bytes of consing between garbage collections.
5701 Garbage collection can happen automatically once this many bytes have been
5702 allocated since the last garbage collection. All data types count.
5704 Garbage collection happens automatically only when `eval' is called.
5706 By binding this temporarily to a large number, you can effectively
5707 prevent garbage collection during a part of the program. */);
5709 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5710 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
5712 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5713 doc
: /* Number of cons cells that have been consed so far. */);
5715 DEFVAR_INT ("floats-consed", &floats_consed
,
5716 doc
: /* Number of floats that have been consed so far. */);
5718 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5719 doc
: /* Number of vector cells that have been consed so far. */);
5721 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5722 doc
: /* Number of symbols that have been consed so far. */);
5724 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5725 doc
: /* Number of string characters that have been consed so far. */);
5727 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5728 doc
: /* Number of miscellaneous objects that have been consed so far. */);
5730 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5731 doc
: /* Number of intervals that have been consed so far. */);
5733 DEFVAR_INT ("strings-consed", &strings_consed
,
5734 doc
: /* Number of strings that have been consed so far. */);
5736 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5737 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
5738 This means that certain objects should be allocated in shared (pure) space. */);
5740 DEFVAR_INT ("undo-limit", &undo_limit
,
5741 doc
: /* Keep no more undo information once it exceeds this size.
5742 This limit is applied when garbage collection happens.
5743 The size is counted as the number of bytes occupied,
5744 which includes both saved text and other data. */);
5747 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5748 doc
: /* Don't keep more than this much size of undo information.
5749 A command which pushes past this size is itself forgotten.
5750 This limit is applied when garbage collection happens.
5751 The size is counted as the number of bytes occupied,
5752 which includes both saved text and other data. */);
5753 undo_strong_limit
= 30000;
5755 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5756 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
5757 garbage_collection_messages
= 0;
5759 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
5760 doc
: /* Hook run after garbage collection has finished. */);
5761 Vpost_gc_hook
= Qnil
;
5762 Qpost_gc_hook
= intern ("post-gc-hook");
5763 staticpro (&Qpost_gc_hook
);
5765 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
5766 doc
: /* Precomputed `signal' argument for memory-full error. */);
5767 /* We build this in advance because if we wait until we need it, we might
5768 not be able to allocate the memory to hold it. */
5771 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
5773 DEFVAR_LISP ("memory-full", &Vmemory_full
,
5774 doc
: /* Non-nil means we are handling a memory-full error. */);
5775 Vmemory_full
= Qnil
;
5777 staticpro (&Qgc_cons_threshold
);
5778 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5780 staticpro (&Qchar_table_extra_slots
);
5781 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5783 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
5784 doc
: /* Accumulated time elapsed in garbage collections.
5785 The time is in seconds as a floating point value. */);
5786 DEFVAR_INT ("gcs-done", &gcs_done
,
5787 doc
: /* Accumulated number of garbage collections done. */);
5792 defsubr (&Smake_byte_code
);
5793 defsubr (&Smake_list
);
5794 defsubr (&Smake_vector
);
5795 defsubr (&Smake_char_table
);
5796 defsubr (&Smake_string
);
5797 defsubr (&Smake_bool_vector
);
5798 defsubr (&Smake_symbol
);
5799 defsubr (&Smake_marker
);
5800 defsubr (&Spurecopy
);
5801 defsubr (&Sgarbage_collect
);
5802 defsubr (&Smemory_limit
);
5803 defsubr (&Smemory_use_counts
);
5805 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5806 defsubr (&Sgc_status
);
5810 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
5811 (do not change this comment) */