1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002, 2003
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
);
601 /* If the memory just allocated cannot be addressed thru a Lisp
602 object's pointer, and it needs to be,
603 that's equivalent to running out of memory. */
604 if (val
&& type
!= MEM_TYPE_NON_LISP
)
607 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
608 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
610 lisp_malloc_loser
= val
;
616 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
617 if (val
&& type
!= MEM_TYPE_NON_LISP
)
618 mem_insert (val
, (char *) val
+ nbytes
, type
);
627 /* Free BLOCK. This must be called to free memory allocated with a
628 call to lisp_malloc. */
636 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
637 mem_delete (mem_find (block
));
642 /* Allocation of aligned blocks of memory to store Lisp data. */
643 /* The entry point is lisp_align_malloc which returns blocks of at most */
644 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
647 /* BLOCK_ALIGN has to be a power of 2. */
648 #define BLOCK_ALIGN (1 << 10)
650 /* Padding to leave at the end of a malloc'd block. This is to give
651 malloc a chance to minimize the amount of memory wasted to alignment.
652 It should be tuned to the particular malloc library used.
653 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
654 posix_memalign on the other hand would ideally prefer a value of 4
655 because otherwise, there's 1020 bytes wasted between each ablocks.
656 But testing shows that those 1020 will most of the time be efficiently
657 used by malloc to place other objects, so a value of 0 is still preferable
658 unless you have a lot of cons&floats and virtually nothing else. */
659 #define BLOCK_PADDING 0
660 #define BLOCK_BYTES \
661 (BLOCK_ALIGN - sizeof (struct aligned_block *) - BLOCK_PADDING)
663 /* Internal data structures and constants. */
665 #define ABLOCKS_SIZE 16
667 /* An aligned block of memory. */
672 char payload
[BLOCK_BYTES
];
673 struct ablock
*next_free
;
675 /* `abase' is the aligned base of the ablocks. */
676 /* It is overloaded to hold the virtual `busy' field that counts
677 the number of used ablock in the parent ablocks.
678 The first ablock has the `busy' field, the others have the `abase'
679 field. To tell the difference, we assume that pointers will have
680 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
681 is used to tell whether the real base of the parent ablocks is `abase'
682 (if not, the word before the first ablock holds a pointer to the
684 struct ablocks
*abase
;
685 /* The padding of all but the last ablock is unused. The padding of
686 the last ablock in an ablocks is not allocated. */
688 char padding
[BLOCK_PADDING
];
692 /* A bunch of consecutive aligned blocks. */
695 struct ablock blocks
[ABLOCKS_SIZE
];
698 /* Size of the block requested from malloc or memalign. */
699 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
701 #define ABLOCK_ABASE(block) \
702 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
703 ? (struct ablocks *)(block) \
706 /* Virtual `busy' field. */
707 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
709 /* Pointer to the (not necessarily aligned) malloc block. */
710 #ifdef HAVE_POSIX_MEMALIGN
711 #define ABLOCKS_BASE(abase) (abase)
713 #define ABLOCKS_BASE(abase) \
714 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
717 /* The list of free ablock. */
718 static struct ablock
*free_ablock
;
720 /* Allocate an aligned block of nbytes.
721 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
722 smaller or equal to BLOCK_BYTES. */
723 static POINTER_TYPE
*
724 lisp_align_malloc (nbytes
, type
)
729 struct ablocks
*abase
;
731 eassert (nbytes
<= BLOCK_BYTES
);
735 #ifdef GC_MALLOC_CHECK
736 allocated_mem_type
= type
;
742 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
744 #ifdef DOUG_LEA_MALLOC
745 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
746 because mapped region contents are not preserved in
748 mallopt (M_MMAP_MAX
, 0);
751 #ifdef HAVE_POSIX_MEMALIGN
753 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
754 abase
= err
? (base
= NULL
) : base
;
757 base
= malloc (ABLOCKS_BYTES
);
758 abase
= ALIGN (base
, BLOCK_ALIGN
);
766 aligned
= (base
== abase
);
768 ((void**)abase
)[-1] = base
;
770 #ifdef DOUG_LEA_MALLOC
771 /* Back to a reasonable maximum of mmap'ed areas. */
772 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
775 /* If the memory just allocated cannot be addressed thru a Lisp
776 object's pointer, and it needs to be, that's equivalent to
777 running out of memory. */
778 if (type
!= MEM_TYPE_NON_LISP
)
781 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
783 if ((char *) XCONS (tem
) != end
)
785 lisp_malloc_loser
= base
;
792 /* Initialize the blocks and put them on the free list.
793 Is `base' was not properly aligned, we can't use the last block. */
794 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
796 abase
->blocks
[i
].abase
= abase
;
797 abase
->blocks
[i
].x
.next_free
= free_ablock
;
798 free_ablock
= &abase
->blocks
[i
];
800 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
802 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
803 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
804 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
805 eassert (ABLOCKS_BASE (abase
) == base
);
806 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
809 abase
= ABLOCK_ABASE (free_ablock
);
810 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
812 free_ablock
= free_ablock
->x
.next_free
;
814 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
815 if (val
&& type
!= MEM_TYPE_NON_LISP
)
816 mem_insert (val
, (char *) val
+ nbytes
, type
);
823 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
828 lisp_align_free (block
)
831 struct ablock
*ablock
= block
;
832 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
835 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
836 mem_delete (mem_find (block
));
838 /* Put on free list. */
839 ablock
->x
.next_free
= free_ablock
;
840 free_ablock
= ablock
;
841 /* Update busy count. */
842 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
844 if (2 > (long) ABLOCKS_BUSY (abase
))
845 { /* All the blocks are free. */
846 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
847 struct ablock
**tem
= &free_ablock
;
848 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
852 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
855 *tem
= (*tem
)->x
.next_free
;
858 tem
= &(*tem
)->x
.next_free
;
860 eassert ((aligned
& 1) == aligned
);
861 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
862 free (ABLOCKS_BASE (abase
));
867 /* Return a new buffer structure allocated from the heap with
868 a call to lisp_malloc. */
874 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
880 /* Arranging to disable input signals while we're in malloc.
882 This only works with GNU malloc. To help out systems which can't
883 use GNU malloc, all the calls to malloc, realloc, and free
884 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
885 pairs; unfortunately, we have no idea what C library functions
886 might call malloc, so we can't really protect them unless you're
887 using GNU malloc. Fortunately, most of the major operating systems
888 can use GNU malloc. */
890 #ifndef SYSTEM_MALLOC
891 #ifndef DOUG_LEA_MALLOC
892 extern void * (*__malloc_hook
) P_ ((size_t));
893 extern void * (*__realloc_hook
) P_ ((void *, size_t));
894 extern void (*__free_hook
) P_ ((void *));
895 /* Else declared in malloc.h, perhaps with an extra arg. */
896 #endif /* DOUG_LEA_MALLOC */
897 static void * (*old_malloc_hook
) ();
898 static void * (*old_realloc_hook
) ();
899 static void (*old_free_hook
) ();
901 /* This function is used as the hook for free to call. */
904 emacs_blocked_free (ptr
)
909 #ifdef GC_MALLOC_CHECK
915 if (m
== MEM_NIL
|| m
->start
!= ptr
)
918 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
923 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
927 #endif /* GC_MALLOC_CHECK */
929 __free_hook
= old_free_hook
;
932 /* If we released our reserve (due to running out of memory),
933 and we have a fair amount free once again,
934 try to set aside another reserve in case we run out once more. */
935 if (spare_memory
== 0
936 /* Verify there is enough space that even with the malloc
937 hysteresis this call won't run out again.
938 The code here is correct as long as SPARE_MEMORY
939 is substantially larger than the block size malloc uses. */
940 && (bytes_used_when_full
941 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
942 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
944 __free_hook
= emacs_blocked_free
;
949 /* If we released our reserve (due to running out of memory),
950 and we have a fair amount free once again,
951 try to set aside another reserve in case we run out once more.
953 This is called when a relocatable block is freed in ralloc.c. */
956 refill_memory_reserve ()
958 if (spare_memory
== 0)
959 spare_memory
= (char *) malloc ((size_t) SPARE_MEMORY
);
963 /* This function is the malloc hook that Emacs uses. */
966 emacs_blocked_malloc (size
)
972 __malloc_hook
= old_malloc_hook
;
973 #ifdef DOUG_LEA_MALLOC
974 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
976 __malloc_extra_blocks
= malloc_hysteresis
;
979 value
= (void *) malloc (size
);
981 #ifdef GC_MALLOC_CHECK
983 struct mem_node
*m
= mem_find (value
);
986 fprintf (stderr
, "Malloc returned %p which is already in use\n",
988 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
989 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
994 if (!dont_register_blocks
)
996 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
997 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1000 #endif /* GC_MALLOC_CHECK */
1002 __malloc_hook
= emacs_blocked_malloc
;
1005 /* fprintf (stderr, "%p malloc\n", value); */
1010 /* This function is the realloc hook that Emacs uses. */
1013 emacs_blocked_realloc (ptr
, size
)
1020 __realloc_hook
= old_realloc_hook
;
1022 #ifdef GC_MALLOC_CHECK
1025 struct mem_node
*m
= mem_find (ptr
);
1026 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1029 "Realloc of %p which wasn't allocated with malloc\n",
1037 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1039 /* Prevent malloc from registering blocks. */
1040 dont_register_blocks
= 1;
1041 #endif /* GC_MALLOC_CHECK */
1043 value
= (void *) realloc (ptr
, size
);
1045 #ifdef GC_MALLOC_CHECK
1046 dont_register_blocks
= 0;
1049 struct mem_node
*m
= mem_find (value
);
1052 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1056 /* Can't handle zero size regions in the red-black tree. */
1057 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1060 /* fprintf (stderr, "%p <- realloc\n", value); */
1061 #endif /* GC_MALLOC_CHECK */
1063 __realloc_hook
= emacs_blocked_realloc
;
1070 /* Called from main to set up malloc to use our hooks. */
1073 uninterrupt_malloc ()
1075 if (__free_hook
!= emacs_blocked_free
)
1076 old_free_hook
= __free_hook
;
1077 __free_hook
= emacs_blocked_free
;
1079 if (__malloc_hook
!= emacs_blocked_malloc
)
1080 old_malloc_hook
= __malloc_hook
;
1081 __malloc_hook
= emacs_blocked_malloc
;
1083 if (__realloc_hook
!= emacs_blocked_realloc
)
1084 old_realloc_hook
= __realloc_hook
;
1085 __realloc_hook
= emacs_blocked_realloc
;
1088 #endif /* not SYSTEM_MALLOC */
1092 /***********************************************************************
1094 ***********************************************************************/
1096 /* Number of intervals allocated in an interval_block structure.
1097 The 1020 is 1024 minus malloc overhead. */
1099 #define INTERVAL_BLOCK_SIZE \
1100 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1102 /* Intervals are allocated in chunks in form of an interval_block
1105 struct interval_block
1107 struct interval_block
*next
;
1108 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1111 /* Current interval block. Its `next' pointer points to older
1114 struct interval_block
*interval_block
;
1116 /* Index in interval_block above of the next unused interval
1119 static int interval_block_index
;
1121 /* Number of free and live intervals. */
1123 static int total_free_intervals
, total_intervals
;
1125 /* List of free intervals. */
1127 INTERVAL interval_free_list
;
1129 /* Total number of interval blocks now in use. */
1131 int n_interval_blocks
;
1134 /* Initialize interval allocation. */
1139 interval_block
= NULL
;
1140 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1141 interval_free_list
= 0;
1142 n_interval_blocks
= 0;
1146 /* Return a new interval. */
1153 if (interval_free_list
)
1155 val
= interval_free_list
;
1156 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1160 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1162 register struct interval_block
*newi
;
1164 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1167 newi
->next
= interval_block
;
1168 interval_block
= newi
;
1169 interval_block_index
= 0;
1170 n_interval_blocks
++;
1172 val
= &interval_block
->intervals
[interval_block_index
++];
1174 consing_since_gc
+= sizeof (struct interval
);
1176 RESET_INTERVAL (val
);
1182 /* Mark Lisp objects in interval I. */
1185 mark_interval (i
, dummy
)
1186 register INTERVAL i
;
1189 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1191 mark_object (i
->plist
);
1195 /* Mark the interval tree rooted in TREE. Don't call this directly;
1196 use the macro MARK_INTERVAL_TREE instead. */
1199 mark_interval_tree (tree
)
1200 register INTERVAL tree
;
1202 /* No need to test if this tree has been marked already; this
1203 function is always called through the MARK_INTERVAL_TREE macro,
1204 which takes care of that. */
1206 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1210 /* Mark the interval tree rooted in I. */
1212 #define MARK_INTERVAL_TREE(i) \
1214 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1215 mark_interval_tree (i); \
1219 #define UNMARK_BALANCE_INTERVALS(i) \
1221 if (! NULL_INTERVAL_P (i)) \
1222 (i) = balance_intervals (i); \
1226 /* Number support. If NO_UNION_TYPE isn't in effect, we
1227 can't create number objects in macros. */
1235 obj
.s
.type
= Lisp_Int
;
1240 /***********************************************************************
1242 ***********************************************************************/
1244 /* Lisp_Strings are allocated in string_block structures. When a new
1245 string_block is allocated, all the Lisp_Strings it contains are
1246 added to a free-list string_free_list. When a new Lisp_String is
1247 needed, it is taken from that list. During the sweep phase of GC,
1248 string_blocks that are entirely free are freed, except two which
1251 String data is allocated from sblock structures. Strings larger
1252 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1253 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1255 Sblocks consist internally of sdata structures, one for each
1256 Lisp_String. The sdata structure points to the Lisp_String it
1257 belongs to. The Lisp_String points back to the `u.data' member of
1258 its sdata structure.
1260 When a Lisp_String is freed during GC, it is put back on
1261 string_free_list, and its `data' member and its sdata's `string'
1262 pointer is set to null. The size of the string is recorded in the
1263 `u.nbytes' member of the sdata. So, sdata structures that are no
1264 longer used, can be easily recognized, and it's easy to compact the
1265 sblocks of small strings which we do in compact_small_strings. */
1267 /* Size in bytes of an sblock structure used for small strings. This
1268 is 8192 minus malloc overhead. */
1270 #define SBLOCK_SIZE 8188
1272 /* Strings larger than this are considered large strings. String data
1273 for large strings is allocated from individual sblocks. */
1275 #define LARGE_STRING_BYTES 1024
1277 /* Structure describing string memory sub-allocated from an sblock.
1278 This is where the contents of Lisp strings are stored. */
1282 /* Back-pointer to the string this sdata belongs to. If null, this
1283 structure is free, and the NBYTES member of the union below
1284 contains the string's byte size (the same value that STRING_BYTES
1285 would return if STRING were non-null). If non-null, STRING_BYTES
1286 (STRING) is the size of the data, and DATA contains the string's
1288 struct Lisp_String
*string
;
1290 #ifdef GC_CHECK_STRING_BYTES
1293 unsigned char data
[1];
1295 #define SDATA_NBYTES(S) (S)->nbytes
1296 #define SDATA_DATA(S) (S)->data
1298 #else /* not GC_CHECK_STRING_BYTES */
1302 /* When STRING in non-null. */
1303 unsigned char data
[1];
1305 /* When STRING is null. */
1310 #define SDATA_NBYTES(S) (S)->u.nbytes
1311 #define SDATA_DATA(S) (S)->u.data
1313 #endif /* not GC_CHECK_STRING_BYTES */
1317 /* Structure describing a block of memory which is sub-allocated to
1318 obtain string data memory for strings. Blocks for small strings
1319 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1320 as large as needed. */
1325 struct sblock
*next
;
1327 /* Pointer to the next free sdata block. This points past the end
1328 of the sblock if there isn't any space left in this block. */
1329 struct sdata
*next_free
;
1331 /* Start of data. */
1332 struct sdata first_data
;
1335 /* Number of Lisp strings in a string_block structure. The 1020 is
1336 1024 minus malloc overhead. */
1338 #define STRING_BLOCK_SIZE \
1339 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1341 /* Structure describing a block from which Lisp_String structures
1346 struct string_block
*next
;
1347 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1350 /* Head and tail of the list of sblock structures holding Lisp string
1351 data. We always allocate from current_sblock. The NEXT pointers
1352 in the sblock structures go from oldest_sblock to current_sblock. */
1354 static struct sblock
*oldest_sblock
, *current_sblock
;
1356 /* List of sblocks for large strings. */
1358 static struct sblock
*large_sblocks
;
1360 /* List of string_block structures, and how many there are. */
1362 static struct string_block
*string_blocks
;
1363 static int n_string_blocks
;
1365 /* Free-list of Lisp_Strings. */
1367 static struct Lisp_String
*string_free_list
;
1369 /* Number of live and free Lisp_Strings. */
1371 static int total_strings
, total_free_strings
;
1373 /* Number of bytes used by live strings. */
1375 static int total_string_size
;
1377 /* Given a pointer to a Lisp_String S which is on the free-list
1378 string_free_list, return a pointer to its successor in the
1381 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1383 /* Return a pointer to the sdata structure belonging to Lisp string S.
1384 S must be live, i.e. S->data must not be null. S->data is actually
1385 a pointer to the `u.data' member of its sdata structure; the
1386 structure starts at a constant offset in front of that. */
1388 #ifdef GC_CHECK_STRING_BYTES
1390 #define SDATA_OF_STRING(S) \
1391 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1392 - sizeof (EMACS_INT)))
1394 #else /* not GC_CHECK_STRING_BYTES */
1396 #define SDATA_OF_STRING(S) \
1397 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1399 #endif /* not GC_CHECK_STRING_BYTES */
1401 /* Value is the size of an sdata structure large enough to hold NBYTES
1402 bytes of string data. The value returned includes a terminating
1403 NUL byte, the size of the sdata structure, and padding. */
1405 #ifdef GC_CHECK_STRING_BYTES
1407 #define SDATA_SIZE(NBYTES) \
1408 ((sizeof (struct Lisp_String *) \
1410 + sizeof (EMACS_INT) \
1411 + sizeof (EMACS_INT) - 1) \
1412 & ~(sizeof (EMACS_INT) - 1))
1414 #else /* not GC_CHECK_STRING_BYTES */
1416 #define SDATA_SIZE(NBYTES) \
1417 ((sizeof (struct Lisp_String *) \
1419 + sizeof (EMACS_INT) - 1) \
1420 & ~(sizeof (EMACS_INT) - 1))
1422 #endif /* not GC_CHECK_STRING_BYTES */
1424 /* Initialize string allocation. Called from init_alloc_once. */
1429 total_strings
= total_free_strings
= total_string_size
= 0;
1430 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1431 string_blocks
= NULL
;
1432 n_string_blocks
= 0;
1433 string_free_list
= NULL
;
1437 #ifdef GC_CHECK_STRING_BYTES
1439 static int check_string_bytes_count
;
1441 void check_string_bytes
P_ ((int));
1442 void check_sblock
P_ ((struct sblock
*));
1444 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1447 /* Like GC_STRING_BYTES, but with debugging check. */
1451 struct Lisp_String
*s
;
1453 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1454 if (!PURE_POINTER_P (s
)
1456 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1461 /* Check validity of Lisp strings' string_bytes member in B. */
1467 struct sdata
*from
, *end
, *from_end
;
1471 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1473 /* Compute the next FROM here because copying below may
1474 overwrite data we need to compute it. */
1477 /* Check that the string size recorded in the string is the
1478 same as the one recorded in the sdata structure. */
1480 CHECK_STRING_BYTES (from
->string
);
1483 nbytes
= GC_STRING_BYTES (from
->string
);
1485 nbytes
= SDATA_NBYTES (from
);
1487 nbytes
= SDATA_SIZE (nbytes
);
1488 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1493 /* Check validity of Lisp strings' string_bytes member. ALL_P
1494 non-zero means check all strings, otherwise check only most
1495 recently allocated strings. Used for hunting a bug. */
1498 check_string_bytes (all_p
)
1505 for (b
= large_sblocks
; b
; b
= b
->next
)
1507 struct Lisp_String
*s
= b
->first_data
.string
;
1509 CHECK_STRING_BYTES (s
);
1512 for (b
= oldest_sblock
; b
; b
= b
->next
)
1516 check_sblock (current_sblock
);
1519 #endif /* GC_CHECK_STRING_BYTES */
1522 /* Return a new Lisp_String. */
1524 static struct Lisp_String
*
1527 struct Lisp_String
*s
;
1529 /* If the free-list is empty, allocate a new string_block, and
1530 add all the Lisp_Strings in it to the free-list. */
1531 if (string_free_list
== NULL
)
1533 struct string_block
*b
;
1536 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1537 bzero (b
, sizeof *b
);
1538 b
->next
= string_blocks
;
1542 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1545 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1546 string_free_list
= s
;
1549 total_free_strings
+= STRING_BLOCK_SIZE
;
1552 /* Pop a Lisp_String off the free-list. */
1553 s
= string_free_list
;
1554 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1556 /* Probably not strictly necessary, but play it safe. */
1557 bzero (s
, sizeof *s
);
1559 --total_free_strings
;
1562 consing_since_gc
+= sizeof *s
;
1564 #ifdef GC_CHECK_STRING_BYTES
1571 if (++check_string_bytes_count
== 200)
1573 check_string_bytes_count
= 0;
1574 check_string_bytes (1);
1577 check_string_bytes (0);
1579 #endif /* GC_CHECK_STRING_BYTES */
1585 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1586 plus a NUL byte at the end. Allocate an sdata structure for S, and
1587 set S->data to its `u.data' member. Store a NUL byte at the end of
1588 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1589 S->data if it was initially non-null. */
1592 allocate_string_data (s
, nchars
, nbytes
)
1593 struct Lisp_String
*s
;
1596 struct sdata
*data
, *old_data
;
1598 int needed
, old_nbytes
;
1600 /* Determine the number of bytes needed to store NBYTES bytes
1602 needed
= SDATA_SIZE (nbytes
);
1604 if (nbytes
> LARGE_STRING_BYTES
)
1606 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1608 #ifdef DOUG_LEA_MALLOC
1609 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1610 because mapped region contents are not preserved in
1613 In case you think of allowing it in a dumped Emacs at the
1614 cost of not being able to re-dump, there's another reason:
1615 mmap'ed data typically have an address towards the top of the
1616 address space, which won't fit into an EMACS_INT (at least on
1617 32-bit systems with the current tagging scheme). --fx */
1618 mallopt (M_MMAP_MAX
, 0);
1621 b
= (struct sblock
*) lisp_malloc (size
, MEM_TYPE_NON_LISP
);
1623 #ifdef DOUG_LEA_MALLOC
1624 /* Back to a reasonable maximum of mmap'ed areas. */
1625 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1628 b
->next_free
= &b
->first_data
;
1629 b
->first_data
.string
= NULL
;
1630 b
->next
= large_sblocks
;
1633 else if (current_sblock
== NULL
1634 || (((char *) current_sblock
+ SBLOCK_SIZE
1635 - (char *) current_sblock
->next_free
)
1638 /* Not enough room in the current sblock. */
1639 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1640 b
->next_free
= &b
->first_data
;
1641 b
->first_data
.string
= NULL
;
1645 current_sblock
->next
= b
;
1653 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1654 old_nbytes
= GC_STRING_BYTES (s
);
1656 data
= b
->next_free
;
1658 s
->data
= SDATA_DATA (data
);
1659 #ifdef GC_CHECK_STRING_BYTES
1660 SDATA_NBYTES (data
) = nbytes
;
1663 s
->size_byte
= nbytes
;
1664 s
->data
[nbytes
] = '\0';
1665 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
);
1667 /* If S had already data assigned, mark that as free by setting its
1668 string back-pointer to null, and recording the size of the data
1672 SDATA_NBYTES (old_data
) = old_nbytes
;
1673 old_data
->string
= NULL
;
1676 consing_since_gc
+= needed
;
1680 /* Sweep and compact strings. */
1685 struct string_block
*b
, *next
;
1686 struct string_block
*live_blocks
= NULL
;
1688 string_free_list
= NULL
;
1689 total_strings
= total_free_strings
= 0;
1690 total_string_size
= 0;
1692 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1693 for (b
= string_blocks
; b
; b
= next
)
1696 struct Lisp_String
*free_list_before
= string_free_list
;
1700 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1702 struct Lisp_String
*s
= b
->strings
+ i
;
1706 /* String was not on free-list before. */
1707 if (STRING_MARKED_P (s
))
1709 /* String is live; unmark it and its intervals. */
1712 if (!NULL_INTERVAL_P (s
->intervals
))
1713 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1716 total_string_size
+= STRING_BYTES (s
);
1720 /* String is dead. Put it on the free-list. */
1721 struct sdata
*data
= SDATA_OF_STRING (s
);
1723 /* Save the size of S in its sdata so that we know
1724 how large that is. Reset the sdata's string
1725 back-pointer so that we know it's free. */
1726 #ifdef GC_CHECK_STRING_BYTES
1727 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
1730 data
->u
.nbytes
= GC_STRING_BYTES (s
);
1732 data
->string
= NULL
;
1734 /* Reset the strings's `data' member so that we
1738 /* Put the string on the free-list. */
1739 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1740 string_free_list
= s
;
1746 /* S was on the free-list before. Put it there again. */
1747 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1748 string_free_list
= s
;
1753 /* Free blocks that contain free Lisp_Strings only, except
1754 the first two of them. */
1755 if (nfree
== STRING_BLOCK_SIZE
1756 && total_free_strings
> STRING_BLOCK_SIZE
)
1760 string_free_list
= free_list_before
;
1764 total_free_strings
+= nfree
;
1765 b
->next
= live_blocks
;
1770 string_blocks
= live_blocks
;
1771 free_large_strings ();
1772 compact_small_strings ();
1776 /* Free dead large strings. */
1779 free_large_strings ()
1781 struct sblock
*b
, *next
;
1782 struct sblock
*live_blocks
= NULL
;
1784 for (b
= large_sblocks
; b
; b
= next
)
1788 if (b
->first_data
.string
== NULL
)
1792 b
->next
= live_blocks
;
1797 large_sblocks
= live_blocks
;
1801 /* Compact data of small strings. Free sblocks that don't contain
1802 data of live strings after compaction. */
1805 compact_small_strings ()
1807 struct sblock
*b
, *tb
, *next
;
1808 struct sdata
*from
, *to
, *end
, *tb_end
;
1809 struct sdata
*to_end
, *from_end
;
1811 /* TB is the sblock we copy to, TO is the sdata within TB we copy
1812 to, and TB_END is the end of TB. */
1814 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1815 to
= &tb
->first_data
;
1817 /* Step through the blocks from the oldest to the youngest. We
1818 expect that old blocks will stabilize over time, so that less
1819 copying will happen this way. */
1820 for (b
= oldest_sblock
; b
; b
= b
->next
)
1823 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
1825 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1827 /* Compute the next FROM here because copying below may
1828 overwrite data we need to compute it. */
1831 #ifdef GC_CHECK_STRING_BYTES
1832 /* Check that the string size recorded in the string is the
1833 same as the one recorded in the sdata structure. */
1835 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
1837 #endif /* GC_CHECK_STRING_BYTES */
1840 nbytes
= GC_STRING_BYTES (from
->string
);
1842 nbytes
= SDATA_NBYTES (from
);
1844 nbytes
= SDATA_SIZE (nbytes
);
1845 from_end
= (struct sdata
*) ((char *) from
+ nbytes
);
1847 /* FROM->string non-null means it's alive. Copy its data. */
1850 /* If TB is full, proceed with the next sblock. */
1851 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1852 if (to_end
> tb_end
)
1856 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
1857 to
= &tb
->first_data
;
1858 to_end
= (struct sdata
*) ((char *) to
+ nbytes
);
1861 /* Copy, and update the string's `data' pointer. */
1864 xassert (tb
!= b
|| to
<= from
);
1865 safe_bcopy ((char *) from
, (char *) to
, nbytes
);
1866 to
->string
->data
= SDATA_DATA (to
);
1869 /* Advance past the sdata we copied to. */
1875 /* The rest of the sblocks following TB don't contain live data, so
1876 we can free them. */
1877 for (b
= tb
->next
; b
; b
= next
)
1885 current_sblock
= tb
;
1889 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1890 doc
: /* Return a newly created string of length LENGTH, with each element being INIT.
1891 Both LENGTH and INIT must be numbers. */)
1893 Lisp_Object length
, init
;
1895 register Lisp_Object val
;
1896 register unsigned char *p
, *end
;
1899 CHECK_NATNUM (length
);
1900 CHECK_NUMBER (init
);
1903 if (SINGLE_BYTE_CHAR_P (c
))
1905 nbytes
= XINT (length
);
1906 val
= make_uninit_string (nbytes
);
1908 end
= p
+ SCHARS (val
);
1914 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
1915 int len
= CHAR_STRING (c
, str
);
1917 nbytes
= len
* XINT (length
);
1918 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1923 bcopy (str
, p
, len
);
1933 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1934 doc
: /* Return a new bool-vector of length LENGTH, using INIT for as each element.
1935 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
1937 Lisp_Object length
, init
;
1939 register Lisp_Object val
;
1940 struct Lisp_Bool_Vector
*p
;
1942 int length_in_chars
, length_in_elts
, bits_per_value
;
1944 CHECK_NATNUM (length
);
1946 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1948 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1949 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1951 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1952 slot `size' of the struct Lisp_Bool_Vector. */
1953 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1954 p
= XBOOL_VECTOR (val
);
1956 /* Get rid of any bits that would cause confusion. */
1958 XSETBOOL_VECTOR (val
, p
);
1959 p
->size
= XFASTINT (length
);
1961 real_init
= (NILP (init
) ? 0 : -1);
1962 for (i
= 0; i
< length_in_chars
; i
++)
1963 p
->data
[i
] = real_init
;
1965 /* Clear the extraneous bits in the last byte. */
1966 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1967 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1968 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1974 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
1975 of characters from the contents. This string may be unibyte or
1976 multibyte, depending on the contents. */
1979 make_string (contents
, nbytes
)
1980 const char *contents
;
1983 register Lisp_Object val
;
1984 int nchars
, multibyte_nbytes
;
1986 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
1987 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
1988 /* CONTENTS contains no multibyte sequences or contains an invalid
1989 multibyte sequence. We must make unibyte string. */
1990 val
= make_unibyte_string (contents
, nbytes
);
1992 val
= make_multibyte_string (contents
, nchars
, nbytes
);
1997 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2000 make_unibyte_string (contents
, length
)
2001 const char *contents
;
2004 register Lisp_Object val
;
2005 val
= make_uninit_string (length
);
2006 bcopy (contents
, SDATA (val
), length
);
2007 STRING_SET_UNIBYTE (val
);
2012 /* Make a multibyte string from NCHARS characters occupying NBYTES
2013 bytes at CONTENTS. */
2016 make_multibyte_string (contents
, nchars
, nbytes
)
2017 const char *contents
;
2020 register Lisp_Object val
;
2021 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2022 bcopy (contents
, SDATA (val
), nbytes
);
2027 /* Make a string from NCHARS characters occupying NBYTES bytes at
2028 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2031 make_string_from_bytes (contents
, nchars
, nbytes
)
2032 const char *contents
;
2035 register Lisp_Object val
;
2036 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2037 bcopy (contents
, SDATA (val
), nbytes
);
2038 if (SBYTES (val
) == SCHARS (val
))
2039 STRING_SET_UNIBYTE (val
);
2044 /* Make a string from NCHARS characters occupying NBYTES bytes at
2045 CONTENTS. The argument MULTIBYTE controls whether to label the
2046 string as multibyte. If NCHARS is negative, it counts the number of
2047 characters by itself. */
2050 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2051 const char *contents
;
2055 register Lisp_Object val
;
2060 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2064 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2065 bcopy (contents
, SDATA (val
), nbytes
);
2067 STRING_SET_UNIBYTE (val
);
2072 /* Make a string from the data at STR, treating it as multibyte if the
2079 return make_string (str
, strlen (str
));
2083 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2084 occupying LENGTH bytes. */
2087 make_uninit_string (length
)
2091 val
= make_uninit_multibyte_string (length
, length
);
2092 STRING_SET_UNIBYTE (val
);
2097 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2098 which occupy NBYTES bytes. */
2101 make_uninit_multibyte_string (nchars
, nbytes
)
2105 struct Lisp_String
*s
;
2110 s
= allocate_string ();
2111 allocate_string_data (s
, nchars
, nbytes
);
2112 XSETSTRING (string
, s
);
2113 string_chars_consed
+= nbytes
;
2119 /***********************************************************************
2121 ***********************************************************************/
2123 /* We store float cells inside of float_blocks, allocating a new
2124 float_block with malloc whenever necessary. Float cells reclaimed
2125 by GC are put on a free list to be reallocated before allocating
2126 any new float cells from the latest float_block. */
2128 #define FLOAT_BLOCK_SIZE \
2129 (((BLOCK_BYTES - sizeof (struct float_block *)) * CHAR_BIT) \
2130 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2132 #define GETMARKBIT(block,n) \
2133 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2134 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2137 #define SETMARKBIT(block,n) \
2138 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2139 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2141 #define UNSETMARKBIT(block,n) \
2142 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2143 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2145 #define FLOAT_BLOCK(fptr) \
2146 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2148 #define FLOAT_INDEX(fptr) \
2149 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2153 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2154 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2155 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2156 struct float_block
*next
;
2159 #define FLOAT_MARKED_P(fptr) \
2160 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2162 #define FLOAT_MARK(fptr) \
2163 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2165 #define FLOAT_UNMARK(fptr) \
2166 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2168 /* Current float_block. */
2170 struct float_block
*float_block
;
2172 /* Index of first unused Lisp_Float in the current float_block. */
2174 int float_block_index
;
2176 /* Total number of float blocks now in use. */
2180 /* Free-list of Lisp_Floats. */
2182 struct Lisp_Float
*float_free_list
;
2185 /* Initialize float allocation. */
2191 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2192 float_free_list
= 0;
2197 /* Explicitly free a float cell by putting it on the free-list. */
2201 struct Lisp_Float
*ptr
;
2203 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
2204 float_free_list
= ptr
;
2208 /* Return a new float object with value FLOAT_VALUE. */
2211 make_float (float_value
)
2214 register Lisp_Object val
;
2216 if (float_free_list
)
2218 /* We use the data field for chaining the free list
2219 so that we won't use the same field that has the mark bit. */
2220 XSETFLOAT (val
, float_free_list
);
2221 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
2225 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2227 register struct float_block
*new;
2229 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2231 new->next
= float_block
;
2233 float_block_index
= 0;
2236 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
2239 XFLOAT_DATA (val
) = float_value
;
2240 FLOAT_UNMARK (XFLOAT (val
));
2241 consing_since_gc
+= sizeof (struct Lisp_Float
);
2248 /***********************************************************************
2250 ***********************************************************************/
2252 /* We store cons cells inside of cons_blocks, allocating a new
2253 cons_block with malloc whenever necessary. Cons cells reclaimed by
2254 GC are put on a free list to be reallocated before allocating
2255 any new cons cells from the latest cons_block. */
2257 #define CONS_BLOCK_SIZE \
2258 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2259 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2261 #define CONS_BLOCK(fptr) \
2262 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2264 #define CONS_INDEX(fptr) \
2265 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2269 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2270 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2271 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2272 struct cons_block
*next
;
2275 #define CONS_MARKED_P(fptr) \
2276 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2278 #define CONS_MARK(fptr) \
2279 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2281 #define CONS_UNMARK(fptr) \
2282 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2284 /* Current cons_block. */
2286 struct cons_block
*cons_block
;
2288 /* Index of first unused Lisp_Cons in the current block. */
2290 int cons_block_index
;
2292 /* Free-list of Lisp_Cons structures. */
2294 struct Lisp_Cons
*cons_free_list
;
2296 /* Total number of cons blocks now in use. */
2301 /* Initialize cons allocation. */
2307 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2313 /* Explicitly free a cons cell by putting it on the free-list. */
2317 struct Lisp_Cons
*ptr
;
2319 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
2323 cons_free_list
= ptr
;
2327 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2328 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2330 Lisp_Object car
, cdr
;
2332 register Lisp_Object val
;
2336 /* We use the cdr for chaining the free list
2337 so that we won't use the same field that has the mark bit. */
2338 XSETCONS (val
, cons_free_list
);
2339 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
2343 if (cons_block_index
== CONS_BLOCK_SIZE
)
2345 register struct cons_block
*new;
2346 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2348 new->next
= cons_block
;
2350 cons_block_index
= 0;
2353 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
2358 CONS_UNMARK (XCONS (val
));
2359 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2360 cons_cells_consed
++;
2365 /* Make a list of 2, 3, 4 or 5 specified objects. */
2369 Lisp_Object arg1
, arg2
;
2371 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2376 list3 (arg1
, arg2
, arg3
)
2377 Lisp_Object arg1
, arg2
, arg3
;
2379 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2384 list4 (arg1
, arg2
, arg3
, arg4
)
2385 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2387 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2392 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2393 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2395 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2396 Fcons (arg5
, Qnil
)))));
2400 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2401 doc
: /* Return a newly created list with specified arguments as elements.
2402 Any number of arguments, even zero arguments, are allowed.
2403 usage: (list &rest OBJECTS) */)
2406 register Lisp_Object
*args
;
2408 register Lisp_Object val
;
2414 val
= Fcons (args
[nargs
], val
);
2420 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2421 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2423 register Lisp_Object length
, init
;
2425 register Lisp_Object val
;
2428 CHECK_NATNUM (length
);
2429 size
= XFASTINT (length
);
2434 val
= Fcons (init
, val
);
2439 val
= Fcons (init
, val
);
2444 val
= Fcons (init
, val
);
2449 val
= Fcons (init
, val
);
2454 val
= Fcons (init
, val
);
2469 /***********************************************************************
2471 ***********************************************************************/
2473 /* Singly-linked list of all vectors. */
2475 struct Lisp_Vector
*all_vectors
;
2477 /* Total number of vector-like objects now in use. */
2482 /* Value is a pointer to a newly allocated Lisp_Vector structure
2483 with room for LEN Lisp_Objects. */
2485 static struct Lisp_Vector
*
2486 allocate_vectorlike (len
, type
)
2490 struct Lisp_Vector
*p
;
2493 #ifdef DOUG_LEA_MALLOC
2494 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2495 because mapped region contents are not preserved in
2497 mallopt (M_MMAP_MAX
, 0);
2500 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2501 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2503 #ifdef DOUG_LEA_MALLOC
2504 /* Back to a reasonable maximum of mmap'ed areas. */
2505 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2508 consing_since_gc
+= nbytes
;
2509 vector_cells_consed
+= len
;
2511 p
->next
= all_vectors
;
2518 /* Allocate a vector with NSLOTS slots. */
2520 struct Lisp_Vector
*
2521 allocate_vector (nslots
)
2524 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2530 /* Allocate other vector-like structures. */
2532 struct Lisp_Hash_Table
*
2533 allocate_hash_table ()
2535 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2536 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2540 for (i
= 0; i
< len
; ++i
)
2541 v
->contents
[i
] = Qnil
;
2543 return (struct Lisp_Hash_Table
*) v
;
2550 EMACS_INT len
= VECSIZE (struct window
);
2551 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
2554 for (i
= 0; i
< len
; ++i
)
2555 v
->contents
[i
] = Qnil
;
2558 return (struct window
*) v
;
2565 EMACS_INT len
= VECSIZE (struct frame
);
2566 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
2569 for (i
= 0; i
< len
; ++i
)
2570 v
->contents
[i
] = make_number (0);
2572 return (struct frame
*) v
;
2576 struct Lisp_Process
*
2579 EMACS_INT len
= VECSIZE (struct Lisp_Process
);
2580 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_PROCESS
);
2583 for (i
= 0; i
< len
; ++i
)
2584 v
->contents
[i
] = Qnil
;
2587 return (struct Lisp_Process
*) v
;
2591 struct Lisp_Vector
*
2592 allocate_other_vector (len
)
2595 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
2598 for (i
= 0; i
< len
; ++i
)
2599 v
->contents
[i
] = Qnil
;
2606 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2607 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2608 See also the function `vector'. */)
2610 register Lisp_Object length
, init
;
2613 register EMACS_INT sizei
;
2615 register struct Lisp_Vector
*p
;
2617 CHECK_NATNUM (length
);
2618 sizei
= XFASTINT (length
);
2620 p
= allocate_vector (sizei
);
2621 for (index
= 0; index
< sizei
; index
++)
2622 p
->contents
[index
] = init
;
2624 XSETVECTOR (vector
, p
);
2629 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
2630 doc
: /* Return a newly created char-table, with purpose PURPOSE.
2631 Each element is initialized to INIT, which defaults to nil.
2632 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
2633 The property's value should be an integer between 0 and 10. */)
2635 register Lisp_Object purpose
, init
;
2639 CHECK_SYMBOL (purpose
);
2640 n
= Fget (purpose
, Qchar_table_extra_slots
);
2642 if (XINT (n
) < 0 || XINT (n
) > 10)
2643 args_out_of_range (n
, Qnil
);
2644 /* Add 2 to the size for the defalt and parent slots. */
2645 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
2647 XCHAR_TABLE (vector
)->top
= Qt
;
2648 XCHAR_TABLE (vector
)->parent
= Qnil
;
2649 XCHAR_TABLE (vector
)->purpose
= purpose
;
2650 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2655 /* Return a newly created sub char table with default value DEFALT.
2656 Since a sub char table does not appear as a top level Emacs Lisp
2657 object, we don't need a Lisp interface to make it. */
2660 make_sub_char_table (defalt
)
2664 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
2665 XCHAR_TABLE (vector
)->top
= Qnil
;
2666 XCHAR_TABLE (vector
)->defalt
= defalt
;
2667 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
2672 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2673 doc
: /* Return a newly created vector with specified arguments as elements.
2674 Any number of arguments, even zero arguments, are allowed.
2675 usage: (vector &rest OBJECTS) */)
2680 register Lisp_Object len
, val
;
2682 register struct Lisp_Vector
*p
;
2684 XSETFASTINT (len
, nargs
);
2685 val
= Fmake_vector (len
, Qnil
);
2687 for (index
= 0; index
< nargs
; index
++)
2688 p
->contents
[index
] = args
[index
];
2693 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2694 doc
: /* Create a byte-code object with specified arguments as elements.
2695 The arguments should be the arglist, bytecode-string, constant vector,
2696 stack size, (optional) doc string, and (optional) interactive spec.
2697 The first four arguments are required; at most six have any
2699 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2704 register Lisp_Object len
, val
;
2706 register struct Lisp_Vector
*p
;
2708 XSETFASTINT (len
, nargs
);
2709 if (!NILP (Vpurify_flag
))
2710 val
= make_pure_vector ((EMACS_INT
) nargs
);
2712 val
= Fmake_vector (len
, Qnil
);
2714 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2715 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2716 earlier because they produced a raw 8-bit string for byte-code
2717 and now such a byte-code string is loaded as multibyte while
2718 raw 8-bit characters converted to multibyte form. Thus, now we
2719 must convert them back to the original unibyte form. */
2720 args
[1] = Fstring_as_unibyte (args
[1]);
2723 for (index
= 0; index
< nargs
; index
++)
2725 if (!NILP (Vpurify_flag
))
2726 args
[index
] = Fpurecopy (args
[index
]);
2727 p
->contents
[index
] = args
[index
];
2729 XSETCOMPILED (val
, p
);
2735 /***********************************************************************
2737 ***********************************************************************/
2739 /* Each symbol_block is just under 1020 bytes long, since malloc
2740 really allocates in units of powers of two and uses 4 bytes for its
2743 #define SYMBOL_BLOCK_SIZE \
2744 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2748 struct symbol_block
*next
;
2749 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
2752 /* Current symbol block and index of first unused Lisp_Symbol
2755 struct symbol_block
*symbol_block
;
2756 int symbol_block_index
;
2758 /* List of free symbols. */
2760 struct Lisp_Symbol
*symbol_free_list
;
2762 /* Total number of symbol blocks now in use. */
2764 int n_symbol_blocks
;
2767 /* Initialize symbol allocation. */
2772 symbol_block
= NULL
;
2773 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
2774 symbol_free_list
= 0;
2775 n_symbol_blocks
= 0;
2779 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
2780 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
2781 Its value and function definition are void, and its property list is nil. */)
2785 register Lisp_Object val
;
2786 register struct Lisp_Symbol
*p
;
2788 CHECK_STRING (name
);
2790 if (symbol_free_list
)
2792 XSETSYMBOL (val
, symbol_free_list
);
2793 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
2797 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
2799 struct symbol_block
*new;
2800 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
2802 new->next
= symbol_block
;
2804 symbol_block_index
= 0;
2807 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
2813 p
->value
= Qunbound
;
2814 p
->function
= Qunbound
;
2817 p
->interned
= SYMBOL_UNINTERNED
;
2819 p
->indirect_variable
= 0;
2820 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
2827 /***********************************************************************
2828 Marker (Misc) Allocation
2829 ***********************************************************************/
2831 /* Allocation of markers and other objects that share that structure.
2832 Works like allocation of conses. */
2834 #define MARKER_BLOCK_SIZE \
2835 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
2839 struct marker_block
*next
;
2840 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
2843 struct marker_block
*marker_block
;
2844 int marker_block_index
;
2846 union Lisp_Misc
*marker_free_list
;
2848 /* Total number of marker blocks now in use. */
2850 int n_marker_blocks
;
2855 marker_block
= NULL
;
2856 marker_block_index
= MARKER_BLOCK_SIZE
;
2857 marker_free_list
= 0;
2858 n_marker_blocks
= 0;
2861 /* Return a newly allocated Lisp_Misc object, with no substructure. */
2868 if (marker_free_list
)
2870 XSETMISC (val
, marker_free_list
);
2871 marker_free_list
= marker_free_list
->u_free
.chain
;
2875 if (marker_block_index
== MARKER_BLOCK_SIZE
)
2877 struct marker_block
*new;
2878 new = (struct marker_block
*) lisp_malloc (sizeof *new,
2880 new->next
= marker_block
;
2882 marker_block_index
= 0;
2885 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
2888 consing_since_gc
+= sizeof (union Lisp_Misc
);
2889 misc_objects_consed
++;
2890 XMARKER (val
)->gcmarkbit
= 0;
2894 /* Return a Lisp_Misc_Save_Value object containing POINTER and
2895 INTEGER. This is used to package C values to call record_unwind_protect.
2896 The unwind function can get the C values back using XSAVE_VALUE. */
2899 make_save_value (pointer
, integer
)
2903 register Lisp_Object val
;
2904 register struct Lisp_Save_Value
*p
;
2906 val
= allocate_misc ();
2907 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
2908 p
= XSAVE_VALUE (val
);
2909 p
->pointer
= pointer
;
2910 p
->integer
= integer
;
2914 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
2915 doc
: /* Return a newly allocated marker which does not point at any place. */)
2918 register Lisp_Object val
;
2919 register struct Lisp_Marker
*p
;
2921 val
= allocate_misc ();
2922 XMISCTYPE (val
) = Lisp_Misc_Marker
;
2928 p
->insertion_type
= 0;
2932 /* Put MARKER back on the free list after using it temporarily. */
2935 free_marker (marker
)
2938 unchain_marker (XMARKER (marker
));
2940 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
2941 XMISC (marker
)->u_free
.chain
= marker_free_list
;
2942 marker_free_list
= XMISC (marker
);
2944 total_free_markers
++;
2948 /* Return a newly created vector or string with specified arguments as
2949 elements. If all the arguments are characters that can fit
2950 in a string of events, make a string; otherwise, make a vector.
2952 Any number of arguments, even zero arguments, are allowed. */
2955 make_event_array (nargs
, args
)
2961 for (i
= 0; i
< nargs
; i
++)
2962 /* The things that fit in a string
2963 are characters that are in 0...127,
2964 after discarding the meta bit and all the bits above it. */
2965 if (!INTEGERP (args
[i
])
2966 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
2967 return Fvector (nargs
, args
);
2969 /* Since the loop exited, we know that all the things in it are
2970 characters, so we can make a string. */
2974 result
= Fmake_string (make_number (nargs
), make_number (0));
2975 for (i
= 0; i
< nargs
; i
++)
2977 SSET (result
, i
, XINT (args
[i
]));
2978 /* Move the meta bit to the right place for a string char. */
2979 if (XINT (args
[i
]) & CHAR_META
)
2980 SSET (result
, i
, SREF (result
, i
) | 0x80);
2989 /************************************************************************
2991 ************************************************************************/
2993 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
2995 /* Conservative C stack marking requires a method to identify possibly
2996 live Lisp objects given a pointer value. We do this by keeping
2997 track of blocks of Lisp data that are allocated in a red-black tree
2998 (see also the comment of mem_node which is the type of nodes in
2999 that tree). Function lisp_malloc adds information for an allocated
3000 block to the red-black tree with calls to mem_insert, and function
3001 lisp_free removes it with mem_delete. Functions live_string_p etc
3002 call mem_find to lookup information about a given pointer in the
3003 tree, and use that to determine if the pointer points to a Lisp
3006 /* Initialize this part of alloc.c. */
3011 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3012 mem_z
.parent
= NULL
;
3013 mem_z
.color
= MEM_BLACK
;
3014 mem_z
.start
= mem_z
.end
= NULL
;
3019 /* Value is a pointer to the mem_node containing START. Value is
3020 MEM_NIL if there is no node in the tree containing START. */
3022 static INLINE
struct mem_node
*
3028 if (start
< min_heap_address
|| start
> max_heap_address
)
3031 /* Make the search always successful to speed up the loop below. */
3032 mem_z
.start
= start
;
3033 mem_z
.end
= (char *) start
+ 1;
3036 while (start
< p
->start
|| start
>= p
->end
)
3037 p
= start
< p
->start
? p
->left
: p
->right
;
3042 /* Insert a new node into the tree for a block of memory with start
3043 address START, end address END, and type TYPE. Value is a
3044 pointer to the node that was inserted. */
3046 static struct mem_node
*
3047 mem_insert (start
, end
, type
)
3051 struct mem_node
*c
, *parent
, *x
;
3053 if (start
< min_heap_address
)
3054 min_heap_address
= start
;
3055 if (end
> max_heap_address
)
3056 max_heap_address
= end
;
3058 /* See where in the tree a node for START belongs. In this
3059 particular application, it shouldn't happen that a node is already
3060 present. For debugging purposes, let's check that. */
3064 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3066 while (c
!= MEM_NIL
)
3068 if (start
>= c
->start
&& start
< c
->end
)
3071 c
= start
< c
->start
? c
->left
: c
->right
;
3074 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3076 while (c
!= MEM_NIL
)
3079 c
= start
< c
->start
? c
->left
: c
->right
;
3082 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3084 /* Create a new node. */
3085 #ifdef GC_MALLOC_CHECK
3086 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3090 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3096 x
->left
= x
->right
= MEM_NIL
;
3099 /* Insert it as child of PARENT or install it as root. */
3102 if (start
< parent
->start
)
3110 /* Re-establish red-black tree properties. */
3111 mem_insert_fixup (x
);
3117 /* Re-establish the red-black properties of the tree, and thereby
3118 balance the tree, after node X has been inserted; X is always red. */
3121 mem_insert_fixup (x
)
3124 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3126 /* X is red and its parent is red. This is a violation of
3127 red-black tree property #3. */
3129 if (x
->parent
== x
->parent
->parent
->left
)
3131 /* We're on the left side of our grandparent, and Y is our
3133 struct mem_node
*y
= x
->parent
->parent
->right
;
3135 if (y
->color
== MEM_RED
)
3137 /* Uncle and parent are red but should be black because
3138 X is red. Change the colors accordingly and proceed
3139 with the grandparent. */
3140 x
->parent
->color
= MEM_BLACK
;
3141 y
->color
= MEM_BLACK
;
3142 x
->parent
->parent
->color
= MEM_RED
;
3143 x
= x
->parent
->parent
;
3147 /* Parent and uncle have different colors; parent is
3148 red, uncle is black. */
3149 if (x
== x
->parent
->right
)
3152 mem_rotate_left (x
);
3155 x
->parent
->color
= MEM_BLACK
;
3156 x
->parent
->parent
->color
= MEM_RED
;
3157 mem_rotate_right (x
->parent
->parent
);
3162 /* This is the symmetrical case of above. */
3163 struct mem_node
*y
= x
->parent
->parent
->left
;
3165 if (y
->color
== MEM_RED
)
3167 x
->parent
->color
= MEM_BLACK
;
3168 y
->color
= MEM_BLACK
;
3169 x
->parent
->parent
->color
= MEM_RED
;
3170 x
= x
->parent
->parent
;
3174 if (x
== x
->parent
->left
)
3177 mem_rotate_right (x
);
3180 x
->parent
->color
= MEM_BLACK
;
3181 x
->parent
->parent
->color
= MEM_RED
;
3182 mem_rotate_left (x
->parent
->parent
);
3187 /* The root may have been changed to red due to the algorithm. Set
3188 it to black so that property #5 is satisfied. */
3189 mem_root
->color
= MEM_BLACK
;
3205 /* Turn y's left sub-tree into x's right sub-tree. */
3208 if (y
->left
!= MEM_NIL
)
3209 y
->left
->parent
= x
;
3211 /* Y's parent was x's parent. */
3213 y
->parent
= x
->parent
;
3215 /* Get the parent to point to y instead of x. */
3218 if (x
== x
->parent
->left
)
3219 x
->parent
->left
= y
;
3221 x
->parent
->right
= y
;
3226 /* Put x on y's left. */
3240 mem_rotate_right (x
)
3243 struct mem_node
*y
= x
->left
;
3246 if (y
->right
!= MEM_NIL
)
3247 y
->right
->parent
= x
;
3250 y
->parent
= x
->parent
;
3253 if (x
== x
->parent
->right
)
3254 x
->parent
->right
= y
;
3256 x
->parent
->left
= y
;
3267 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3273 struct mem_node
*x
, *y
;
3275 if (!z
|| z
== MEM_NIL
)
3278 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3283 while (y
->left
!= MEM_NIL
)
3287 if (y
->left
!= MEM_NIL
)
3292 x
->parent
= y
->parent
;
3295 if (y
== y
->parent
->left
)
3296 y
->parent
->left
= x
;
3298 y
->parent
->right
= x
;
3305 z
->start
= y
->start
;
3310 if (y
->color
== MEM_BLACK
)
3311 mem_delete_fixup (x
);
3313 #ifdef GC_MALLOC_CHECK
3321 /* Re-establish the red-black properties of the tree, after a
3325 mem_delete_fixup (x
)
3328 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3330 if (x
== x
->parent
->left
)
3332 struct mem_node
*w
= x
->parent
->right
;
3334 if (w
->color
== MEM_RED
)
3336 w
->color
= MEM_BLACK
;
3337 x
->parent
->color
= MEM_RED
;
3338 mem_rotate_left (x
->parent
);
3339 w
= x
->parent
->right
;
3342 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3349 if (w
->right
->color
== MEM_BLACK
)
3351 w
->left
->color
= MEM_BLACK
;
3353 mem_rotate_right (w
);
3354 w
= x
->parent
->right
;
3356 w
->color
= x
->parent
->color
;
3357 x
->parent
->color
= MEM_BLACK
;
3358 w
->right
->color
= MEM_BLACK
;
3359 mem_rotate_left (x
->parent
);
3365 struct mem_node
*w
= x
->parent
->left
;
3367 if (w
->color
== MEM_RED
)
3369 w
->color
= MEM_BLACK
;
3370 x
->parent
->color
= MEM_RED
;
3371 mem_rotate_right (x
->parent
);
3372 w
= x
->parent
->left
;
3375 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3382 if (w
->left
->color
== MEM_BLACK
)
3384 w
->right
->color
= MEM_BLACK
;
3386 mem_rotate_left (w
);
3387 w
= x
->parent
->left
;
3390 w
->color
= x
->parent
->color
;
3391 x
->parent
->color
= MEM_BLACK
;
3392 w
->left
->color
= MEM_BLACK
;
3393 mem_rotate_right (x
->parent
);
3399 x
->color
= MEM_BLACK
;
3403 /* Value is non-zero if P is a pointer to a live Lisp string on
3404 the heap. M is a pointer to the mem_block for P. */
3407 live_string_p (m
, p
)
3411 if (m
->type
== MEM_TYPE_STRING
)
3413 struct string_block
*b
= (struct string_block
*) m
->start
;
3414 int offset
= (char *) p
- (char *) &b
->strings
[0];
3416 /* P must point to the start of a Lisp_String structure, and it
3417 must not be on the free-list. */
3419 && offset
% sizeof b
->strings
[0] == 0
3420 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3427 /* Value is non-zero if P is a pointer to a live Lisp cons on
3428 the heap. M is a pointer to the mem_block for P. */
3435 if (m
->type
== MEM_TYPE_CONS
)
3437 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3438 int offset
= (char *) p
- (char *) &b
->conses
[0];
3440 /* P must point to the start of a Lisp_Cons, not be
3441 one of the unused cells in the current cons block,
3442 and not be on the free-list. */
3444 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3445 && offset
% sizeof b
->conses
[0] == 0
3447 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3448 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3455 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3456 the heap. M is a pointer to the mem_block for P. */
3459 live_symbol_p (m
, p
)
3463 if (m
->type
== MEM_TYPE_SYMBOL
)
3465 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3466 int offset
= (char *) p
- (char *) &b
->symbols
[0];
3468 /* P must point to the start of a Lisp_Symbol, not be
3469 one of the unused cells in the current symbol block,
3470 and not be on the free-list. */
3472 && offset
% sizeof b
->symbols
[0] == 0
3473 && (b
!= symbol_block
3474 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3475 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3482 /* Value is non-zero if P is a pointer to a live Lisp float on
3483 the heap. M is a pointer to the mem_block for P. */
3490 if (m
->type
== MEM_TYPE_FLOAT
)
3492 struct float_block
*b
= (struct float_block
*) m
->start
;
3493 int offset
= (char *) p
- (char *) &b
->floats
[0];
3495 /* P must point to the start of a Lisp_Float and not be
3496 one of the unused cells in the current float block. */
3498 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3499 && offset
% sizeof b
->floats
[0] == 0
3500 && (b
!= float_block
3501 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3508 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3509 the heap. M is a pointer to the mem_block for P. */
3516 if (m
->type
== MEM_TYPE_MISC
)
3518 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3519 int offset
= (char *) p
- (char *) &b
->markers
[0];
3521 /* P must point to the start of a Lisp_Misc, not be
3522 one of the unused cells in the current misc block,
3523 and not be on the free-list. */
3525 && offset
% sizeof b
->markers
[0] == 0
3526 && (b
!= marker_block
3527 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3528 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
3535 /* Value is non-zero if P is a pointer to a live vector-like object.
3536 M is a pointer to the mem_block for P. */
3539 live_vector_p (m
, p
)
3543 return (p
== m
->start
3544 && m
->type
>= MEM_TYPE_VECTOR
3545 && m
->type
<= MEM_TYPE_WINDOW
);
3549 /* Value is non-zero if P is a pointer to a live buffer. M is a
3550 pointer to the mem_block for P. */
3553 live_buffer_p (m
, p
)
3557 /* P must point to the start of the block, and the buffer
3558 must not have been killed. */
3559 return (m
->type
== MEM_TYPE_BUFFER
3561 && !NILP (((struct buffer
*) p
)->name
));
3564 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3568 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3570 /* Array of objects that are kept alive because the C stack contains
3571 a pattern that looks like a reference to them . */
3573 #define MAX_ZOMBIES 10
3574 static Lisp_Object zombies
[MAX_ZOMBIES
];
3576 /* Number of zombie objects. */
3578 static int nzombies
;
3580 /* Number of garbage collections. */
3584 /* Average percentage of zombies per collection. */
3586 static double avg_zombies
;
3588 /* Max. number of live and zombie objects. */
3590 static int max_live
, max_zombies
;
3592 /* Average number of live objects per GC. */
3594 static double avg_live
;
3596 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3597 doc
: /* Show information about live and zombie objects. */)
3600 Lisp_Object args
[8], zombie_list
= Qnil
;
3602 for (i
= 0; i
< nzombies
; i
++)
3603 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3604 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3605 args
[1] = make_number (ngcs
);
3606 args
[2] = make_float (avg_live
);
3607 args
[3] = make_float (avg_zombies
);
3608 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3609 args
[5] = make_number (max_live
);
3610 args
[6] = make_number (max_zombies
);
3611 args
[7] = zombie_list
;
3612 return Fmessage (8, args
);
3615 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3618 /* Mark OBJ if we can prove it's a Lisp_Object. */
3621 mark_maybe_object (obj
)
3624 void *po
= (void *) XPNTR (obj
);
3625 struct mem_node
*m
= mem_find (po
);
3631 switch (XGCTYPE (obj
))
3634 mark_p
= (live_string_p (m
, po
)
3635 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3639 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
3643 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
3647 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
3650 case Lisp_Vectorlike
:
3651 /* Note: can't check GC_BUFFERP before we know it's a
3652 buffer because checking that dereferences the pointer
3653 PO which might point anywhere. */
3654 if (live_vector_p (m
, po
))
3655 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
3656 else if (live_buffer_p (m
, po
))
3657 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
3661 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
3665 case Lisp_Type_Limit
:
3671 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3672 if (nzombies
< MAX_ZOMBIES
)
3673 zombies
[nzombies
] = obj
;
3682 /* If P points to Lisp data, mark that as live if it isn't already
3686 mark_maybe_pointer (p
)
3691 /* Quickly rule out some values which can't point to Lisp data. We
3692 assume that Lisp data is aligned on even addresses. */
3693 if ((EMACS_INT
) p
& 1)
3699 Lisp_Object obj
= Qnil
;
3703 case MEM_TYPE_NON_LISP
:
3704 /* Nothing to do; not a pointer to Lisp memory. */
3707 case MEM_TYPE_BUFFER
:
3708 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
3709 XSETVECTOR (obj
, p
);
3713 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
3717 case MEM_TYPE_STRING
:
3718 if (live_string_p (m
, p
)
3719 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
3720 XSETSTRING (obj
, p
);
3724 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
3728 case MEM_TYPE_SYMBOL
:
3729 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
3730 XSETSYMBOL (obj
, p
);
3733 case MEM_TYPE_FLOAT
:
3734 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
3738 case MEM_TYPE_VECTOR
:
3739 case MEM_TYPE_PROCESS
:
3740 case MEM_TYPE_HASH_TABLE
:
3741 case MEM_TYPE_FRAME
:
3742 case MEM_TYPE_WINDOW
:
3743 if (live_vector_p (m
, p
))
3746 XSETVECTOR (tem
, p
);
3747 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
3762 /* Mark Lisp objects referenced from the address range START..END. */
3765 mark_memory (start
, end
)
3771 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3775 /* Make START the pointer to the start of the memory region,
3776 if it isn't already. */
3784 /* Mark Lisp_Objects. */
3785 for (p
= (Lisp_Object
*) start
; (void *) p
< end
; ++p
)
3786 mark_maybe_object (*p
);
3788 /* Mark Lisp data pointed to. This is necessary because, in some
3789 situations, the C compiler optimizes Lisp objects away, so that
3790 only a pointer to them remains. Example:
3792 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
3795 Lisp_Object obj = build_string ("test");
3796 struct Lisp_String *s = XSTRING (obj);
3797 Fgarbage_collect ();
3798 fprintf (stderr, "test `%s'\n", s->data);
3802 Here, `obj' isn't really used, and the compiler optimizes it
3803 away. The only reference to the life string is through the
3806 for (pp
= (void **) start
; (void *) pp
< end
; ++pp
)
3807 mark_maybe_pointer (*pp
);
3810 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
3811 the GCC system configuration. In gcc 3.2, the only systems for
3812 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
3813 by others?) and ns32k-pc532-min. */
3815 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
3817 static int setjmp_tested_p
, longjmps_done
;
3819 #define SETJMP_WILL_LIKELY_WORK "\
3821 Emacs garbage collector has been changed to use conservative stack\n\
3822 marking. Emacs has determined that the method it uses to do the\n\
3823 marking will likely work on your system, but this isn't sure.\n\
3825 If you are a system-programmer, or can get the help of a local wizard\n\
3826 who is, please take a look at the function mark_stack in alloc.c, and\n\
3827 verify that the methods used are appropriate for your system.\n\
3829 Please mail the result to <emacs-devel@gnu.org>.\n\
3832 #define SETJMP_WILL_NOT_WORK "\
3834 Emacs garbage collector has been changed to use conservative stack\n\
3835 marking. Emacs has determined that the default method it uses to do the\n\
3836 marking will not work on your system. We will need a system-dependent\n\
3837 solution for your system.\n\
3839 Please take a look at the function mark_stack in alloc.c, and\n\
3840 try to find a way to make it work on your system.\n\
3842 Note that you may get false negatives, depending on the compiler.\n\
3843 In particular, you need to use -O with GCC for this test.\n\
3845 Please mail the result to <emacs-devel@gnu.org>.\n\
3849 /* Perform a quick check if it looks like setjmp saves registers in a
3850 jmp_buf. Print a message to stderr saying so. When this test
3851 succeeds, this is _not_ a proof that setjmp is sufficient for
3852 conservative stack marking. Only the sources or a disassembly
3863 /* Arrange for X to be put in a register. */
3869 if (longjmps_done
== 1)
3871 /* Came here after the longjmp at the end of the function.
3873 If x == 1, the longjmp has restored the register to its
3874 value before the setjmp, and we can hope that setjmp
3875 saves all such registers in the jmp_buf, although that
3878 For other values of X, either something really strange is
3879 taking place, or the setjmp just didn't save the register. */
3882 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
3885 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
3892 if (longjmps_done
== 1)
3896 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
3899 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
3901 /* Abort if anything GCPRO'd doesn't survive the GC. */
3909 for (p
= gcprolist
; p
; p
= p
->next
)
3910 for (i
= 0; i
< p
->nvars
; ++i
)
3911 if (!survives_gc_p (p
->var
[i
]))
3912 /* FIXME: It's not necessarily a bug. It might just be that the
3913 GCPRO is unnecessary or should release the object sooner. */
3917 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3924 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
3925 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
3927 fprintf (stderr
, " %d = ", i
);
3928 debug_print (zombies
[i
]);
3932 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3935 /* Mark live Lisp objects on the C stack.
3937 There are several system-dependent problems to consider when
3938 porting this to new architectures:
3942 We have to mark Lisp objects in CPU registers that can hold local
3943 variables or are used to pass parameters.
3945 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
3946 something that either saves relevant registers on the stack, or
3947 calls mark_maybe_object passing it each register's contents.
3949 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
3950 implementation assumes that calling setjmp saves registers we need
3951 to see in a jmp_buf which itself lies on the stack. This doesn't
3952 have to be true! It must be verified for each system, possibly
3953 by taking a look at the source code of setjmp.
3957 Architectures differ in the way their processor stack is organized.
3958 For example, the stack might look like this
3961 | Lisp_Object | size = 4
3963 | something else | size = 2
3965 | Lisp_Object | size = 4
3969 In such a case, not every Lisp_Object will be aligned equally. To
3970 find all Lisp_Object on the stack it won't be sufficient to walk
3971 the stack in steps of 4 bytes. Instead, two passes will be
3972 necessary, one starting at the start of the stack, and a second
3973 pass starting at the start of the stack + 2. Likewise, if the
3974 minimal alignment of Lisp_Objects on the stack is 1, four passes
3975 would be necessary, each one starting with one byte more offset
3976 from the stack start.
3978 The current code assumes by default that Lisp_Objects are aligned
3979 equally on the stack. */
3986 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
3989 /* This trick flushes the register windows so that all the state of
3990 the process is contained in the stack. */
3991 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
3992 needed on ia64 too. See mach_dep.c, where it also says inline
3993 assembler doesn't work with relevant proprietary compilers. */
3998 /* Save registers that we need to see on the stack. We need to see
3999 registers used to hold register variables and registers used to
4001 #ifdef GC_SAVE_REGISTERS_ON_STACK
4002 GC_SAVE_REGISTERS_ON_STACK (end
);
4003 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4005 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4006 setjmp will definitely work, test it
4007 and print a message with the result
4009 if (!setjmp_tested_p
)
4011 setjmp_tested_p
= 1;
4014 #endif /* GC_SETJMP_WORKS */
4017 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4018 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4020 /* This assumes that the stack is a contiguous region in memory. If
4021 that's not the case, something has to be done here to iterate
4022 over the stack segments. */
4023 #ifndef GC_LISP_OBJECT_ALIGNMENT
4025 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4027 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4030 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4031 mark_memory ((char *) stack_base
+ i
, end
);
4033 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4039 #endif /* GC_MARK_STACK != 0 */
4043 /***********************************************************************
4044 Pure Storage Management
4045 ***********************************************************************/
4047 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4048 pointer to it. TYPE is the Lisp type for which the memory is
4049 allocated. TYPE < 0 means it's not used for a Lisp object.
4051 If store_pure_type_info is set and TYPE is >= 0, the type of
4052 the allocated object is recorded in pure_types. */
4054 static POINTER_TYPE
*
4055 pure_alloc (size
, type
)
4059 POINTER_TYPE
*result
;
4060 size_t alignment
= sizeof (EMACS_INT
);
4062 /* Give Lisp_Floats an extra alignment. */
4063 if (type
== Lisp_Float
)
4065 #if defined __GNUC__ && __GNUC__ >= 2
4066 alignment
= __alignof (struct Lisp_Float
);
4068 alignment
= sizeof (struct Lisp_Float
);
4073 result
= ALIGN (purebeg
+ pure_bytes_used
, alignment
);
4074 pure_bytes_used
= ((char *)result
- (char *)purebeg
) + size
;
4076 if (pure_bytes_used
<= pure_size
)
4079 /* Don't allocate a large amount here,
4080 because it might get mmap'd and then its address
4081 might not be usable. */
4082 purebeg
= (char *) xmalloc (10000);
4084 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4085 pure_bytes_used
= 0;
4090 /* Print a warning if PURESIZE is too small. */
4095 if (pure_bytes_used_before_overflow
)
4096 message ("Pure Lisp storage overflow (approx. %d bytes needed)",
4097 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4101 /* Return a string allocated in pure space. DATA is a buffer holding
4102 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4103 non-zero means make the result string multibyte.
4105 Must get an error if pure storage is full, since if it cannot hold
4106 a large string it may be able to hold conses that point to that
4107 string; then the string is not protected from gc. */
4110 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4116 struct Lisp_String
*s
;
4118 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4119 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4121 s
->size_byte
= multibyte
? nbytes
: -1;
4122 bcopy (data
, s
->data
, nbytes
);
4123 s
->data
[nbytes
] = '\0';
4124 s
->intervals
= NULL_INTERVAL
;
4125 XSETSTRING (string
, s
);
4130 /* Return a cons allocated from pure space. Give it pure copies
4131 of CAR as car and CDR as cdr. */
4134 pure_cons (car
, cdr
)
4135 Lisp_Object car
, cdr
;
4137 register Lisp_Object
new;
4138 struct Lisp_Cons
*p
;
4140 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4142 XSETCAR (new, Fpurecopy (car
));
4143 XSETCDR (new, Fpurecopy (cdr
));
4148 /* Value is a float object with value NUM allocated from pure space. */
4151 make_pure_float (num
)
4154 register Lisp_Object
new;
4155 struct Lisp_Float
*p
;
4157 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4159 XFLOAT_DATA (new) = num
;
4164 /* Return a vector with room for LEN Lisp_Objects allocated from
4168 make_pure_vector (len
)
4172 struct Lisp_Vector
*p
;
4173 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4175 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4176 XSETVECTOR (new, p
);
4177 XVECTOR (new)->size
= len
;
4182 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4183 doc
: /* Make a copy of OBJECT in pure storage.
4184 Recursively copies contents of vectors and cons cells.
4185 Does not copy symbols. Copies strings without text properties. */)
4187 register Lisp_Object obj
;
4189 if (NILP (Vpurify_flag
))
4192 if (PURE_POINTER_P (XPNTR (obj
)))
4196 return pure_cons (XCAR (obj
), XCDR (obj
));
4197 else if (FLOATP (obj
))
4198 return make_pure_float (XFLOAT_DATA (obj
));
4199 else if (STRINGP (obj
))
4200 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4202 STRING_MULTIBYTE (obj
));
4203 else if (COMPILEDP (obj
) || VECTORP (obj
))
4205 register struct Lisp_Vector
*vec
;
4206 register int i
, size
;
4208 size
= XVECTOR (obj
)->size
;
4209 if (size
& PSEUDOVECTOR_FLAG
)
4210 size
&= PSEUDOVECTOR_SIZE_MASK
;
4211 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
4212 for (i
= 0; i
< size
; i
++)
4213 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4214 if (COMPILEDP (obj
))
4215 XSETCOMPILED (obj
, vec
);
4217 XSETVECTOR (obj
, vec
);
4220 else if (MARKERP (obj
))
4221 error ("Attempt to copy a marker to pure storage");
4228 /***********************************************************************
4230 ***********************************************************************/
4232 /* Put an entry in staticvec, pointing at the variable with address
4236 staticpro (varaddress
)
4237 Lisp_Object
*varaddress
;
4239 staticvec
[staticidx
++] = varaddress
;
4240 if (staticidx
>= NSTATICS
)
4248 struct catchtag
*next
;
4253 struct backtrace
*next
;
4254 Lisp_Object
*function
;
4255 Lisp_Object
*args
; /* Points to vector of args. */
4256 int nargs
; /* Length of vector. */
4257 /* If nargs is UNEVALLED, args points to slot holding list of
4264 /***********************************************************************
4266 ***********************************************************************/
4268 /* Temporarily prevent garbage collection. */
4271 inhibit_garbage_collection ()
4273 int count
= SPECPDL_INDEX ();
4274 int nbits
= min (VALBITS
, BITS_PER_INT
);
4276 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4281 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4282 doc
: /* Reclaim storage for Lisp objects no longer needed.
4283 Garbage collection happens automatically if you cons more than
4284 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4285 `garbage-collect' normally returns a list with info on amount of space in use:
4286 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4287 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4288 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4289 (USED-STRINGS . FREE-STRINGS))
4290 However, if there was overflow in pure space, `garbage-collect'
4291 returns nil, because real GC can't be done. */)
4294 register struct specbinding
*bind
;
4295 struct catchtag
*catch;
4296 struct handler
*handler
;
4297 register struct backtrace
*backlist
;
4298 char stack_top_variable
;
4301 Lisp_Object total
[8];
4302 int count
= SPECPDL_INDEX ();
4303 EMACS_TIME t1
, t2
, t3
;
4308 EMACS_GET_TIME (t1
);
4310 /* Can't GC if pure storage overflowed because we can't determine
4311 if something is a pure object or not. */
4312 if (pure_bytes_used_before_overflow
)
4315 /* In case user calls debug_print during GC,
4316 don't let that cause a recursive GC. */
4317 consing_since_gc
= 0;
4319 /* Save what's currently displayed in the echo area. */
4320 message_p
= push_message ();
4321 record_unwind_protect (pop_message_unwind
, Qnil
);
4323 /* Save a copy of the contents of the stack, for debugging. */
4324 #if MAX_SAVE_STACK > 0
4325 if (NILP (Vpurify_flag
))
4327 i
= &stack_top_variable
- stack_bottom
;
4329 if (i
< MAX_SAVE_STACK
)
4331 if (stack_copy
== 0)
4332 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4333 else if (stack_copy_size
< i
)
4334 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4337 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4338 bcopy (stack_bottom
, stack_copy
, i
);
4340 bcopy (&stack_top_variable
, stack_copy
, i
);
4344 #endif /* MAX_SAVE_STACK > 0 */
4346 if (garbage_collection_messages
)
4347 message1_nolog ("Garbage collecting...");
4351 shrink_regexp_cache ();
4353 /* Don't keep undo information around forever. */
4355 register struct buffer
*nextb
= all_buffers
;
4359 /* If a buffer's undo list is Qt, that means that undo is
4360 turned off in that buffer. Calling truncate_undo_list on
4361 Qt tends to return NULL, which effectively turns undo back on.
4362 So don't call truncate_undo_list if undo_list is Qt. */
4363 if (! EQ (nextb
->undo_list
, Qt
))
4365 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
4368 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4369 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
4371 /* If a buffer's gap size is more than 10% of the buffer
4372 size, or larger than 2000 bytes, then shrink it
4373 accordingly. Keep a minimum size of 20 bytes. */
4374 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4376 if (nextb
->text
->gap_size
> size
)
4378 struct buffer
*save_current
= current_buffer
;
4379 current_buffer
= nextb
;
4380 make_gap (-(nextb
->text
->gap_size
- size
));
4381 current_buffer
= save_current
;
4385 nextb
= nextb
->next
;
4391 /* clear_marks (); */
4393 /* Mark all the special slots that serve as the roots of accessibility. */
4395 for (i
= 0; i
< staticidx
; i
++)
4396 mark_object (*staticvec
[i
]);
4398 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4399 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4403 register struct gcpro
*tail
;
4404 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4405 for (i
= 0; i
< tail
->nvars
; i
++)
4406 mark_object (tail
->var
[i
]);
4411 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4413 mark_object (bind
->symbol
);
4414 mark_object (bind
->old_value
);
4416 for (catch = catchlist
; catch; catch = catch->next
)
4418 mark_object (catch->tag
);
4419 mark_object (catch->val
);
4421 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4423 mark_object (handler
->handler
);
4424 mark_object (handler
->var
);
4426 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
4428 mark_object (*backlist
->function
);
4430 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
4433 i
= backlist
->nargs
- 1;
4435 mark_object (backlist
->args
[i
]);
4439 /* Look thru every buffer's undo list
4440 for elements that update markers that were not marked,
4443 register struct buffer
*nextb
= all_buffers
;
4447 /* If a buffer's undo list is Qt, that means that undo is
4448 turned off in that buffer. Calling truncate_undo_list on
4449 Qt tends to return NULL, which effectively turns undo back on.
4450 So don't call truncate_undo_list if undo_list is Qt. */
4451 if (! EQ (nextb
->undo_list
, Qt
))
4453 Lisp_Object tail
, prev
;
4454 tail
= nextb
->undo_list
;
4456 while (CONSP (tail
))
4458 if (GC_CONSP (XCAR (tail
))
4459 && GC_MARKERP (XCAR (XCAR (tail
)))
4460 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
4463 nextb
->undo_list
= tail
= XCDR (tail
);
4467 XSETCDR (prev
, tail
);
4478 nextb
= nextb
->next
;
4482 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4488 extern void xg_mark_data ();
4495 /* Clear the mark bits that we set in certain root slots. */
4497 #if (GC_MARK_STACK == GC_USE_GCPROS_AS_BEFORE \
4498 || GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES)
4500 register struct gcpro
*tail
;
4504 unmark_byte_stack ();
4505 VECTOR_UNMARK (&buffer_defaults
);
4506 VECTOR_UNMARK (&buffer_local_symbols
);
4508 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
4514 /* clear_marks (); */
4517 consing_since_gc
= 0;
4518 if (gc_cons_threshold
< 10000)
4519 gc_cons_threshold
= 10000;
4521 if (garbage_collection_messages
)
4523 if (message_p
|| minibuf_level
> 0)
4526 message1_nolog ("Garbage collecting...done");
4529 unbind_to (count
, Qnil
);
4531 total
[0] = Fcons (make_number (total_conses
),
4532 make_number (total_free_conses
));
4533 total
[1] = Fcons (make_number (total_symbols
),
4534 make_number (total_free_symbols
));
4535 total
[2] = Fcons (make_number (total_markers
),
4536 make_number (total_free_markers
));
4537 total
[3] = make_number (total_string_size
);
4538 total
[4] = make_number (total_vector_size
);
4539 total
[5] = Fcons (make_number (total_floats
),
4540 make_number (total_free_floats
));
4541 total
[6] = Fcons (make_number (total_intervals
),
4542 make_number (total_free_intervals
));
4543 total
[7] = Fcons (make_number (total_strings
),
4544 make_number (total_free_strings
));
4546 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4548 /* Compute average percentage of zombies. */
4551 for (i
= 0; i
< 7; ++i
)
4552 if (CONSP (total
[i
]))
4553 nlive
+= XFASTINT (XCAR (total
[i
]));
4555 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
4556 max_live
= max (nlive
, max_live
);
4557 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
4558 max_zombies
= max (nzombies
, max_zombies
);
4563 if (!NILP (Vpost_gc_hook
))
4565 int count
= inhibit_garbage_collection ();
4566 safe_run_hooks (Qpost_gc_hook
);
4567 unbind_to (count
, Qnil
);
4570 /* Accumulate statistics. */
4571 EMACS_GET_TIME (t2
);
4572 EMACS_SUB_TIME (t3
, t2
, t1
);
4573 if (FLOATP (Vgc_elapsed
))
4574 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
4576 EMACS_USECS (t3
) * 1.0e-6);
4579 return Flist (sizeof total
/ sizeof *total
, total
);
4583 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
4584 only interesting objects referenced from glyphs are strings. */
4587 mark_glyph_matrix (matrix
)
4588 struct glyph_matrix
*matrix
;
4590 struct glyph_row
*row
= matrix
->rows
;
4591 struct glyph_row
*end
= row
+ matrix
->nrows
;
4593 for (; row
< end
; ++row
)
4597 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
4599 struct glyph
*glyph
= row
->glyphs
[area
];
4600 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
4602 for (; glyph
< end_glyph
; ++glyph
)
4603 if (GC_STRINGP (glyph
->object
)
4604 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
4605 mark_object (glyph
->object
);
4611 /* Mark Lisp faces in the face cache C. */
4615 struct face_cache
*c
;
4620 for (i
= 0; i
< c
->used
; ++i
)
4622 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
4626 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
4627 mark_object (face
->lface
[j
]);
4634 #ifdef HAVE_WINDOW_SYSTEM
4636 /* Mark Lisp objects in image IMG. */
4642 mark_object (img
->spec
);
4644 if (!NILP (img
->data
.lisp_val
))
4645 mark_object (img
->data
.lisp_val
);
4649 /* Mark Lisp objects in image cache of frame F. It's done this way so
4650 that we don't have to include xterm.h here. */
4653 mark_image_cache (f
)
4656 forall_images_in_image_cache (f
, mark_image
);
4659 #endif /* HAVE_X_WINDOWS */
4663 /* Mark reference to a Lisp_Object.
4664 If the object referred to has not been seen yet, recursively mark
4665 all the references contained in it. */
4667 #define LAST_MARKED_SIZE 500
4668 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
4669 int last_marked_index
;
4671 /* For debugging--call abort when we cdr down this many
4672 links of a list, in mark_object. In debugging,
4673 the call to abort will hit a breakpoint.
4674 Normally this is zero and the check never goes off. */
4675 int mark_object_loop_halt
;
4681 register Lisp_Object obj
= arg
;
4682 #ifdef GC_CHECK_MARKED_OBJECTS
4690 if (PURE_POINTER_P (XPNTR (obj
)))
4693 last_marked
[last_marked_index
++] = obj
;
4694 if (last_marked_index
== LAST_MARKED_SIZE
)
4695 last_marked_index
= 0;
4697 /* Perform some sanity checks on the objects marked here. Abort if
4698 we encounter an object we know is bogus. This increases GC time
4699 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
4700 #ifdef GC_CHECK_MARKED_OBJECTS
4702 po
= (void *) XPNTR (obj
);
4704 /* Check that the object pointed to by PO is known to be a Lisp
4705 structure allocated from the heap. */
4706 #define CHECK_ALLOCATED() \
4708 m = mem_find (po); \
4713 /* Check that the object pointed to by PO is live, using predicate
4715 #define CHECK_LIVE(LIVEP) \
4717 if (!LIVEP (m, po)) \
4721 /* Check both of the above conditions. */
4722 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
4724 CHECK_ALLOCATED (); \
4725 CHECK_LIVE (LIVEP); \
4728 #else /* not GC_CHECK_MARKED_OBJECTS */
4730 #define CHECK_ALLOCATED() (void) 0
4731 #define CHECK_LIVE(LIVEP) (void) 0
4732 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
4734 #endif /* not GC_CHECK_MARKED_OBJECTS */
4736 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
4740 register struct Lisp_String
*ptr
= XSTRING (obj
);
4741 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
4742 MARK_INTERVAL_TREE (ptr
->intervals
);
4744 #ifdef GC_CHECK_STRING_BYTES
4745 /* Check that the string size recorded in the string is the
4746 same as the one recorded in the sdata structure. */
4747 CHECK_STRING_BYTES (ptr
);
4748 #endif /* GC_CHECK_STRING_BYTES */
4752 case Lisp_Vectorlike
:
4753 #ifdef GC_CHECK_MARKED_OBJECTS
4755 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
4756 && po
!= &buffer_defaults
4757 && po
!= &buffer_local_symbols
)
4759 #endif /* GC_CHECK_MARKED_OBJECTS */
4761 if (GC_BUFFERP (obj
))
4763 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
4765 #ifdef GC_CHECK_MARKED_OBJECTS
4766 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
4769 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
4774 #endif /* GC_CHECK_MARKED_OBJECTS */
4778 else if (GC_SUBRP (obj
))
4780 else if (GC_COMPILEDP (obj
))
4781 /* We could treat this just like a vector, but it is better to
4782 save the COMPILED_CONSTANTS element for last and avoid
4785 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4786 register EMACS_INT size
= ptr
->size
;
4789 if (VECTOR_MARKED_P (ptr
))
4790 break; /* Already marked */
4792 CHECK_LIVE (live_vector_p
);
4793 VECTOR_MARK (ptr
); /* Else mark it */
4794 size
&= PSEUDOVECTOR_SIZE_MASK
;
4795 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4797 if (i
!= COMPILED_CONSTANTS
)
4798 mark_object (ptr
->contents
[i
]);
4800 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
4803 else if (GC_FRAMEP (obj
))
4805 register struct frame
*ptr
= XFRAME (obj
);
4807 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4808 VECTOR_MARK (ptr
); /* Else mark it */
4810 CHECK_LIVE (live_vector_p
);
4811 mark_object (ptr
->name
);
4812 mark_object (ptr
->icon_name
);
4813 mark_object (ptr
->title
);
4814 mark_object (ptr
->focus_frame
);
4815 mark_object (ptr
->selected_window
);
4816 mark_object (ptr
->minibuffer_window
);
4817 mark_object (ptr
->param_alist
);
4818 mark_object (ptr
->scroll_bars
);
4819 mark_object (ptr
->condemned_scroll_bars
);
4820 mark_object (ptr
->menu_bar_items
);
4821 mark_object (ptr
->face_alist
);
4822 mark_object (ptr
->menu_bar_vector
);
4823 mark_object (ptr
->buffer_predicate
);
4824 mark_object (ptr
->buffer_list
);
4825 mark_object (ptr
->menu_bar_window
);
4826 mark_object (ptr
->tool_bar_window
);
4827 mark_face_cache (ptr
->face_cache
);
4828 #ifdef HAVE_WINDOW_SYSTEM
4829 mark_image_cache (ptr
);
4830 mark_object (ptr
->tool_bar_items
);
4831 mark_object (ptr
->desired_tool_bar_string
);
4832 mark_object (ptr
->current_tool_bar_string
);
4833 #endif /* HAVE_WINDOW_SYSTEM */
4835 else if (GC_BOOL_VECTOR_P (obj
))
4837 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4839 if (VECTOR_MARKED_P (ptr
))
4840 break; /* Already marked */
4841 CHECK_LIVE (live_vector_p
);
4842 VECTOR_MARK (ptr
); /* Else mark it */
4844 else if (GC_WINDOWP (obj
))
4846 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4847 struct window
*w
= XWINDOW (obj
);
4850 /* Stop if already marked. */
4851 if (VECTOR_MARKED_P (ptr
))
4855 CHECK_LIVE (live_vector_p
);
4858 /* There is no Lisp data above The member CURRENT_MATRIX in
4859 struct WINDOW. Stop marking when that slot is reached. */
4861 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
4863 mark_object (ptr
->contents
[i
]);
4865 /* Mark glyphs for leaf windows. Marking window matrices is
4866 sufficient because frame matrices use the same glyph
4868 if (NILP (w
->hchild
)
4870 && w
->current_matrix
)
4872 mark_glyph_matrix (w
->current_matrix
);
4873 mark_glyph_matrix (w
->desired_matrix
);
4876 else if (GC_HASH_TABLE_P (obj
))
4878 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
4880 /* Stop if already marked. */
4881 if (VECTOR_MARKED_P (h
))
4885 CHECK_LIVE (live_vector_p
);
4888 /* Mark contents. */
4889 /* Do not mark next_free or next_weak.
4890 Being in the next_weak chain
4891 should not keep the hash table alive.
4892 No need to mark `count' since it is an integer. */
4893 mark_object (h
->test
);
4894 mark_object (h
->weak
);
4895 mark_object (h
->rehash_size
);
4896 mark_object (h
->rehash_threshold
);
4897 mark_object (h
->hash
);
4898 mark_object (h
->next
);
4899 mark_object (h
->index
);
4900 mark_object (h
->user_hash_function
);
4901 mark_object (h
->user_cmp_function
);
4903 /* If hash table is not weak, mark all keys and values.
4904 For weak tables, mark only the vector. */
4905 if (GC_NILP (h
->weak
))
4906 mark_object (h
->key_and_value
);
4908 VECTOR_MARK (XVECTOR (h
->key_and_value
));
4912 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
4913 register EMACS_INT size
= ptr
->size
;
4916 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
4917 CHECK_LIVE (live_vector_p
);
4918 VECTOR_MARK (ptr
); /* Else mark it */
4919 if (size
& PSEUDOVECTOR_FLAG
)
4920 size
&= PSEUDOVECTOR_SIZE_MASK
;
4922 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
4923 mark_object (ptr
->contents
[i
]);
4929 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
4930 struct Lisp_Symbol
*ptrx
;
4932 if (ptr
->gcmarkbit
) break;
4933 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
4935 mark_object (ptr
->value
);
4936 mark_object (ptr
->function
);
4937 mark_object (ptr
->plist
);
4939 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
4940 MARK_STRING (XSTRING (ptr
->xname
));
4941 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
4943 /* Note that we do not mark the obarray of the symbol.
4944 It is safe not to do so because nothing accesses that
4945 slot except to check whether it is nil. */
4949 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
4950 XSETSYMBOL (obj
, ptrx
);
4957 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
4958 if (XMARKER (obj
)->gcmarkbit
)
4960 XMARKER (obj
)->gcmarkbit
= 1;
4961 switch (XMISCTYPE (obj
))
4963 case Lisp_Misc_Buffer_Local_Value
:
4964 case Lisp_Misc_Some_Buffer_Local_Value
:
4966 register struct Lisp_Buffer_Local_Value
*ptr
4967 = XBUFFER_LOCAL_VALUE (obj
);
4968 /* If the cdr is nil, avoid recursion for the car. */
4969 if (EQ (ptr
->cdr
, Qnil
))
4971 obj
= ptr
->realvalue
;
4974 mark_object (ptr
->realvalue
);
4975 mark_object (ptr
->buffer
);
4976 mark_object (ptr
->frame
);
4981 case Lisp_Misc_Marker
:
4982 /* DO NOT mark thru the marker's chain.
4983 The buffer's markers chain does not preserve markers from gc;
4984 instead, markers are removed from the chain when freed by gc. */
4985 case Lisp_Misc_Intfwd
:
4986 case Lisp_Misc_Boolfwd
:
4987 case Lisp_Misc_Objfwd
:
4988 case Lisp_Misc_Buffer_Objfwd
:
4989 case Lisp_Misc_Kboard_Objfwd
:
4990 /* Don't bother with Lisp_Buffer_Objfwd,
4991 since all markable slots in current buffer marked anyway. */
4992 /* Don't need to do Lisp_Objfwd, since the places they point
4993 are protected with staticpro. */
4994 case Lisp_Misc_Save_Value
:
4997 case Lisp_Misc_Overlay
:
4999 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5000 mark_object (ptr
->start
);
5001 mark_object (ptr
->end
);
5002 mark_object (ptr
->plist
);
5005 XSETMISC (obj
, ptr
->next
);
5018 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5019 if (CONS_MARKED_P (ptr
)) break;
5020 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5022 /* If the cdr is nil, avoid recursion for the car. */
5023 if (EQ (ptr
->cdr
, Qnil
))
5029 mark_object (ptr
->car
);
5032 if (cdr_count
== mark_object_loop_halt
)
5038 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5039 FLOAT_MARK (XFLOAT (obj
));
5050 #undef CHECK_ALLOCATED
5051 #undef CHECK_ALLOCATED_AND_LIVE
5054 /* Mark the pointers in a buffer structure. */
5060 register struct buffer
*buffer
= XBUFFER (buf
);
5061 register Lisp_Object
*ptr
, tmp
;
5062 Lisp_Object base_buffer
;
5064 VECTOR_MARK (buffer
);
5066 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5068 if (CONSP (buffer
->undo_list
))
5071 tail
= buffer
->undo_list
;
5073 /* We mark the undo list specially because
5074 its pointers to markers should be weak. */
5076 while (CONSP (tail
))
5078 register struct Lisp_Cons
*ptr
= XCONS (tail
);
5080 if (CONS_MARKED_P (ptr
))
5083 if (GC_CONSP (ptr
->car
)
5084 && !CONS_MARKED_P (XCONS (ptr
->car
))
5085 && GC_MARKERP (XCAR (ptr
->car
)))
5087 CONS_MARK (XCONS (ptr
->car
));
5088 mark_object (XCDR (ptr
->car
));
5091 mark_object (ptr
->car
);
5093 if (CONSP (ptr
->cdr
))
5099 mark_object (XCDR (tail
));
5102 mark_object (buffer
->undo_list
);
5104 if (buffer
->overlays_before
)
5106 XSETMISC (tmp
, buffer
->overlays_before
);
5109 if (buffer
->overlays_after
)
5111 XSETMISC (tmp
, buffer
->overlays_after
);
5115 for (ptr
= &buffer
->name
;
5116 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5120 /* If this is an indirect buffer, mark its base buffer. */
5121 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5123 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5124 mark_buffer (base_buffer
);
5129 /* Value is non-zero if OBJ will survive the current GC because it's
5130 either marked or does not need to be marked to survive. */
5138 switch (XGCTYPE (obj
))
5145 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5149 survives_p
= XMARKER (obj
)->gcmarkbit
;
5153 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5156 case Lisp_Vectorlike
:
5157 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5161 survives_p
= CONS_MARKED_P (XCONS (obj
));
5165 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5172 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5177 /* Sweep: find all structures not marked, and free them. */
5182 /* Remove or mark entries in weak hash tables.
5183 This must be done before any object is unmarked. */
5184 sweep_weak_hash_tables ();
5187 #ifdef GC_CHECK_STRING_BYTES
5188 if (!noninteractive
)
5189 check_string_bytes (1);
5192 /* Put all unmarked conses on free list */
5194 register struct cons_block
*cblk
;
5195 struct cons_block
**cprev
= &cons_block
;
5196 register int lim
= cons_block_index
;
5197 register int num_free
= 0, num_used
= 0;
5201 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5205 for (i
= 0; i
< lim
; i
++)
5206 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5209 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
5210 cons_free_list
= &cblk
->conses
[i
];
5212 cons_free_list
->car
= Vdead
;
5218 CONS_UNMARK (&cblk
->conses
[i
]);
5220 lim
= CONS_BLOCK_SIZE
;
5221 /* If this block contains only free conses and we have already
5222 seen more than two blocks worth of free conses then deallocate
5224 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5226 *cprev
= cblk
->next
;
5227 /* Unhook from the free list. */
5228 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
5229 lisp_align_free (cblk
);
5234 num_free
+= this_free
;
5235 cprev
= &cblk
->next
;
5238 total_conses
= num_used
;
5239 total_free_conses
= num_free
;
5242 /* Put all unmarked floats on free list */
5244 register struct float_block
*fblk
;
5245 struct float_block
**fprev
= &float_block
;
5246 register int lim
= float_block_index
;
5247 register int num_free
= 0, num_used
= 0;
5249 float_free_list
= 0;
5251 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5255 for (i
= 0; i
< lim
; i
++)
5256 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5259 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
5260 float_free_list
= &fblk
->floats
[i
];
5265 FLOAT_UNMARK (&fblk
->floats
[i
]);
5267 lim
= FLOAT_BLOCK_SIZE
;
5268 /* If this block contains only free floats and we have already
5269 seen more than two blocks worth of free floats then deallocate
5271 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5273 *fprev
= fblk
->next
;
5274 /* Unhook from the free list. */
5275 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
5276 lisp_align_free (fblk
);
5281 num_free
+= this_free
;
5282 fprev
= &fblk
->next
;
5285 total_floats
= num_used
;
5286 total_free_floats
= num_free
;
5289 /* Put all unmarked intervals on free list */
5291 register struct interval_block
*iblk
;
5292 struct interval_block
**iprev
= &interval_block
;
5293 register int lim
= interval_block_index
;
5294 register int num_free
= 0, num_used
= 0;
5296 interval_free_list
= 0;
5298 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5303 for (i
= 0; i
< lim
; i
++)
5305 if (!iblk
->intervals
[i
].gcmarkbit
)
5307 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5308 interval_free_list
= &iblk
->intervals
[i
];
5314 iblk
->intervals
[i
].gcmarkbit
= 0;
5317 lim
= INTERVAL_BLOCK_SIZE
;
5318 /* If this block contains only free intervals and we have already
5319 seen more than two blocks worth of free intervals then
5320 deallocate this block. */
5321 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5323 *iprev
= iblk
->next
;
5324 /* Unhook from the free list. */
5325 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5327 n_interval_blocks
--;
5331 num_free
+= this_free
;
5332 iprev
= &iblk
->next
;
5335 total_intervals
= num_used
;
5336 total_free_intervals
= num_free
;
5339 /* Put all unmarked symbols on free list */
5341 register struct symbol_block
*sblk
;
5342 struct symbol_block
**sprev
= &symbol_block
;
5343 register int lim
= symbol_block_index
;
5344 register int num_free
= 0, num_used
= 0;
5346 symbol_free_list
= NULL
;
5348 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5351 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5352 struct Lisp_Symbol
*end
= sym
+ lim
;
5354 for (; sym
< end
; ++sym
)
5356 /* Check if the symbol was created during loadup. In such a case
5357 it might be pointed to by pure bytecode which we don't trace,
5358 so we conservatively assume that it is live. */
5359 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5361 if (!sym
->gcmarkbit
&& !pure_p
)
5363 *(struct Lisp_Symbol
**) &sym
->value
= symbol_free_list
;
5364 symbol_free_list
= sym
;
5366 symbol_free_list
->function
= Vdead
;
5374 UNMARK_STRING (XSTRING (sym
->xname
));
5379 lim
= SYMBOL_BLOCK_SIZE
;
5380 /* If this block contains only free symbols and we have already
5381 seen more than two blocks worth of free symbols then deallocate
5383 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5385 *sprev
= sblk
->next
;
5386 /* Unhook from the free list. */
5387 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
5393 num_free
+= this_free
;
5394 sprev
= &sblk
->next
;
5397 total_symbols
= num_used
;
5398 total_free_symbols
= num_free
;
5401 /* Put all unmarked misc's on free list.
5402 For a marker, first unchain it from the buffer it points into. */
5404 register struct marker_block
*mblk
;
5405 struct marker_block
**mprev
= &marker_block
;
5406 register int lim
= marker_block_index
;
5407 register int num_free
= 0, num_used
= 0;
5409 marker_free_list
= 0;
5411 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5416 for (i
= 0; i
< lim
; i
++)
5418 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
5420 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
5421 unchain_marker (&mblk
->markers
[i
].u_marker
);
5422 /* Set the type of the freed object to Lisp_Misc_Free.
5423 We could leave the type alone, since nobody checks it,
5424 but this might catch bugs faster. */
5425 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5426 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5427 marker_free_list
= &mblk
->markers
[i
];
5433 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
5436 lim
= MARKER_BLOCK_SIZE
;
5437 /* If this block contains only free markers and we have already
5438 seen more than two blocks worth of free markers then deallocate
5440 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5442 *mprev
= mblk
->next
;
5443 /* Unhook from the free list. */
5444 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5450 num_free
+= this_free
;
5451 mprev
= &mblk
->next
;
5455 total_markers
= num_used
;
5456 total_free_markers
= num_free
;
5459 /* Free all unmarked buffers */
5461 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5464 if (!VECTOR_MARKED_P (buffer
))
5467 prev
->next
= buffer
->next
;
5469 all_buffers
= buffer
->next
;
5470 next
= buffer
->next
;
5476 VECTOR_UNMARK (buffer
);
5477 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
5478 prev
= buffer
, buffer
= buffer
->next
;
5482 /* Free all unmarked vectors */
5484 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
5485 total_vector_size
= 0;
5488 if (!VECTOR_MARKED_P (vector
))
5491 prev
->next
= vector
->next
;
5493 all_vectors
= vector
->next
;
5494 next
= vector
->next
;
5502 VECTOR_UNMARK (vector
);
5503 if (vector
->size
& PSEUDOVECTOR_FLAG
)
5504 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
5506 total_vector_size
+= vector
->size
;
5507 prev
= vector
, vector
= vector
->next
;
5511 #ifdef GC_CHECK_STRING_BYTES
5512 if (!noninteractive
)
5513 check_string_bytes (1);
5520 /* Debugging aids. */
5522 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
5523 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
5524 This may be helpful in debugging Emacs's memory usage.
5525 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
5530 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
5535 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
5536 doc
: /* Return a list of counters that measure how much consing there has been.
5537 Each of these counters increments for a certain kind of object.
5538 The counters wrap around from the largest positive integer to zero.
5539 Garbage collection does not decrease them.
5540 The elements of the value are as follows:
5541 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
5542 All are in units of 1 = one object consed
5543 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
5545 MISCS include overlays, markers, and some internal types.
5546 Frames, windows, buffers, and subprocesses count as vectors
5547 (but the contents of a buffer's text do not count here). */)
5550 Lisp_Object consed
[8];
5552 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
5553 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
5554 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
5555 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
5556 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
5557 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
5558 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
5559 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
5561 return Flist (8, consed
);
5564 int suppress_checking
;
5566 die (msg
, file
, line
)
5571 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
5576 /* Initialization */
5581 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
5583 pure_size
= PURESIZE
;
5584 pure_bytes_used
= 0;
5585 pure_bytes_used_before_overflow
= 0;
5587 /* Initialize the list of free aligned blocks. */
5590 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
5592 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
5596 ignore_warnings
= 1;
5597 #ifdef DOUG_LEA_MALLOC
5598 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
5599 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
5600 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
5610 malloc_hysteresis
= 32;
5612 malloc_hysteresis
= 0;
5615 spare_memory
= (char *) malloc (SPARE_MEMORY
);
5617 ignore_warnings
= 0;
5619 byte_stack_list
= 0;
5621 consing_since_gc
= 0;
5622 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
5623 #ifdef VIRT_ADDR_VARIES
5624 malloc_sbrk_unused
= 1<<22; /* A large number */
5625 malloc_sbrk_used
= 100000; /* as reasonable as any number */
5626 #endif /* VIRT_ADDR_VARIES */
5633 byte_stack_list
= 0;
5635 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
5636 setjmp_tested_p
= longjmps_done
= 0;
5639 Vgc_elapsed
= make_float (0.0);
5646 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
5647 doc
: /* *Number of bytes of consing between garbage collections.
5648 Garbage collection can happen automatically once this many bytes have been
5649 allocated since the last garbage collection. All data types count.
5651 Garbage collection happens automatically only when `eval' is called.
5653 By binding this temporarily to a large number, you can effectively
5654 prevent garbage collection during a part of the program. */);
5656 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
5657 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
5659 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
5660 doc
: /* Number of cons cells that have been consed so far. */);
5662 DEFVAR_INT ("floats-consed", &floats_consed
,
5663 doc
: /* Number of floats that have been consed so far. */);
5665 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
5666 doc
: /* Number of vector cells that have been consed so far. */);
5668 DEFVAR_INT ("symbols-consed", &symbols_consed
,
5669 doc
: /* Number of symbols that have been consed so far. */);
5671 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
5672 doc
: /* Number of string characters that have been consed so far. */);
5674 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
5675 doc
: /* Number of miscellaneous objects that have been consed so far. */);
5677 DEFVAR_INT ("intervals-consed", &intervals_consed
,
5678 doc
: /* Number of intervals that have been consed so far. */);
5680 DEFVAR_INT ("strings-consed", &strings_consed
,
5681 doc
: /* Number of strings that have been consed so far. */);
5683 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
5684 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
5685 This means that certain objects should be allocated in shared (pure) space. */);
5687 DEFVAR_INT ("undo-limit", &undo_limit
,
5688 doc
: /* Keep no more undo information once it exceeds this size.
5689 This limit is applied when garbage collection happens.
5690 The size is counted as the number of bytes occupied,
5691 which includes both saved text and other data. */);
5694 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
5695 doc
: /* Don't keep more than this much size of undo information.
5696 A command which pushes past this size is itself forgotten.
5697 This limit is applied when garbage collection happens.
5698 The size is counted as the number of bytes occupied,
5699 which includes both saved text and other data. */);
5700 undo_strong_limit
= 30000;
5702 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
5703 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
5704 garbage_collection_messages
= 0;
5706 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
5707 doc
: /* Hook run after garbage collection has finished. */);
5708 Vpost_gc_hook
= Qnil
;
5709 Qpost_gc_hook
= intern ("post-gc-hook");
5710 staticpro (&Qpost_gc_hook
);
5712 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
5713 doc
: /* Precomputed `signal' argument for memory-full error. */);
5714 /* We build this in advance because if we wait until we need it, we might
5715 not be able to allocate the memory to hold it. */
5718 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
5720 DEFVAR_LISP ("memory-full", &Vmemory_full
,
5721 doc
: /* Non-nil means we are handling a memory-full error. */);
5722 Vmemory_full
= Qnil
;
5724 staticpro (&Qgc_cons_threshold
);
5725 Qgc_cons_threshold
= intern ("gc-cons-threshold");
5727 staticpro (&Qchar_table_extra_slots
);
5728 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
5730 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
5731 doc
: /* Accumulated time elapsed in garbage collections.
5732 The time is in seconds as a floating point value. */);
5733 DEFVAR_INT ("gcs-done", &gcs_done
,
5734 doc
: /* Accumulated number of garbage collections done. */);
5739 defsubr (&Smake_byte_code
);
5740 defsubr (&Smake_list
);
5741 defsubr (&Smake_vector
);
5742 defsubr (&Smake_char_table
);
5743 defsubr (&Smake_string
);
5744 defsubr (&Smake_bool_vector
);
5745 defsubr (&Smake_symbol
);
5746 defsubr (&Smake_marker
);
5747 defsubr (&Spurecopy
);
5748 defsubr (&Sgarbage_collect
);
5749 defsubr (&Smemory_limit
);
5750 defsubr (&Smemory_use_counts
);
5752 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5753 defsubr (&Sgc_status
);
5757 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
5758 (do not change this comment) */