1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
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 3 of the License, or
10 (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>. */
22 #include <limits.h> /* For CHAR_BIT. */
31 #ifdef HAVE_GTK_AND_PTHREAD
35 /* This file is part of the core Lisp implementation, and thus must
36 deal with the real data structures. If the Lisp implementation is
37 replaced, this file likely will not be used. */
39 #undef HIDE_LISP_IMPLEMENTATION
42 #include "intervals.h"
48 #include "blockinput.h"
49 #include "character.h"
50 #include "syssignal.h"
51 #include "termhooks.h" /* For struct terminal. */
54 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
55 memory. Can do this only if using gmalloc.c. */
57 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
58 #undef GC_MALLOC_CHECK
63 extern POINTER_TYPE
*sbrk ();
72 #ifdef DOUG_LEA_MALLOC
75 /* malloc.h #defines this as size_t, at least in glibc2. */
76 #ifndef __malloc_size_t
77 #define __malloc_size_t int
80 /* Specify maximum number of areas to mmap. It would be nice to use a
81 value that explicitly means "no limit". */
83 #define MMAP_MAX_AREAS 100000000
85 #else /* not DOUG_LEA_MALLOC */
87 /* The following come from gmalloc.c. */
89 #define __malloc_size_t size_t
90 extern __malloc_size_t _bytes_used
;
91 extern __malloc_size_t __malloc_extra_blocks
;
93 #endif /* not DOUG_LEA_MALLOC */
95 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
97 /* When GTK uses the file chooser dialog, different backends can be loaded
98 dynamically. One such a backend is the Gnome VFS backend that gets loaded
99 if you run Gnome. That backend creates several threads and also allocates
102 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
103 functions below are called from malloc, there is a chance that one
104 of these threads preempts the Emacs main thread and the hook variables
105 end up in an inconsistent state. So we have a mutex to prevent that (note
106 that the backend handles concurrent access to malloc within its own threads
107 but Emacs code running in the main thread is not included in that control).
109 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
110 happens in one of the backend threads we will have two threads that tries
111 to run Emacs code at once, and the code is not prepared for that.
112 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
114 static pthread_mutex_t alloc_mutex
;
116 #define BLOCK_INPUT_ALLOC \
119 if (pthread_equal (pthread_self (), main_thread)) \
121 pthread_mutex_lock (&alloc_mutex); \
124 #define UNBLOCK_INPUT_ALLOC \
127 pthread_mutex_unlock (&alloc_mutex); \
128 if (pthread_equal (pthread_self (), main_thread)) \
133 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
135 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
136 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
138 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
140 /* Value of _bytes_used, when spare_memory was freed. */
142 static __malloc_size_t bytes_used_when_full
;
144 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
145 to a struct Lisp_String. */
147 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
148 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
149 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
151 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
152 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
153 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
155 /* Value is the number of bytes/chars of S, a pointer to a struct
156 Lisp_String. This must be used instead of STRING_BYTES (S) or
157 S->size during GC, because S->size contains the mark bit for
160 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
161 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
163 /* Global variables. */
164 struct emacs_globals globals
;
166 /* Number of bytes of consing done since the last gc. */
168 int consing_since_gc
;
170 /* Similar minimum, computed from Vgc_cons_percentage. */
172 EMACS_INT gc_relative_threshold
;
174 /* Minimum number of bytes of consing since GC before next GC,
175 when memory is full. */
177 EMACS_INT memory_full_cons_threshold
;
179 /* Nonzero during GC. */
183 /* Nonzero means abort if try to GC.
184 This is for code which is written on the assumption that
185 no GC will happen, so as to verify that assumption. */
189 /* Number of live and free conses etc. */
191 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
192 static int total_free_conses
, total_free_markers
, total_free_symbols
;
193 static int total_free_floats
, total_floats
;
195 /* Points to memory space allocated as "spare", to be freed if we run
196 out of memory. We keep one large block, four cons-blocks, and
197 two string blocks. */
199 static char *spare_memory
[7];
201 /* Amount of spare memory to keep in large reserve block. */
203 #define SPARE_MEMORY (1 << 14)
205 /* Number of extra blocks malloc should get when it needs more core. */
207 static int malloc_hysteresis
;
209 /* Initialize it to a nonzero value to force it into data space
210 (rather than bss space). That way unexec will remap it into text
211 space (pure), on some systems. We have not implemented the
212 remapping on more recent systems because this is less important
213 nowadays than in the days of small memories and timesharing. */
215 EMACS_INT pure
[(PURESIZE
+ sizeof (EMACS_INT
) - 1) / sizeof (EMACS_INT
)] = {1,};
216 #define PUREBEG (char *) pure
218 /* Pointer to the pure area, and its size. */
220 static char *purebeg
;
221 static size_t pure_size
;
223 /* Number of bytes of pure storage used before pure storage overflowed.
224 If this is non-zero, this implies that an overflow occurred. */
226 static size_t pure_bytes_used_before_overflow
;
228 /* Value is non-zero if P points into pure space. */
230 #define PURE_POINTER_P(P) \
231 (((PNTR_COMPARISON_TYPE) (P) \
232 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
233 && ((PNTR_COMPARISON_TYPE) (P) \
234 >= (PNTR_COMPARISON_TYPE) purebeg))
236 /* Index in pure at which next pure Lisp object will be allocated.. */
238 static EMACS_INT pure_bytes_used_lisp
;
240 /* Number of bytes allocated for non-Lisp objects in pure storage. */
242 static EMACS_INT pure_bytes_used_non_lisp
;
244 /* If nonzero, this is a warning delivered by malloc and not yet
247 const char *pending_malloc_warning
;
249 /* Maximum amount of C stack to save when a GC happens. */
251 #ifndef MAX_SAVE_STACK
252 #define MAX_SAVE_STACK 16000
255 /* Buffer in which we save a copy of the C stack at each GC. */
257 static char *stack_copy
;
258 static int stack_copy_size
;
260 /* Non-zero means ignore malloc warnings. Set during initialization.
261 Currently not used. */
263 static int ignore_warnings
;
265 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
267 /* Hook run after GC has finished. */
269 Lisp_Object Qpost_gc_hook
;
271 static void mark_buffer (Lisp_Object
);
272 static void mark_terminals (void);
273 extern void mark_kboards (void);
274 extern void mark_ttys (void);
275 extern void mark_backtrace (void);
276 static void gc_sweep (void);
277 static void mark_glyph_matrix (struct glyph_matrix
*);
278 static void mark_face_cache (struct face_cache
*);
280 #ifdef HAVE_WINDOW_SYSTEM
281 extern void mark_fringe_data (void);
282 #endif /* HAVE_WINDOW_SYSTEM */
284 static struct Lisp_String
*allocate_string (void);
285 static void compact_small_strings (void);
286 static void free_large_strings (void);
287 static void sweep_strings (void);
289 extern int message_enable_multibyte
;
291 /* When scanning the C stack for live Lisp objects, Emacs keeps track
292 of what memory allocated via lisp_malloc is intended for what
293 purpose. This enumeration specifies the type of memory. */
304 /* We used to keep separate mem_types for subtypes of vectors such as
305 process, hash_table, frame, terminal, and window, but we never made
306 use of the distinction, so it only caused source-code complexity
307 and runtime slowdown. Minor but pointless. */
311 static POINTER_TYPE
*lisp_align_malloc (size_t, enum mem_type
);
312 static POINTER_TYPE
*lisp_malloc (size_t, enum mem_type
);
315 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
317 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
318 #include <stdio.h> /* For fprintf. */
321 /* A unique object in pure space used to make some Lisp objects
322 on free lists recognizable in O(1). */
324 static Lisp_Object Vdead
;
326 #ifdef GC_MALLOC_CHECK
328 enum mem_type allocated_mem_type
;
329 static int dont_register_blocks
;
331 #endif /* GC_MALLOC_CHECK */
333 /* A node in the red-black tree describing allocated memory containing
334 Lisp data. Each such block is recorded with its start and end
335 address when it is allocated, and removed from the tree when it
338 A red-black tree is a balanced binary tree with the following
341 1. Every node is either red or black.
342 2. Every leaf is black.
343 3. If a node is red, then both of its children are black.
344 4. Every simple path from a node to a descendant leaf contains
345 the same number of black nodes.
346 5. The root is always black.
348 When nodes are inserted into the tree, or deleted from the tree,
349 the tree is "fixed" so that these properties are always true.
351 A red-black tree with N internal nodes has height at most 2
352 log(N+1). Searches, insertions and deletions are done in O(log N).
353 Please see a text book about data structures for a detailed
354 description of red-black trees. Any book worth its salt should
359 /* Children of this node. These pointers are never NULL. When there
360 is no child, the value is MEM_NIL, which points to a dummy node. */
361 struct mem_node
*left
, *right
;
363 /* The parent of this node. In the root node, this is NULL. */
364 struct mem_node
*parent
;
366 /* Start and end of allocated region. */
370 enum {MEM_BLACK
, MEM_RED
} color
;
376 /* Base address of stack. Set in main. */
378 Lisp_Object
*stack_base
;
380 /* Root of the tree describing allocated Lisp memory. */
382 static struct mem_node
*mem_root
;
384 /* Lowest and highest known address in the heap. */
386 static void *min_heap_address
, *max_heap_address
;
388 /* Sentinel node of the tree. */
390 static struct mem_node mem_z
;
391 #define MEM_NIL &mem_z
393 static struct Lisp_Vector
*allocate_vectorlike (EMACS_INT
);
394 static void lisp_free (POINTER_TYPE
*);
395 static void mark_stack (void);
396 static int live_vector_p (struct mem_node
*, void *);
397 static int live_buffer_p (struct mem_node
*, void *);
398 static int live_string_p (struct mem_node
*, void *);
399 static int live_cons_p (struct mem_node
*, void *);
400 static int live_symbol_p (struct mem_node
*, void *);
401 static int live_float_p (struct mem_node
*, void *);
402 static int live_misc_p (struct mem_node
*, void *);
403 static void mark_maybe_object (Lisp_Object
);
404 static void mark_memory (void *, void *, int);
405 static void mem_init (void);
406 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
407 static void mem_insert_fixup (struct mem_node
*);
408 static void mem_rotate_left (struct mem_node
*);
409 static void mem_rotate_right (struct mem_node
*);
410 static void mem_delete (struct mem_node
*);
411 static void mem_delete_fixup (struct mem_node
*);
412 static INLINE
struct mem_node
*mem_find (void *);
415 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
416 static void check_gcpros (void);
419 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
421 /* Recording what needs to be marked for gc. */
423 struct gcpro
*gcprolist
;
425 /* Addresses of staticpro'd variables. Initialize it to a nonzero
426 value; otherwise some compilers put it into BSS. */
428 #define NSTATICS 0x640
429 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
431 /* Index of next unused slot in staticvec. */
433 static int staticidx
= 0;
435 static POINTER_TYPE
*pure_alloc (size_t, int);
438 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
439 ALIGNMENT must be a power of 2. */
441 #define ALIGN(ptr, ALIGNMENT) \
442 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
443 & ~((ALIGNMENT) - 1)))
447 /************************************************************************
449 ************************************************************************/
451 /* Function malloc calls this if it finds we are near exhausting storage. */
454 malloc_warning (const char *str
)
456 pending_malloc_warning
= str
;
460 /* Display an already-pending malloc warning. */
463 display_malloc_warning (void)
465 call3 (intern ("display-warning"),
467 build_string (pending_malloc_warning
),
468 intern ("emergency"));
469 pending_malloc_warning
= 0;
473 #ifdef DOUG_LEA_MALLOC
474 # define BYTES_USED (mallinfo ().uordblks)
476 # define BYTES_USED _bytes_used
479 /* Called if we can't allocate relocatable space for a buffer. */
482 buffer_memory_full (void)
484 /* If buffers use the relocating allocator, no need to free
485 spare_memory, because we may have plenty of malloc space left
486 that we could get, and if we don't, the malloc that fails will
487 itself cause spare_memory to be freed. If buffers don't use the
488 relocating allocator, treat this like any other failing
495 /* This used to call error, but if we've run out of memory, we could
496 get infinite recursion trying to build the string. */
497 xsignal (Qnil
, Vmemory_signal_data
);
501 #ifdef XMALLOC_OVERRUN_CHECK
503 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
504 and a 16 byte trailer around each block.
506 The header consists of 12 fixed bytes + a 4 byte integer contaning the
507 original block size, while the trailer consists of 16 fixed bytes.
509 The header is used to detect whether this block has been allocated
510 through these functions -- as it seems that some low-level libc
511 functions may bypass the malloc hooks.
515 #define XMALLOC_OVERRUN_CHECK_SIZE 16
517 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
518 { 0x9a, 0x9b, 0xae, 0xaf,
519 0xbf, 0xbe, 0xce, 0xcf,
520 0xea, 0xeb, 0xec, 0xed };
522 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
523 { 0xaa, 0xab, 0xac, 0xad,
524 0xba, 0xbb, 0xbc, 0xbd,
525 0xca, 0xcb, 0xcc, 0xcd,
526 0xda, 0xdb, 0xdc, 0xdd };
528 /* Macros to insert and extract the block size in the header. */
530 #define XMALLOC_PUT_SIZE(ptr, size) \
531 (ptr[-1] = (size & 0xff), \
532 ptr[-2] = ((size >> 8) & 0xff), \
533 ptr[-3] = ((size >> 16) & 0xff), \
534 ptr[-4] = ((size >> 24) & 0xff))
536 #define XMALLOC_GET_SIZE(ptr) \
537 (size_t)((unsigned)(ptr[-1]) | \
538 ((unsigned)(ptr[-2]) << 8) | \
539 ((unsigned)(ptr[-3]) << 16) | \
540 ((unsigned)(ptr[-4]) << 24))
543 /* The call depth in overrun_check functions. For example, this might happen:
545 overrun_check_malloc()
546 -> malloc -> (via hook)_-> emacs_blocked_malloc
547 -> overrun_check_malloc
548 call malloc (hooks are NULL, so real malloc is called).
549 malloc returns 10000.
550 add overhead, return 10016.
551 <- (back in overrun_check_malloc)
552 add overhead again, return 10032
553 xmalloc returns 10032.
558 overrun_check_free(10032)
560 free(10016) <- crash, because 10000 is the original pointer. */
562 static int check_depth
;
564 /* Like malloc, but wraps allocated block with header and trailer. */
567 overrun_check_malloc (size
)
570 register unsigned char *val
;
571 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
573 val
= (unsigned char *) malloc (size
+ overhead
);
574 if (val
&& check_depth
== 1)
576 memcpy (val
, xmalloc_overrun_check_header
,
577 XMALLOC_OVERRUN_CHECK_SIZE
- 4);
578 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
579 XMALLOC_PUT_SIZE(val
, size
);
580 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
581 XMALLOC_OVERRUN_CHECK_SIZE
);
584 return (POINTER_TYPE
*)val
;
588 /* Like realloc, but checks old block for overrun, and wraps new block
589 with header and trailer. */
592 overrun_check_realloc (block
, size
)
596 register unsigned char *val
= (unsigned char *)block
;
597 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
601 && memcmp (xmalloc_overrun_check_header
,
602 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
603 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
605 size_t osize
= XMALLOC_GET_SIZE (val
);
606 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
607 XMALLOC_OVERRUN_CHECK_SIZE
))
609 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
610 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
611 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
614 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
616 if (val
&& check_depth
== 1)
618 memcpy (val
, xmalloc_overrun_check_header
,
619 XMALLOC_OVERRUN_CHECK_SIZE
- 4);
620 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
621 XMALLOC_PUT_SIZE(val
, size
);
622 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
623 XMALLOC_OVERRUN_CHECK_SIZE
);
626 return (POINTER_TYPE
*)val
;
629 /* Like free, but checks block for overrun. */
632 overrun_check_free (block
)
635 unsigned char *val
= (unsigned char *)block
;
640 && memcmp (xmalloc_overrun_check_header
,
641 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
642 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
644 size_t osize
= XMALLOC_GET_SIZE (val
);
645 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
646 XMALLOC_OVERRUN_CHECK_SIZE
))
648 #ifdef XMALLOC_CLEAR_FREE_MEMORY
649 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
650 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
652 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
653 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
654 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
665 #define malloc overrun_check_malloc
666 #define realloc overrun_check_realloc
667 #define free overrun_check_free
671 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
672 there's no need to block input around malloc. */
673 #define MALLOC_BLOCK_INPUT ((void)0)
674 #define MALLOC_UNBLOCK_INPUT ((void)0)
676 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
677 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
680 /* Like malloc but check for no memory and block interrupt input.. */
683 xmalloc (size_t size
)
685 register POINTER_TYPE
*val
;
688 val
= (POINTER_TYPE
*) malloc (size
);
689 MALLOC_UNBLOCK_INPUT
;
697 /* Like realloc but check for no memory and block interrupt input.. */
700 xrealloc (POINTER_TYPE
*block
, size_t size
)
702 register POINTER_TYPE
*val
;
705 /* We must call malloc explicitly when BLOCK is 0, since some
706 reallocs don't do this. */
708 val
= (POINTER_TYPE
*) malloc (size
);
710 val
= (POINTER_TYPE
*) realloc (block
, size
);
711 MALLOC_UNBLOCK_INPUT
;
713 if (!val
&& size
) memory_full ();
718 /* Like free but block interrupt input. */
721 xfree (POINTER_TYPE
*block
)
727 MALLOC_UNBLOCK_INPUT
;
728 /* We don't call refill_memory_reserve here
729 because that duplicates doing so in emacs_blocked_free
730 and the criterion should go there. */
734 /* Like strdup, but uses xmalloc. */
737 xstrdup (const char *s
)
739 size_t len
= strlen (s
) + 1;
740 char *p
= (char *) xmalloc (len
);
746 /* Unwind for SAFE_ALLOCA */
749 safe_alloca_unwind (Lisp_Object arg
)
751 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
761 /* Like malloc but used for allocating Lisp data. NBYTES is the
762 number of bytes to allocate, TYPE describes the intended use of the
763 allcated memory block (for strings, for conses, ...). */
766 static void *lisp_malloc_loser
;
769 static POINTER_TYPE
*
770 lisp_malloc (size_t nbytes
, enum mem_type type
)
776 #ifdef GC_MALLOC_CHECK
777 allocated_mem_type
= type
;
780 val
= (void *) malloc (nbytes
);
783 /* If the memory just allocated cannot be addressed thru a Lisp
784 object's pointer, and it needs to be,
785 that's equivalent to running out of memory. */
786 if (val
&& type
!= MEM_TYPE_NON_LISP
)
789 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
790 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
792 lisp_malloc_loser
= val
;
799 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
800 if (val
&& type
!= MEM_TYPE_NON_LISP
)
801 mem_insert (val
, (char *) val
+ nbytes
, type
);
804 MALLOC_UNBLOCK_INPUT
;
810 /* Free BLOCK. This must be called to free memory allocated with a
811 call to lisp_malloc. */
814 lisp_free (POINTER_TYPE
*block
)
818 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
819 mem_delete (mem_find (block
));
821 MALLOC_UNBLOCK_INPUT
;
824 /* Allocation of aligned blocks of memory to store Lisp data. */
825 /* The entry point is lisp_align_malloc which returns blocks of at most */
826 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
828 /* Use posix_memalloc if the system has it and we're using the system's
829 malloc (because our gmalloc.c routines don't have posix_memalign although
830 its memalloc could be used). */
831 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
832 #define USE_POSIX_MEMALIGN 1
835 /* BLOCK_ALIGN has to be a power of 2. */
836 #define BLOCK_ALIGN (1 << 10)
838 /* Padding to leave at the end of a malloc'd block. This is to give
839 malloc a chance to minimize the amount of memory wasted to alignment.
840 It should be tuned to the particular malloc library used.
841 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
842 posix_memalign on the other hand would ideally prefer a value of 4
843 because otherwise, there's 1020 bytes wasted between each ablocks.
844 In Emacs, testing shows that those 1020 can most of the time be
845 efficiently used by malloc to place other objects, so a value of 0 can
846 still preferable unless you have a lot of aligned blocks and virtually
848 #define BLOCK_PADDING 0
849 #define BLOCK_BYTES \
850 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
852 /* Internal data structures and constants. */
854 #define ABLOCKS_SIZE 16
856 /* An aligned block of memory. */
861 char payload
[BLOCK_BYTES
];
862 struct ablock
*next_free
;
864 /* `abase' is the aligned base of the ablocks. */
865 /* It is overloaded to hold the virtual `busy' field that counts
866 the number of used ablock in the parent ablocks.
867 The first ablock has the `busy' field, the others have the `abase'
868 field. To tell the difference, we assume that pointers will have
869 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
870 is used to tell whether the real base of the parent ablocks is `abase'
871 (if not, the word before the first ablock holds a pointer to the
873 struct ablocks
*abase
;
874 /* The padding of all but the last ablock is unused. The padding of
875 the last ablock in an ablocks is not allocated. */
877 char padding
[BLOCK_PADDING
];
881 /* A bunch of consecutive aligned blocks. */
884 struct ablock blocks
[ABLOCKS_SIZE
];
887 /* Size of the block requested from malloc or memalign. */
888 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
890 #define ABLOCK_ABASE(block) \
891 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
892 ? (struct ablocks *)(block) \
895 /* Virtual `busy' field. */
896 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
898 /* Pointer to the (not necessarily aligned) malloc block. */
899 #ifdef USE_POSIX_MEMALIGN
900 #define ABLOCKS_BASE(abase) (abase)
902 #define ABLOCKS_BASE(abase) \
903 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
906 /* The list of free ablock. */
907 static struct ablock
*free_ablock
;
909 /* Allocate an aligned block of nbytes.
910 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
911 smaller or equal to BLOCK_BYTES. */
912 static POINTER_TYPE
*
913 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
916 struct ablocks
*abase
;
918 eassert (nbytes
<= BLOCK_BYTES
);
922 #ifdef GC_MALLOC_CHECK
923 allocated_mem_type
= type
;
929 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
931 #ifdef DOUG_LEA_MALLOC
932 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
933 because mapped region contents are not preserved in
935 mallopt (M_MMAP_MAX
, 0);
938 #ifdef USE_POSIX_MEMALIGN
940 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
946 base
= malloc (ABLOCKS_BYTES
);
947 abase
= ALIGN (base
, BLOCK_ALIGN
);
952 MALLOC_UNBLOCK_INPUT
;
956 aligned
= (base
== abase
);
958 ((void**)abase
)[-1] = base
;
960 #ifdef DOUG_LEA_MALLOC
961 /* Back to a reasonable maximum of mmap'ed areas. */
962 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
966 /* If the memory just allocated cannot be addressed thru a Lisp
967 object's pointer, and it needs to be, that's equivalent to
968 running out of memory. */
969 if (type
!= MEM_TYPE_NON_LISP
)
972 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
974 if ((char *) XCONS (tem
) != end
)
976 lisp_malloc_loser
= base
;
978 MALLOC_UNBLOCK_INPUT
;
984 /* Initialize the blocks and put them on the free list.
985 Is `base' was not properly aligned, we can't use the last block. */
986 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
988 abase
->blocks
[i
].abase
= abase
;
989 abase
->blocks
[i
].x
.next_free
= free_ablock
;
990 free_ablock
= &abase
->blocks
[i
];
992 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
994 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
995 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
996 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
997 eassert (ABLOCKS_BASE (abase
) == base
);
998 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1001 abase
= ABLOCK_ABASE (free_ablock
);
1002 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1004 free_ablock
= free_ablock
->x
.next_free
;
1006 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1007 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1008 mem_insert (val
, (char *) val
+ nbytes
, type
);
1011 MALLOC_UNBLOCK_INPUT
;
1015 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1020 lisp_align_free (POINTER_TYPE
*block
)
1022 struct ablock
*ablock
= block
;
1023 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1026 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1027 mem_delete (mem_find (block
));
1029 /* Put on free list. */
1030 ablock
->x
.next_free
= free_ablock
;
1031 free_ablock
= ablock
;
1032 /* Update busy count. */
1033 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1035 if (2 > (long) ABLOCKS_BUSY (abase
))
1036 { /* All the blocks are free. */
1037 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1038 struct ablock
**tem
= &free_ablock
;
1039 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1043 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1046 *tem
= (*tem
)->x
.next_free
;
1049 tem
= &(*tem
)->x
.next_free
;
1051 eassert ((aligned
& 1) == aligned
);
1052 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1053 #ifdef USE_POSIX_MEMALIGN
1054 eassert ((unsigned long)ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1056 free (ABLOCKS_BASE (abase
));
1058 MALLOC_UNBLOCK_INPUT
;
1061 /* Return a new buffer structure allocated from the heap with
1062 a call to lisp_malloc. */
1065 allocate_buffer (void)
1068 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1070 b
->size
= sizeof (struct buffer
) / sizeof (EMACS_INT
);
1071 XSETPVECTYPE (b
, PVEC_BUFFER
);
1076 #ifndef SYSTEM_MALLOC
1078 /* Arranging to disable input signals while we're in malloc.
1080 This only works with GNU malloc. To help out systems which can't
1081 use GNU malloc, all the calls to malloc, realloc, and free
1082 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1083 pair; unfortunately, we have no idea what C library functions
1084 might call malloc, so we can't really protect them unless you're
1085 using GNU malloc. Fortunately, most of the major operating systems
1086 can use GNU malloc. */
1089 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1090 there's no need to block input around malloc. */
1092 #ifndef DOUG_LEA_MALLOC
1093 extern void * (*__malloc_hook
) (size_t, const void *);
1094 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1095 extern void (*__free_hook
) (void *, const void *);
1096 /* Else declared in malloc.h, perhaps with an extra arg. */
1097 #endif /* DOUG_LEA_MALLOC */
1098 static void * (*old_malloc_hook
) (size_t, const void *);
1099 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1100 static void (*old_free_hook
) (void*, const void*);
1102 static __malloc_size_t bytes_used_when_reconsidered
;
1104 /* This function is used as the hook for free to call. */
1107 emacs_blocked_free (void *ptr
, const void *ptr2
)
1111 #ifdef GC_MALLOC_CHECK
1117 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1120 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1125 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1129 #endif /* GC_MALLOC_CHECK */
1131 __free_hook
= old_free_hook
;
1134 /* If we released our reserve (due to running out of memory),
1135 and we have a fair amount free once again,
1136 try to set aside another reserve in case we run out once more. */
1137 if (! NILP (Vmemory_full
)
1138 /* Verify there is enough space that even with the malloc
1139 hysteresis this call won't run out again.
1140 The code here is correct as long as SPARE_MEMORY
1141 is substantially larger than the block size malloc uses. */
1142 && (bytes_used_when_full
1143 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1144 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1145 refill_memory_reserve ();
1147 __free_hook
= emacs_blocked_free
;
1148 UNBLOCK_INPUT_ALLOC
;
1152 /* This function is the malloc hook that Emacs uses. */
1155 emacs_blocked_malloc (size_t size
, const void *ptr
)
1160 __malloc_hook
= old_malloc_hook
;
1161 #ifdef DOUG_LEA_MALLOC
1162 /* Segfaults on my system. --lorentey */
1163 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1165 __malloc_extra_blocks
= malloc_hysteresis
;
1168 value
= (void *) malloc (size
);
1170 #ifdef GC_MALLOC_CHECK
1172 struct mem_node
*m
= mem_find (value
);
1175 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1177 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1178 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1183 if (!dont_register_blocks
)
1185 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1186 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1189 #endif /* GC_MALLOC_CHECK */
1191 __malloc_hook
= emacs_blocked_malloc
;
1192 UNBLOCK_INPUT_ALLOC
;
1194 /* fprintf (stderr, "%p malloc\n", value); */
1199 /* This function is the realloc hook that Emacs uses. */
1202 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1207 __realloc_hook
= old_realloc_hook
;
1209 #ifdef GC_MALLOC_CHECK
1212 struct mem_node
*m
= mem_find (ptr
);
1213 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1216 "Realloc of %p which wasn't allocated with malloc\n",
1224 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1226 /* Prevent malloc from registering blocks. */
1227 dont_register_blocks
= 1;
1228 #endif /* GC_MALLOC_CHECK */
1230 value
= (void *) realloc (ptr
, size
);
1232 #ifdef GC_MALLOC_CHECK
1233 dont_register_blocks
= 0;
1236 struct mem_node
*m
= mem_find (value
);
1239 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1243 /* Can't handle zero size regions in the red-black tree. */
1244 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1247 /* fprintf (stderr, "%p <- realloc\n", value); */
1248 #endif /* GC_MALLOC_CHECK */
1250 __realloc_hook
= emacs_blocked_realloc
;
1251 UNBLOCK_INPUT_ALLOC
;
1257 #ifdef HAVE_GTK_AND_PTHREAD
1258 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1259 normal malloc. Some thread implementations need this as they call
1260 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1261 calls malloc because it is the first call, and we have an endless loop. */
1264 reset_malloc_hooks ()
1266 __free_hook
= old_free_hook
;
1267 __malloc_hook
= old_malloc_hook
;
1268 __realloc_hook
= old_realloc_hook
;
1270 #endif /* HAVE_GTK_AND_PTHREAD */
1273 /* Called from main to set up malloc to use our hooks. */
1276 uninterrupt_malloc (void)
1278 #ifdef HAVE_GTK_AND_PTHREAD
1279 #ifdef DOUG_LEA_MALLOC
1280 pthread_mutexattr_t attr
;
1282 /* GLIBC has a faster way to do this, but lets keep it portable.
1283 This is according to the Single UNIX Specification. */
1284 pthread_mutexattr_init (&attr
);
1285 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1286 pthread_mutex_init (&alloc_mutex
, &attr
);
1287 #else /* !DOUG_LEA_MALLOC */
1288 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1289 and the bundled gmalloc.c doesn't require it. */
1290 pthread_mutex_init (&alloc_mutex
, NULL
);
1291 #endif /* !DOUG_LEA_MALLOC */
1292 #endif /* HAVE_GTK_AND_PTHREAD */
1294 if (__free_hook
!= emacs_blocked_free
)
1295 old_free_hook
= __free_hook
;
1296 __free_hook
= emacs_blocked_free
;
1298 if (__malloc_hook
!= emacs_blocked_malloc
)
1299 old_malloc_hook
= __malloc_hook
;
1300 __malloc_hook
= emacs_blocked_malloc
;
1302 if (__realloc_hook
!= emacs_blocked_realloc
)
1303 old_realloc_hook
= __realloc_hook
;
1304 __realloc_hook
= emacs_blocked_realloc
;
1307 #endif /* not SYNC_INPUT */
1308 #endif /* not SYSTEM_MALLOC */
1312 /***********************************************************************
1314 ***********************************************************************/
1316 /* Number of intervals allocated in an interval_block structure.
1317 The 1020 is 1024 minus malloc overhead. */
1319 #define INTERVAL_BLOCK_SIZE \
1320 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1322 /* Intervals are allocated in chunks in form of an interval_block
1325 struct interval_block
1327 /* Place `intervals' first, to preserve alignment. */
1328 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1329 struct interval_block
*next
;
1332 /* Current interval block. Its `next' pointer points to older
1335 static struct interval_block
*interval_block
;
1337 /* Index in interval_block above of the next unused interval
1340 static int interval_block_index
;
1342 /* Number of free and live intervals. */
1344 static int total_free_intervals
, total_intervals
;
1346 /* List of free intervals. */
1348 INTERVAL interval_free_list
;
1350 /* Total number of interval blocks now in use. */
1352 static int n_interval_blocks
;
1355 /* Initialize interval allocation. */
1358 init_intervals (void)
1360 interval_block
= NULL
;
1361 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1362 interval_free_list
= 0;
1363 n_interval_blocks
= 0;
1367 /* Return a new interval. */
1370 make_interval (void)
1374 /* eassert (!handling_signal); */
1378 if (interval_free_list
)
1380 val
= interval_free_list
;
1381 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1385 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1387 register struct interval_block
*newi
;
1389 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1392 newi
->next
= interval_block
;
1393 interval_block
= newi
;
1394 interval_block_index
= 0;
1395 n_interval_blocks
++;
1397 val
= &interval_block
->intervals
[interval_block_index
++];
1400 MALLOC_UNBLOCK_INPUT
;
1402 consing_since_gc
+= sizeof (struct interval
);
1404 RESET_INTERVAL (val
);
1410 /* Mark Lisp objects in interval I. */
1413 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1415 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1417 mark_object (i
->plist
);
1421 /* Mark the interval tree rooted in TREE. Don't call this directly;
1422 use the macro MARK_INTERVAL_TREE instead. */
1425 mark_interval_tree (register INTERVAL tree
)
1427 /* No need to test if this tree has been marked already; this
1428 function is always called through the MARK_INTERVAL_TREE macro,
1429 which takes care of that. */
1431 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1435 /* Mark the interval tree rooted in I. */
1437 #define MARK_INTERVAL_TREE(i) \
1439 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1440 mark_interval_tree (i); \
1444 #define UNMARK_BALANCE_INTERVALS(i) \
1446 if (! NULL_INTERVAL_P (i)) \
1447 (i) = balance_intervals (i); \
1451 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1452 can't create number objects in macros. */
1455 make_number (EMACS_INT n
)
1459 obj
.s
.type
= Lisp_Int
;
1464 /***********************************************************************
1466 ***********************************************************************/
1468 /* Lisp_Strings are allocated in string_block structures. When a new
1469 string_block is allocated, all the Lisp_Strings it contains are
1470 added to a free-list string_free_list. When a new Lisp_String is
1471 needed, it is taken from that list. During the sweep phase of GC,
1472 string_blocks that are entirely free are freed, except two which
1475 String data is allocated from sblock structures. Strings larger
1476 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1477 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1479 Sblocks consist internally of sdata structures, one for each
1480 Lisp_String. The sdata structure points to the Lisp_String it
1481 belongs to. The Lisp_String points back to the `u.data' member of
1482 its sdata structure.
1484 When a Lisp_String is freed during GC, it is put back on
1485 string_free_list, and its `data' member and its sdata's `string'
1486 pointer is set to null. The size of the string is recorded in the
1487 `u.nbytes' member of the sdata. So, sdata structures that are no
1488 longer used, can be easily recognized, and it's easy to compact the
1489 sblocks of small strings which we do in compact_small_strings. */
1491 /* Size in bytes of an sblock structure used for small strings. This
1492 is 8192 minus malloc overhead. */
1494 #define SBLOCK_SIZE 8188
1496 /* Strings larger than this are considered large strings. String data
1497 for large strings is allocated from individual sblocks. */
1499 #define LARGE_STRING_BYTES 1024
1501 /* Structure describing string memory sub-allocated from an sblock.
1502 This is where the contents of Lisp strings are stored. */
1506 /* Back-pointer to the string this sdata belongs to. If null, this
1507 structure is free, and the NBYTES member of the union below
1508 contains the string's byte size (the same value that STRING_BYTES
1509 would return if STRING were non-null). If non-null, STRING_BYTES
1510 (STRING) is the size of the data, and DATA contains the string's
1512 struct Lisp_String
*string
;
1514 #ifdef GC_CHECK_STRING_BYTES
1517 unsigned char data
[1];
1519 #define SDATA_NBYTES(S) (S)->nbytes
1520 #define SDATA_DATA(S) (S)->data
1522 #else /* not GC_CHECK_STRING_BYTES */
1526 /* When STRING in non-null. */
1527 unsigned char data
[1];
1529 /* When STRING is null. */
1534 #define SDATA_NBYTES(S) (S)->u.nbytes
1535 #define SDATA_DATA(S) (S)->u.data
1537 #endif /* not GC_CHECK_STRING_BYTES */
1541 /* Structure describing a block of memory which is sub-allocated to
1542 obtain string data memory for strings. Blocks for small strings
1543 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1544 as large as needed. */
1549 struct sblock
*next
;
1551 /* Pointer to the next free sdata block. This points past the end
1552 of the sblock if there isn't any space left in this block. */
1553 struct sdata
*next_free
;
1555 /* Start of data. */
1556 struct sdata first_data
;
1559 /* Number of Lisp strings in a string_block structure. The 1020 is
1560 1024 minus malloc overhead. */
1562 #define STRING_BLOCK_SIZE \
1563 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1565 /* Structure describing a block from which Lisp_String structures
1570 /* Place `strings' first, to preserve alignment. */
1571 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1572 struct string_block
*next
;
1575 /* Head and tail of the list of sblock structures holding Lisp string
1576 data. We always allocate from current_sblock. The NEXT pointers
1577 in the sblock structures go from oldest_sblock to current_sblock. */
1579 static struct sblock
*oldest_sblock
, *current_sblock
;
1581 /* List of sblocks for large strings. */
1583 static struct sblock
*large_sblocks
;
1585 /* List of string_block structures, and how many there are. */
1587 static struct string_block
*string_blocks
;
1588 static int n_string_blocks
;
1590 /* Free-list of Lisp_Strings. */
1592 static struct Lisp_String
*string_free_list
;
1594 /* Number of live and free Lisp_Strings. */
1596 static int total_strings
, total_free_strings
;
1598 /* Number of bytes used by live strings. */
1600 static EMACS_INT total_string_size
;
1602 /* Given a pointer to a Lisp_String S which is on the free-list
1603 string_free_list, return a pointer to its successor in the
1606 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1608 /* Return a pointer to the sdata structure belonging to Lisp string S.
1609 S must be live, i.e. S->data must not be null. S->data is actually
1610 a pointer to the `u.data' member of its sdata structure; the
1611 structure starts at a constant offset in front of that. */
1613 #ifdef GC_CHECK_STRING_BYTES
1615 #define SDATA_OF_STRING(S) \
1616 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1617 - sizeof (EMACS_INT)))
1619 #else /* not GC_CHECK_STRING_BYTES */
1621 #define SDATA_OF_STRING(S) \
1622 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1624 #endif /* not GC_CHECK_STRING_BYTES */
1627 #ifdef GC_CHECK_STRING_OVERRUN
1629 /* We check for overrun in string data blocks by appending a small
1630 "cookie" after each allocated string data block, and check for the
1631 presence of this cookie during GC. */
1633 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1634 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1635 { 0xde, 0xad, 0xbe, 0xef };
1638 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1641 /* Value is the size of an sdata structure large enough to hold NBYTES
1642 bytes of string data. The value returned includes a terminating
1643 NUL byte, the size of the sdata structure, and padding. */
1645 #ifdef GC_CHECK_STRING_BYTES
1647 #define SDATA_SIZE(NBYTES) \
1648 ((sizeof (struct Lisp_String *) \
1650 + sizeof (EMACS_INT) \
1651 + sizeof (EMACS_INT) - 1) \
1652 & ~(sizeof (EMACS_INT) - 1))
1654 #else /* not GC_CHECK_STRING_BYTES */
1656 #define SDATA_SIZE(NBYTES) \
1657 ((sizeof (struct Lisp_String *) \
1659 + sizeof (EMACS_INT) - 1) \
1660 & ~(sizeof (EMACS_INT) - 1))
1662 #endif /* not GC_CHECK_STRING_BYTES */
1664 /* Extra bytes to allocate for each string. */
1666 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1668 /* Initialize string allocation. Called from init_alloc_once. */
1673 total_strings
= total_free_strings
= total_string_size
= 0;
1674 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1675 string_blocks
= NULL
;
1676 n_string_blocks
= 0;
1677 string_free_list
= NULL
;
1678 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1679 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1683 #ifdef GC_CHECK_STRING_BYTES
1685 static int check_string_bytes_count
;
1687 static void check_string_bytes (int);
1688 static void check_sblock (struct sblock
*);
1690 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1693 /* Like GC_STRING_BYTES, but with debugging check. */
1696 string_bytes (struct Lisp_String
*s
)
1699 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1701 if (!PURE_POINTER_P (s
)
1703 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1708 /* Check validity of Lisp strings' string_bytes member in B. */
1714 struct sdata
*from
, *end
, *from_end
;
1718 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1720 /* Compute the next FROM here because copying below may
1721 overwrite data we need to compute it. */
1724 /* Check that the string size recorded in the string is the
1725 same as the one recorded in the sdata structure. */
1727 CHECK_STRING_BYTES (from
->string
);
1730 nbytes
= GC_STRING_BYTES (from
->string
);
1732 nbytes
= SDATA_NBYTES (from
);
1734 nbytes
= SDATA_SIZE (nbytes
);
1735 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1740 /* Check validity of Lisp strings' string_bytes member. ALL_P
1741 non-zero means check all strings, otherwise check only most
1742 recently allocated strings. Used for hunting a bug. */
1745 check_string_bytes (all_p
)
1752 for (b
= large_sblocks
; b
; b
= b
->next
)
1754 struct Lisp_String
*s
= b
->first_data
.string
;
1756 CHECK_STRING_BYTES (s
);
1759 for (b
= oldest_sblock
; b
; b
= b
->next
)
1763 check_sblock (current_sblock
);
1766 #endif /* GC_CHECK_STRING_BYTES */
1768 #ifdef GC_CHECK_STRING_FREE_LIST
1770 /* Walk through the string free list looking for bogus next pointers.
1771 This may catch buffer overrun from a previous string. */
1774 check_string_free_list ()
1776 struct Lisp_String
*s
;
1778 /* Pop a Lisp_String off the free-list. */
1779 s
= string_free_list
;
1782 if ((unsigned long)s
< 1024)
1784 s
= NEXT_FREE_LISP_STRING (s
);
1788 #define check_string_free_list()
1791 /* Return a new Lisp_String. */
1793 static struct Lisp_String
*
1794 allocate_string (void)
1796 struct Lisp_String
*s
;
1798 /* eassert (!handling_signal); */
1802 /* If the free-list is empty, allocate a new string_block, and
1803 add all the Lisp_Strings in it to the free-list. */
1804 if (string_free_list
== NULL
)
1806 struct string_block
*b
;
1809 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1810 memset (b
, 0, sizeof *b
);
1811 b
->next
= string_blocks
;
1815 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1818 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1819 string_free_list
= s
;
1822 total_free_strings
+= STRING_BLOCK_SIZE
;
1825 check_string_free_list ();
1827 /* Pop a Lisp_String off the free-list. */
1828 s
= string_free_list
;
1829 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1831 MALLOC_UNBLOCK_INPUT
;
1833 /* Probably not strictly necessary, but play it safe. */
1834 memset (s
, 0, sizeof *s
);
1836 --total_free_strings
;
1839 consing_since_gc
+= sizeof *s
;
1841 #ifdef GC_CHECK_STRING_BYTES
1842 if (!noninteractive
)
1844 if (++check_string_bytes_count
== 200)
1846 check_string_bytes_count
= 0;
1847 check_string_bytes (1);
1850 check_string_bytes (0);
1852 #endif /* GC_CHECK_STRING_BYTES */
1858 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1859 plus a NUL byte at the end. Allocate an sdata structure for S, and
1860 set S->data to its `u.data' member. Store a NUL byte at the end of
1861 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1862 S->data if it was initially non-null. */
1865 allocate_string_data (struct Lisp_String
*s
,
1866 EMACS_INT nchars
, EMACS_INT nbytes
)
1868 struct sdata
*data
, *old_data
;
1870 EMACS_INT needed
, old_nbytes
;
1872 /* Determine the number of bytes needed to store NBYTES bytes
1874 needed
= SDATA_SIZE (nbytes
);
1875 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1876 old_nbytes
= GC_STRING_BYTES (s
);
1880 if (nbytes
> LARGE_STRING_BYTES
)
1882 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1884 #ifdef DOUG_LEA_MALLOC
1885 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1886 because mapped region contents are not preserved in
1889 In case you think of allowing it in a dumped Emacs at the
1890 cost of not being able to re-dump, there's another reason:
1891 mmap'ed data typically have an address towards the top of the
1892 address space, which won't fit into an EMACS_INT (at least on
1893 32-bit systems with the current tagging scheme). --fx */
1894 mallopt (M_MMAP_MAX
, 0);
1897 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1899 #ifdef DOUG_LEA_MALLOC
1900 /* Back to a reasonable maximum of mmap'ed areas. */
1901 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1904 b
->next_free
= &b
->first_data
;
1905 b
->first_data
.string
= NULL
;
1906 b
->next
= large_sblocks
;
1909 else if (current_sblock
== NULL
1910 || (((char *) current_sblock
+ SBLOCK_SIZE
1911 - (char *) current_sblock
->next_free
)
1912 < (needed
+ GC_STRING_EXTRA
)))
1914 /* Not enough room in the current sblock. */
1915 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1916 b
->next_free
= &b
->first_data
;
1917 b
->first_data
.string
= NULL
;
1921 current_sblock
->next
= b
;
1929 data
= b
->next_free
;
1930 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1932 MALLOC_UNBLOCK_INPUT
;
1935 s
->data
= SDATA_DATA (data
);
1936 #ifdef GC_CHECK_STRING_BYTES
1937 SDATA_NBYTES (data
) = nbytes
;
1940 s
->size_byte
= nbytes
;
1941 s
->data
[nbytes
] = '\0';
1942 #ifdef GC_CHECK_STRING_OVERRUN
1943 memcpy (data
+ needed
, string_overrun_cookie
, GC_STRING_OVERRUN_COOKIE_SIZE
);
1946 /* If S had already data assigned, mark that as free by setting its
1947 string back-pointer to null, and recording the size of the data
1951 SDATA_NBYTES (old_data
) = old_nbytes
;
1952 old_data
->string
= NULL
;
1955 consing_since_gc
+= needed
;
1959 /* Sweep and compact strings. */
1962 sweep_strings (void)
1964 struct string_block
*b
, *next
;
1965 struct string_block
*live_blocks
= NULL
;
1967 string_free_list
= NULL
;
1968 total_strings
= total_free_strings
= 0;
1969 total_string_size
= 0;
1971 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1972 for (b
= string_blocks
; b
; b
= next
)
1975 struct Lisp_String
*free_list_before
= string_free_list
;
1979 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1981 struct Lisp_String
*s
= b
->strings
+ i
;
1985 /* String was not on free-list before. */
1986 if (STRING_MARKED_P (s
))
1988 /* String is live; unmark it and its intervals. */
1991 if (!NULL_INTERVAL_P (s
->intervals
))
1992 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1995 total_string_size
+= STRING_BYTES (s
);
1999 /* String is dead. Put it on the free-list. */
2000 struct sdata
*data
= SDATA_OF_STRING (s
);
2002 /* Save the size of S in its sdata so that we know
2003 how large that is. Reset the sdata's string
2004 back-pointer so that we know it's free. */
2005 #ifdef GC_CHECK_STRING_BYTES
2006 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2009 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2011 data
->string
= NULL
;
2013 /* Reset the strings's `data' member so that we
2017 /* Put the string on the free-list. */
2018 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2019 string_free_list
= s
;
2025 /* S was on the free-list before. Put it there again. */
2026 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2027 string_free_list
= s
;
2032 /* Free blocks that contain free Lisp_Strings only, except
2033 the first two of them. */
2034 if (nfree
== STRING_BLOCK_SIZE
2035 && total_free_strings
> STRING_BLOCK_SIZE
)
2039 string_free_list
= free_list_before
;
2043 total_free_strings
+= nfree
;
2044 b
->next
= live_blocks
;
2049 check_string_free_list ();
2051 string_blocks
= live_blocks
;
2052 free_large_strings ();
2053 compact_small_strings ();
2055 check_string_free_list ();
2059 /* Free dead large strings. */
2062 free_large_strings (void)
2064 struct sblock
*b
, *next
;
2065 struct sblock
*live_blocks
= NULL
;
2067 for (b
= large_sblocks
; b
; b
= next
)
2071 if (b
->first_data
.string
== NULL
)
2075 b
->next
= live_blocks
;
2080 large_sblocks
= live_blocks
;
2084 /* Compact data of small strings. Free sblocks that don't contain
2085 data of live strings after compaction. */
2088 compact_small_strings (void)
2090 struct sblock
*b
, *tb
, *next
;
2091 struct sdata
*from
, *to
, *end
, *tb_end
;
2092 struct sdata
*to_end
, *from_end
;
2094 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2095 to, and TB_END is the end of TB. */
2097 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2098 to
= &tb
->first_data
;
2100 /* Step through the blocks from the oldest to the youngest. We
2101 expect that old blocks will stabilize over time, so that less
2102 copying will happen this way. */
2103 for (b
= oldest_sblock
; b
; b
= b
->next
)
2106 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2108 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2110 /* Compute the next FROM here because copying below may
2111 overwrite data we need to compute it. */
2114 #ifdef GC_CHECK_STRING_BYTES
2115 /* Check that the string size recorded in the string is the
2116 same as the one recorded in the sdata structure. */
2118 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2120 #endif /* GC_CHECK_STRING_BYTES */
2123 nbytes
= GC_STRING_BYTES (from
->string
);
2125 nbytes
= SDATA_NBYTES (from
);
2127 if (nbytes
> LARGE_STRING_BYTES
)
2130 nbytes
= SDATA_SIZE (nbytes
);
2131 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2133 #ifdef GC_CHECK_STRING_OVERRUN
2134 if (memcmp (string_overrun_cookie
,
2135 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2136 GC_STRING_OVERRUN_COOKIE_SIZE
))
2140 /* FROM->string non-null means it's alive. Copy its data. */
2143 /* If TB is full, proceed with the next sblock. */
2144 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2145 if (to_end
> tb_end
)
2149 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2150 to
= &tb
->first_data
;
2151 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2154 /* Copy, and update the string's `data' pointer. */
2157 xassert (tb
!= b
|| to
<= from
);
2158 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2159 to
->string
->data
= SDATA_DATA (to
);
2162 /* Advance past the sdata we copied to. */
2168 /* The rest of the sblocks following TB don't contain live data, so
2169 we can free them. */
2170 for (b
= tb
->next
; b
; b
= next
)
2178 current_sblock
= tb
;
2182 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2183 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2184 LENGTH must be an integer.
2185 INIT must be an integer that represents a character. */)
2186 (Lisp_Object length
, Lisp_Object init
)
2188 register Lisp_Object val
;
2189 register unsigned char *p
, *end
;
2193 CHECK_NATNUM (length
);
2194 CHECK_NUMBER (init
);
2197 if (ASCII_CHAR_P (c
))
2199 nbytes
= XINT (length
);
2200 val
= make_uninit_string (nbytes
);
2202 end
= p
+ SCHARS (val
);
2208 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2209 int len
= CHAR_STRING (c
, str
);
2210 EMACS_INT string_len
= XINT (length
);
2212 if (string_len
> MOST_POSITIVE_FIXNUM
/ len
)
2213 error ("Maximum string size exceeded");
2214 nbytes
= len
* string_len
;
2215 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2220 memcpy (p
, str
, len
);
2230 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2231 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2232 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2233 (Lisp_Object length
, Lisp_Object init
)
2235 register Lisp_Object val
;
2236 struct Lisp_Bool_Vector
*p
;
2238 EMACS_INT length_in_chars
, length_in_elts
;
2241 CHECK_NATNUM (length
);
2243 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2245 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2246 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2247 / BOOL_VECTOR_BITS_PER_CHAR
);
2249 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2250 slot `size' of the struct Lisp_Bool_Vector. */
2251 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2253 /* Get rid of any bits that would cause confusion. */
2254 XVECTOR (val
)->size
= 0; /* No Lisp_Object to trace in there. */
2255 /* Use XVECTOR (val) rather than `p' because p->size is not TRT. */
2256 XSETPVECTYPE (XVECTOR (val
), PVEC_BOOL_VECTOR
);
2258 p
= XBOOL_VECTOR (val
);
2259 p
->size
= XFASTINT (length
);
2261 real_init
= (NILP (init
) ? 0 : -1);
2262 for (i
= 0; i
< length_in_chars
; i
++)
2263 p
->data
[i
] = real_init
;
2265 /* Clear the extraneous bits in the last byte. */
2266 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2267 p
->data
[length_in_chars
- 1]
2268 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2274 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2275 of characters from the contents. This string may be unibyte or
2276 multibyte, depending on the contents. */
2279 make_string (const char *contents
, EMACS_INT nbytes
)
2281 register Lisp_Object val
;
2282 EMACS_INT nchars
, multibyte_nbytes
;
2284 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2285 &nchars
, &multibyte_nbytes
);
2286 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2287 /* CONTENTS contains no multibyte sequences or contains an invalid
2288 multibyte sequence. We must make unibyte string. */
2289 val
= make_unibyte_string (contents
, nbytes
);
2291 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2296 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2299 make_unibyte_string (const char *contents
, EMACS_INT length
)
2301 register Lisp_Object val
;
2302 val
= make_uninit_string (length
);
2303 memcpy (SDATA (val
), contents
, length
);
2308 /* Make a multibyte string from NCHARS characters occupying NBYTES
2309 bytes at CONTENTS. */
2312 make_multibyte_string (const char *contents
,
2313 EMACS_INT nchars
, EMACS_INT nbytes
)
2315 register Lisp_Object val
;
2316 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2317 memcpy (SDATA (val
), contents
, nbytes
);
2322 /* Make a string from NCHARS characters occupying NBYTES bytes at
2323 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2326 make_string_from_bytes (const char *contents
,
2327 EMACS_INT nchars
, EMACS_INT nbytes
)
2329 register Lisp_Object val
;
2330 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2331 memcpy (SDATA (val
), contents
, nbytes
);
2332 if (SBYTES (val
) == SCHARS (val
))
2333 STRING_SET_UNIBYTE (val
);
2338 /* Make a string from NCHARS characters occupying NBYTES bytes at
2339 CONTENTS. The argument MULTIBYTE controls whether to label the
2340 string as multibyte. If NCHARS is negative, it counts the number of
2341 characters by itself. */
2344 make_specified_string (const char *contents
,
2345 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
2347 register Lisp_Object val
;
2352 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2357 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2358 memcpy (SDATA (val
), contents
, nbytes
);
2360 STRING_SET_UNIBYTE (val
);
2365 /* Make a string from the data at STR, treating it as multibyte if the
2369 build_string (const char *str
)
2371 return make_string (str
, strlen (str
));
2375 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2376 occupying LENGTH bytes. */
2379 make_uninit_string (EMACS_INT length
)
2384 return empty_unibyte_string
;
2385 val
= make_uninit_multibyte_string (length
, length
);
2386 STRING_SET_UNIBYTE (val
);
2391 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2392 which occupy NBYTES bytes. */
2395 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2398 struct Lisp_String
*s
;
2403 return empty_multibyte_string
;
2405 s
= allocate_string ();
2406 allocate_string_data (s
, nchars
, nbytes
);
2407 XSETSTRING (string
, s
);
2408 string_chars_consed
+= nbytes
;
2414 /***********************************************************************
2416 ***********************************************************************/
2418 /* We store float cells inside of float_blocks, allocating a new
2419 float_block with malloc whenever necessary. Float cells reclaimed
2420 by GC are put on a free list to be reallocated before allocating
2421 any new float cells from the latest float_block. */
2423 #define FLOAT_BLOCK_SIZE \
2424 (((BLOCK_BYTES - sizeof (struct float_block *) \
2425 /* The compiler might add padding at the end. */ \
2426 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2427 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2429 #define GETMARKBIT(block,n) \
2430 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2431 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2434 #define SETMARKBIT(block,n) \
2435 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2436 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2438 #define UNSETMARKBIT(block,n) \
2439 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2440 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2442 #define FLOAT_BLOCK(fptr) \
2443 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2445 #define FLOAT_INDEX(fptr) \
2446 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2450 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2451 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2452 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2453 struct float_block
*next
;
2456 #define FLOAT_MARKED_P(fptr) \
2457 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2459 #define FLOAT_MARK(fptr) \
2460 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2462 #define FLOAT_UNMARK(fptr) \
2463 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2465 /* Current float_block. */
2467 struct float_block
*float_block
;
2469 /* Index of first unused Lisp_Float in the current float_block. */
2471 int float_block_index
;
2473 /* Total number of float blocks now in use. */
2477 /* Free-list of Lisp_Floats. */
2479 struct Lisp_Float
*float_free_list
;
2482 /* Initialize float allocation. */
2488 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2489 float_free_list
= 0;
2494 /* Return a new float object with value FLOAT_VALUE. */
2497 make_float (double float_value
)
2499 register Lisp_Object val
;
2501 /* eassert (!handling_signal); */
2505 if (float_free_list
)
2507 /* We use the data field for chaining the free list
2508 so that we won't use the same field that has the mark bit. */
2509 XSETFLOAT (val
, float_free_list
);
2510 float_free_list
= float_free_list
->u
.chain
;
2514 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2516 register struct float_block
*new;
2518 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2520 new->next
= float_block
;
2521 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2523 float_block_index
= 0;
2526 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2527 float_block_index
++;
2530 MALLOC_UNBLOCK_INPUT
;
2532 XFLOAT_INIT (val
, float_value
);
2533 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2534 consing_since_gc
+= sizeof (struct Lisp_Float
);
2541 /***********************************************************************
2543 ***********************************************************************/
2545 /* We store cons cells inside of cons_blocks, allocating a new
2546 cons_block with malloc whenever necessary. Cons cells reclaimed by
2547 GC are put on a free list to be reallocated before allocating
2548 any new cons cells from the latest cons_block. */
2550 #define CONS_BLOCK_SIZE \
2551 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2552 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2554 #define CONS_BLOCK(fptr) \
2555 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2557 #define CONS_INDEX(fptr) \
2558 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2562 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2563 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2564 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2565 struct cons_block
*next
;
2568 #define CONS_MARKED_P(fptr) \
2569 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2571 #define CONS_MARK(fptr) \
2572 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2574 #define CONS_UNMARK(fptr) \
2575 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2577 /* Current cons_block. */
2579 struct cons_block
*cons_block
;
2581 /* Index of first unused Lisp_Cons in the current block. */
2583 int cons_block_index
;
2585 /* Free-list of Lisp_Cons structures. */
2587 struct Lisp_Cons
*cons_free_list
;
2589 /* Total number of cons blocks now in use. */
2591 static int n_cons_blocks
;
2594 /* Initialize cons allocation. */
2600 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2606 /* Explicitly free a cons cell by putting it on the free-list. */
2609 free_cons (struct Lisp_Cons
*ptr
)
2611 ptr
->u
.chain
= cons_free_list
;
2615 cons_free_list
= ptr
;
2618 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2619 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2620 (Lisp_Object car
, Lisp_Object cdr
)
2622 register Lisp_Object val
;
2624 /* eassert (!handling_signal); */
2630 /* We use the cdr for chaining the free list
2631 so that we won't use the same field that has the mark bit. */
2632 XSETCONS (val
, cons_free_list
);
2633 cons_free_list
= cons_free_list
->u
.chain
;
2637 if (cons_block_index
== CONS_BLOCK_SIZE
)
2639 register struct cons_block
*new;
2640 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2642 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2643 new->next
= cons_block
;
2645 cons_block_index
= 0;
2648 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2652 MALLOC_UNBLOCK_INPUT
;
2656 eassert (!CONS_MARKED_P (XCONS (val
)));
2657 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2658 cons_cells_consed
++;
2662 /* Get an error now if there's any junk in the cons free list. */
2664 check_cons_list (void)
2666 #ifdef GC_CHECK_CONS_LIST
2667 struct Lisp_Cons
*tail
= cons_free_list
;
2670 tail
= tail
->u
.chain
;
2674 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2677 list1 (Lisp_Object arg1
)
2679 return Fcons (arg1
, Qnil
);
2683 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2685 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2690 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2692 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2697 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2699 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2704 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2706 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2707 Fcons (arg5
, Qnil
)))));
2711 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2712 doc
: /* Return a newly created list with specified arguments as elements.
2713 Any number of arguments, even zero arguments, are allowed.
2714 usage: (list &rest OBJECTS) */)
2715 (int nargs
, register Lisp_Object
*args
)
2717 register Lisp_Object val
;
2723 val
= Fcons (args
[nargs
], val
);
2729 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2730 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2731 (register Lisp_Object length
, Lisp_Object init
)
2733 register Lisp_Object val
;
2734 register EMACS_INT size
;
2736 CHECK_NATNUM (length
);
2737 size
= XFASTINT (length
);
2742 val
= Fcons (init
, val
);
2747 val
= Fcons (init
, val
);
2752 val
= Fcons (init
, val
);
2757 val
= Fcons (init
, val
);
2762 val
= Fcons (init
, val
);
2777 /***********************************************************************
2779 ***********************************************************************/
2781 /* Singly-linked list of all vectors. */
2783 static struct Lisp_Vector
*all_vectors
;
2785 /* Total number of vector-like objects now in use. */
2787 static int n_vectors
;
2790 /* Value is a pointer to a newly allocated Lisp_Vector structure
2791 with room for LEN Lisp_Objects. */
2793 static struct Lisp_Vector
*
2794 allocate_vectorlike (EMACS_INT len
)
2796 struct Lisp_Vector
*p
;
2801 #ifdef DOUG_LEA_MALLOC
2802 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2803 because mapped region contents are not preserved in
2805 mallopt (M_MMAP_MAX
, 0);
2808 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2809 /* eassert (!handling_signal); */
2811 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2812 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
2814 #ifdef DOUG_LEA_MALLOC
2815 /* Back to a reasonable maximum of mmap'ed areas. */
2816 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2819 consing_since_gc
+= nbytes
;
2820 vector_cells_consed
+= len
;
2822 p
->next
= all_vectors
;
2825 MALLOC_UNBLOCK_INPUT
;
2832 /* Allocate a vector with NSLOTS slots. */
2834 struct Lisp_Vector
*
2835 allocate_vector (EMACS_INT nslots
)
2837 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
);
2843 /* Allocate other vector-like structures. */
2845 struct Lisp_Vector
*
2846 allocate_pseudovector (int memlen
, int lisplen
, EMACS_INT tag
)
2848 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2851 /* Only the first lisplen slots will be traced normally by the GC. */
2853 for (i
= 0; i
< lisplen
; ++i
)
2854 v
->contents
[i
] = Qnil
;
2856 XSETPVECTYPE (v
, tag
); /* Add the appropriate tag. */
2860 struct Lisp_Hash_Table
*
2861 allocate_hash_table (void)
2863 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
2868 allocate_window (void)
2870 return ALLOCATE_PSEUDOVECTOR(struct window
, current_matrix
, PVEC_WINDOW
);
2875 allocate_terminal (void)
2877 struct terminal
*t
= ALLOCATE_PSEUDOVECTOR (struct terminal
,
2878 next_terminal
, PVEC_TERMINAL
);
2879 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
2880 memset (&t
->next_terminal
, 0,
2881 (char*) (t
+ 1) - (char*) &t
->next_terminal
);
2887 allocate_frame (void)
2889 struct frame
*f
= ALLOCATE_PSEUDOVECTOR (struct frame
,
2890 face_cache
, PVEC_FRAME
);
2891 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
2892 memset (&f
->face_cache
, 0,
2893 (char *) (f
+ 1) - (char *) &f
->face_cache
);
2898 struct Lisp_Process
*
2899 allocate_process (void)
2901 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
2905 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2906 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2907 See also the function `vector'. */)
2908 (register Lisp_Object length
, Lisp_Object init
)
2911 register EMACS_INT sizei
;
2912 register EMACS_INT index
;
2913 register struct Lisp_Vector
*p
;
2915 CHECK_NATNUM (length
);
2916 sizei
= XFASTINT (length
);
2918 p
= allocate_vector (sizei
);
2919 for (index
= 0; index
< sizei
; index
++)
2920 p
->contents
[index
] = init
;
2922 XSETVECTOR (vector
, p
);
2927 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2928 doc
: /* Return a newly created vector with specified arguments as elements.
2929 Any number of arguments, even zero arguments, are allowed.
2930 usage: (vector &rest OBJECTS) */)
2931 (register int nargs
, Lisp_Object
*args
)
2933 register Lisp_Object len
, val
;
2935 register struct Lisp_Vector
*p
;
2937 XSETFASTINT (len
, nargs
);
2938 val
= Fmake_vector (len
, Qnil
);
2940 for (index
= 0; index
< nargs
; index
++)
2941 p
->contents
[index
] = args
[index
];
2946 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2947 doc
: /* Create a byte-code object with specified arguments as elements.
2948 The arguments should be the arglist, bytecode-string, constant vector,
2949 stack size, (optional) doc string, and (optional) interactive spec.
2950 The first four arguments are required; at most six have any
2952 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2953 (register int nargs
, Lisp_Object
*args
)
2955 register Lisp_Object len
, val
;
2957 register struct Lisp_Vector
*p
;
2959 XSETFASTINT (len
, nargs
);
2960 if (!NILP (Vpurify_flag
))
2961 val
= make_pure_vector ((EMACS_INT
) nargs
);
2963 val
= Fmake_vector (len
, Qnil
);
2965 if (nargs
> 1 && STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2966 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2967 earlier because they produced a raw 8-bit string for byte-code
2968 and now such a byte-code string is loaded as multibyte while
2969 raw 8-bit characters converted to multibyte form. Thus, now we
2970 must convert them back to the original unibyte form. */
2971 args
[1] = Fstring_as_unibyte (args
[1]);
2974 for (index
= 0; index
< nargs
; index
++)
2976 if (!NILP (Vpurify_flag
))
2977 args
[index
] = Fpurecopy (args
[index
]);
2978 p
->contents
[index
] = args
[index
];
2980 XSETPVECTYPE (p
, PVEC_COMPILED
);
2981 XSETCOMPILED (val
, p
);
2987 /***********************************************************************
2989 ***********************************************************************/
2991 /* Each symbol_block is just under 1020 bytes long, since malloc
2992 really allocates in units of powers of two and uses 4 bytes for its
2995 #define SYMBOL_BLOCK_SIZE \
2996 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3000 /* Place `symbols' first, to preserve alignment. */
3001 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3002 struct symbol_block
*next
;
3005 /* Current symbol block and index of first unused Lisp_Symbol
3008 static struct symbol_block
*symbol_block
;
3009 static int symbol_block_index
;
3011 /* List of free symbols. */
3013 static struct Lisp_Symbol
*symbol_free_list
;
3015 /* Total number of symbol blocks now in use. */
3017 static int n_symbol_blocks
;
3020 /* Initialize symbol allocation. */
3025 symbol_block
= NULL
;
3026 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3027 symbol_free_list
= 0;
3028 n_symbol_blocks
= 0;
3032 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3033 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3034 Its value and function definition are void, and its property list is nil. */)
3037 register Lisp_Object val
;
3038 register struct Lisp_Symbol
*p
;
3040 CHECK_STRING (name
);
3042 /* eassert (!handling_signal); */
3046 if (symbol_free_list
)
3048 XSETSYMBOL (val
, symbol_free_list
);
3049 symbol_free_list
= symbol_free_list
->next
;
3053 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3055 struct symbol_block
*new;
3056 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3058 new->next
= symbol_block
;
3060 symbol_block_index
= 0;
3063 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3064 symbol_block_index
++;
3067 MALLOC_UNBLOCK_INPUT
;
3072 p
->redirect
= SYMBOL_PLAINVAL
;
3073 SET_SYMBOL_VAL (p
, Qunbound
);
3074 p
->function
= Qunbound
;
3077 p
->interned
= SYMBOL_UNINTERNED
;
3079 p
->declared_special
= 0;
3080 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3087 /***********************************************************************
3088 Marker (Misc) Allocation
3089 ***********************************************************************/
3091 /* Allocation of markers and other objects that share that structure.
3092 Works like allocation of conses. */
3094 #define MARKER_BLOCK_SIZE \
3095 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3099 /* Place `markers' first, to preserve alignment. */
3100 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3101 struct marker_block
*next
;
3104 static struct marker_block
*marker_block
;
3105 static int marker_block_index
;
3107 static union Lisp_Misc
*marker_free_list
;
3109 /* Total number of marker blocks now in use. */
3111 static int n_marker_blocks
;
3116 marker_block
= NULL
;
3117 marker_block_index
= MARKER_BLOCK_SIZE
;
3118 marker_free_list
= 0;
3119 n_marker_blocks
= 0;
3122 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3125 allocate_misc (void)
3129 /* eassert (!handling_signal); */
3133 if (marker_free_list
)
3135 XSETMISC (val
, marker_free_list
);
3136 marker_free_list
= marker_free_list
->u_free
.chain
;
3140 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3142 struct marker_block
*new;
3143 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3145 new->next
= marker_block
;
3147 marker_block_index
= 0;
3149 total_free_markers
+= MARKER_BLOCK_SIZE
;
3151 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3152 marker_block_index
++;
3155 MALLOC_UNBLOCK_INPUT
;
3157 --total_free_markers
;
3158 consing_since_gc
+= sizeof (union Lisp_Misc
);
3159 misc_objects_consed
++;
3160 XMISCANY (val
)->gcmarkbit
= 0;
3164 /* Free a Lisp_Misc object */
3167 free_misc (Lisp_Object misc
)
3169 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3170 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3171 marker_free_list
= XMISC (misc
);
3173 total_free_markers
++;
3176 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3177 INTEGER. This is used to package C values to call record_unwind_protect.
3178 The unwind function can get the C values back using XSAVE_VALUE. */
3181 make_save_value (void *pointer
, int integer
)
3183 register Lisp_Object val
;
3184 register struct Lisp_Save_Value
*p
;
3186 val
= allocate_misc ();
3187 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3188 p
= XSAVE_VALUE (val
);
3189 p
->pointer
= pointer
;
3190 p
->integer
= integer
;
3195 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3196 doc
: /* Return a newly allocated marker which does not point at any place. */)
3199 register Lisp_Object val
;
3200 register struct Lisp_Marker
*p
;
3202 val
= allocate_misc ();
3203 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3209 p
->insertion_type
= 0;
3213 /* Put MARKER back on the free list after using it temporarily. */
3216 free_marker (Lisp_Object marker
)
3218 unchain_marker (XMARKER (marker
));
3223 /* Return a newly created vector or string with specified arguments as
3224 elements. If all the arguments are characters that can fit
3225 in a string of events, make a string; otherwise, make a vector.
3227 Any number of arguments, even zero arguments, are allowed. */
3230 make_event_array (register int nargs
, Lisp_Object
*args
)
3234 for (i
= 0; i
< nargs
; i
++)
3235 /* The things that fit in a string
3236 are characters that are in 0...127,
3237 after discarding the meta bit and all the bits above it. */
3238 if (!INTEGERP (args
[i
])
3239 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3240 return Fvector (nargs
, args
);
3242 /* Since the loop exited, we know that all the things in it are
3243 characters, so we can make a string. */
3247 result
= Fmake_string (make_number (nargs
), make_number (0));
3248 for (i
= 0; i
< nargs
; i
++)
3250 SSET (result
, i
, XINT (args
[i
]));
3251 /* Move the meta bit to the right place for a string char. */
3252 if (XINT (args
[i
]) & CHAR_META
)
3253 SSET (result
, i
, SREF (result
, i
) | 0x80);
3262 /************************************************************************
3263 Memory Full Handling
3264 ************************************************************************/
3267 /* Called if malloc returns zero. */
3276 memory_full_cons_threshold
= sizeof (struct cons_block
);
3278 /* The first time we get here, free the spare memory. */
3279 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3280 if (spare_memory
[i
])
3283 free (spare_memory
[i
]);
3284 else if (i
>= 1 && i
<= 4)
3285 lisp_align_free (spare_memory
[i
]);
3287 lisp_free (spare_memory
[i
]);
3288 spare_memory
[i
] = 0;
3291 /* Record the space now used. When it decreases substantially,
3292 we can refill the memory reserve. */
3293 #ifndef SYSTEM_MALLOC
3294 bytes_used_when_full
= BYTES_USED
;
3297 /* This used to call error, but if we've run out of memory, we could
3298 get infinite recursion trying to build the string. */
3299 xsignal (Qnil
, Vmemory_signal_data
);
3302 /* If we released our reserve (due to running out of memory),
3303 and we have a fair amount free once again,
3304 try to set aside another reserve in case we run out once more.
3306 This is called when a relocatable block is freed in ralloc.c,
3307 and also directly from this file, in case we're not using ralloc.c. */
3310 refill_memory_reserve (void)
3312 #ifndef SYSTEM_MALLOC
3313 if (spare_memory
[0] == 0)
3314 spare_memory
[0] = (char *) malloc ((size_t) SPARE_MEMORY
);
3315 if (spare_memory
[1] == 0)
3316 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3318 if (spare_memory
[2] == 0)
3319 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3321 if (spare_memory
[3] == 0)
3322 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3324 if (spare_memory
[4] == 0)
3325 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3327 if (spare_memory
[5] == 0)
3328 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3330 if (spare_memory
[6] == 0)
3331 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3333 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3334 Vmemory_full
= Qnil
;
3338 /************************************************************************
3340 ************************************************************************/
3342 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3344 /* Conservative C stack marking requires a method to identify possibly
3345 live Lisp objects given a pointer value. We do this by keeping
3346 track of blocks of Lisp data that are allocated in a red-black tree
3347 (see also the comment of mem_node which is the type of nodes in
3348 that tree). Function lisp_malloc adds information for an allocated
3349 block to the red-black tree with calls to mem_insert, and function
3350 lisp_free removes it with mem_delete. Functions live_string_p etc
3351 call mem_find to lookup information about a given pointer in the
3352 tree, and use that to determine if the pointer points to a Lisp
3355 /* Initialize this part of alloc.c. */
3360 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3361 mem_z
.parent
= NULL
;
3362 mem_z
.color
= MEM_BLACK
;
3363 mem_z
.start
= mem_z
.end
= NULL
;
3368 /* Value is a pointer to the mem_node containing START. Value is
3369 MEM_NIL if there is no node in the tree containing START. */
3371 static INLINE
struct mem_node
*
3372 mem_find (void *start
)
3376 if (start
< min_heap_address
|| start
> max_heap_address
)
3379 /* Make the search always successful to speed up the loop below. */
3380 mem_z
.start
= start
;
3381 mem_z
.end
= (char *) start
+ 1;
3384 while (start
< p
->start
|| start
>= p
->end
)
3385 p
= start
< p
->start
? p
->left
: p
->right
;
3390 /* Insert a new node into the tree for a block of memory with start
3391 address START, end address END, and type TYPE. Value is a
3392 pointer to the node that was inserted. */
3394 static struct mem_node
*
3395 mem_insert (void *start
, void *end
, enum mem_type type
)
3397 struct mem_node
*c
, *parent
, *x
;
3399 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3400 min_heap_address
= start
;
3401 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3402 max_heap_address
= end
;
3404 /* See where in the tree a node for START belongs. In this
3405 particular application, it shouldn't happen that a node is already
3406 present. For debugging purposes, let's check that. */
3410 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3412 while (c
!= MEM_NIL
)
3414 if (start
>= c
->start
&& start
< c
->end
)
3417 c
= start
< c
->start
? c
->left
: c
->right
;
3420 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3422 while (c
!= MEM_NIL
)
3425 c
= start
< c
->start
? c
->left
: c
->right
;
3428 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3430 /* Create a new node. */
3431 #ifdef GC_MALLOC_CHECK
3432 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3436 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3442 x
->left
= x
->right
= MEM_NIL
;
3445 /* Insert it as child of PARENT or install it as root. */
3448 if (start
< parent
->start
)
3456 /* Re-establish red-black tree properties. */
3457 mem_insert_fixup (x
);
3463 /* Re-establish the red-black properties of the tree, and thereby
3464 balance the tree, after node X has been inserted; X is always red. */
3467 mem_insert_fixup (struct mem_node
*x
)
3469 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3471 /* X is red and its parent is red. This is a violation of
3472 red-black tree property #3. */
3474 if (x
->parent
== x
->parent
->parent
->left
)
3476 /* We're on the left side of our grandparent, and Y is our
3478 struct mem_node
*y
= x
->parent
->parent
->right
;
3480 if (y
->color
== MEM_RED
)
3482 /* Uncle and parent are red but should be black because
3483 X is red. Change the colors accordingly and proceed
3484 with the grandparent. */
3485 x
->parent
->color
= MEM_BLACK
;
3486 y
->color
= MEM_BLACK
;
3487 x
->parent
->parent
->color
= MEM_RED
;
3488 x
= x
->parent
->parent
;
3492 /* Parent and uncle have different colors; parent is
3493 red, uncle is black. */
3494 if (x
== x
->parent
->right
)
3497 mem_rotate_left (x
);
3500 x
->parent
->color
= MEM_BLACK
;
3501 x
->parent
->parent
->color
= MEM_RED
;
3502 mem_rotate_right (x
->parent
->parent
);
3507 /* This is the symmetrical case of above. */
3508 struct mem_node
*y
= x
->parent
->parent
->left
;
3510 if (y
->color
== MEM_RED
)
3512 x
->parent
->color
= MEM_BLACK
;
3513 y
->color
= MEM_BLACK
;
3514 x
->parent
->parent
->color
= MEM_RED
;
3515 x
= x
->parent
->parent
;
3519 if (x
== x
->parent
->left
)
3522 mem_rotate_right (x
);
3525 x
->parent
->color
= MEM_BLACK
;
3526 x
->parent
->parent
->color
= MEM_RED
;
3527 mem_rotate_left (x
->parent
->parent
);
3532 /* The root may have been changed to red due to the algorithm. Set
3533 it to black so that property #5 is satisfied. */
3534 mem_root
->color
= MEM_BLACK
;
3545 mem_rotate_left (struct mem_node
*x
)
3549 /* Turn y's left sub-tree into x's right sub-tree. */
3552 if (y
->left
!= MEM_NIL
)
3553 y
->left
->parent
= x
;
3555 /* Y's parent was x's parent. */
3557 y
->parent
= x
->parent
;
3559 /* Get the parent to point to y instead of x. */
3562 if (x
== x
->parent
->left
)
3563 x
->parent
->left
= y
;
3565 x
->parent
->right
= y
;
3570 /* Put x on y's left. */
3584 mem_rotate_right (struct mem_node
*x
)
3586 struct mem_node
*y
= x
->left
;
3589 if (y
->right
!= MEM_NIL
)
3590 y
->right
->parent
= x
;
3593 y
->parent
= x
->parent
;
3596 if (x
== x
->parent
->right
)
3597 x
->parent
->right
= y
;
3599 x
->parent
->left
= y
;
3610 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3613 mem_delete (struct mem_node
*z
)
3615 struct mem_node
*x
, *y
;
3617 if (!z
|| z
== MEM_NIL
)
3620 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3625 while (y
->left
!= MEM_NIL
)
3629 if (y
->left
!= MEM_NIL
)
3634 x
->parent
= y
->parent
;
3637 if (y
== y
->parent
->left
)
3638 y
->parent
->left
= x
;
3640 y
->parent
->right
= x
;
3647 z
->start
= y
->start
;
3652 if (y
->color
== MEM_BLACK
)
3653 mem_delete_fixup (x
);
3655 #ifdef GC_MALLOC_CHECK
3663 /* Re-establish the red-black properties of the tree, after a
3667 mem_delete_fixup (struct mem_node
*x
)
3669 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3671 if (x
== x
->parent
->left
)
3673 struct mem_node
*w
= x
->parent
->right
;
3675 if (w
->color
== MEM_RED
)
3677 w
->color
= MEM_BLACK
;
3678 x
->parent
->color
= MEM_RED
;
3679 mem_rotate_left (x
->parent
);
3680 w
= x
->parent
->right
;
3683 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3690 if (w
->right
->color
== MEM_BLACK
)
3692 w
->left
->color
= MEM_BLACK
;
3694 mem_rotate_right (w
);
3695 w
= x
->parent
->right
;
3697 w
->color
= x
->parent
->color
;
3698 x
->parent
->color
= MEM_BLACK
;
3699 w
->right
->color
= MEM_BLACK
;
3700 mem_rotate_left (x
->parent
);
3706 struct mem_node
*w
= x
->parent
->left
;
3708 if (w
->color
== MEM_RED
)
3710 w
->color
= MEM_BLACK
;
3711 x
->parent
->color
= MEM_RED
;
3712 mem_rotate_right (x
->parent
);
3713 w
= x
->parent
->left
;
3716 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3723 if (w
->left
->color
== MEM_BLACK
)
3725 w
->right
->color
= MEM_BLACK
;
3727 mem_rotate_left (w
);
3728 w
= x
->parent
->left
;
3731 w
->color
= x
->parent
->color
;
3732 x
->parent
->color
= MEM_BLACK
;
3733 w
->left
->color
= MEM_BLACK
;
3734 mem_rotate_right (x
->parent
);
3740 x
->color
= MEM_BLACK
;
3744 /* Value is non-zero if P is a pointer to a live Lisp string on
3745 the heap. M is a pointer to the mem_block for P. */
3748 live_string_p (struct mem_node
*m
, void *p
)
3750 if (m
->type
== MEM_TYPE_STRING
)
3752 struct string_block
*b
= (struct string_block
*) m
->start
;
3753 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3755 /* P must point to the start of a Lisp_String structure, and it
3756 must not be on the free-list. */
3758 && offset
% sizeof b
->strings
[0] == 0
3759 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3760 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3767 /* Value is non-zero if P is a pointer to a live Lisp cons on
3768 the heap. M is a pointer to the mem_block for P. */
3771 live_cons_p (struct mem_node
*m
, void *p
)
3773 if (m
->type
== MEM_TYPE_CONS
)
3775 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3776 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
3778 /* P must point to the start of a Lisp_Cons, not be
3779 one of the unused cells in the current cons block,
3780 and not be on the free-list. */
3782 && offset
% sizeof b
->conses
[0] == 0
3783 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3785 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3786 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3793 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3794 the heap. M is a pointer to the mem_block for P. */
3797 live_symbol_p (struct mem_node
*m
, void *p
)
3799 if (m
->type
== MEM_TYPE_SYMBOL
)
3801 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3802 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
3804 /* P must point to the start of a Lisp_Symbol, not be
3805 one of the unused cells in the current symbol block,
3806 and not be on the free-list. */
3808 && offset
% sizeof b
->symbols
[0] == 0
3809 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3810 && (b
!= symbol_block
3811 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3812 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3819 /* Value is non-zero if P is a pointer to a live Lisp float on
3820 the heap. M is a pointer to the mem_block for P. */
3823 live_float_p (struct mem_node
*m
, void *p
)
3825 if (m
->type
== MEM_TYPE_FLOAT
)
3827 struct float_block
*b
= (struct float_block
*) m
->start
;
3828 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
3830 /* P must point to the start of a Lisp_Float and not be
3831 one of the unused cells in the current float block. */
3833 && offset
% sizeof b
->floats
[0] == 0
3834 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3835 && (b
!= float_block
3836 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3843 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3844 the heap. M is a pointer to the mem_block for P. */
3847 live_misc_p (struct mem_node
*m
, void *p
)
3849 if (m
->type
== MEM_TYPE_MISC
)
3851 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3852 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
3854 /* P must point to the start of a Lisp_Misc, not be
3855 one of the unused cells in the current misc block,
3856 and not be on the free-list. */
3858 && offset
% sizeof b
->markers
[0] == 0
3859 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3860 && (b
!= marker_block
3861 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3862 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
3869 /* Value is non-zero if P is a pointer to a live vector-like object.
3870 M is a pointer to the mem_block for P. */
3873 live_vector_p (struct mem_node
*m
, void *p
)
3875 return (p
== m
->start
&& m
->type
== MEM_TYPE_VECTORLIKE
);
3879 /* Value is non-zero if P is a pointer to a live buffer. M is a
3880 pointer to the mem_block for P. */
3883 live_buffer_p (struct mem_node
*m
, void *p
)
3885 /* P must point to the start of the block, and the buffer
3886 must not have been killed. */
3887 return (m
->type
== MEM_TYPE_BUFFER
3889 && !NILP (((struct buffer
*) p
)->BUFFER_INTERNAL_FIELD (name
)));
3892 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3896 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3898 /* Array of objects that are kept alive because the C stack contains
3899 a pattern that looks like a reference to them . */
3901 #define MAX_ZOMBIES 10
3902 static Lisp_Object zombies
[MAX_ZOMBIES
];
3904 /* Number of zombie objects. */
3906 static int nzombies
;
3908 /* Number of garbage collections. */
3912 /* Average percentage of zombies per collection. */
3914 static double avg_zombies
;
3916 /* Max. number of live and zombie objects. */
3918 static int max_live
, max_zombies
;
3920 /* Average number of live objects per GC. */
3922 static double avg_live
;
3924 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3925 doc
: /* Show information about live and zombie objects. */)
3928 Lisp_Object args
[8], zombie_list
= Qnil
;
3930 for (i
= 0; i
< nzombies
; i
++)
3931 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3932 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3933 args
[1] = make_number (ngcs
);
3934 args
[2] = make_float (avg_live
);
3935 args
[3] = make_float (avg_zombies
);
3936 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3937 args
[5] = make_number (max_live
);
3938 args
[6] = make_number (max_zombies
);
3939 args
[7] = zombie_list
;
3940 return Fmessage (8, args
);
3943 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3946 /* Mark OBJ if we can prove it's a Lisp_Object. */
3949 mark_maybe_object (Lisp_Object obj
)
3957 po
= (void *) XPNTR (obj
);
3964 switch (XTYPE (obj
))
3967 mark_p
= (live_string_p (m
, po
)
3968 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3972 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
3976 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
3980 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
3983 case Lisp_Vectorlike
:
3984 /* Note: can't check BUFFERP before we know it's a
3985 buffer because checking that dereferences the pointer
3986 PO which might point anywhere. */
3987 if (live_vector_p (m
, po
))
3988 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
3989 else if (live_buffer_p (m
, po
))
3990 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
3994 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4003 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4004 if (nzombies
< MAX_ZOMBIES
)
4005 zombies
[nzombies
] = obj
;
4014 /* If P points to Lisp data, mark that as live if it isn't already
4018 mark_maybe_pointer (void *p
)
4022 /* Quickly rule out some values which can't point to Lisp data. */
4025 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4027 2 /* We assume that Lisp data is aligned on even addresses. */
4035 Lisp_Object obj
= Qnil
;
4039 case MEM_TYPE_NON_LISP
:
4040 /* Nothing to do; not a pointer to Lisp memory. */
4043 case MEM_TYPE_BUFFER
:
4044 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4045 XSETVECTOR (obj
, p
);
4049 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4053 case MEM_TYPE_STRING
:
4054 if (live_string_p (m
, p
)
4055 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4056 XSETSTRING (obj
, p
);
4060 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4064 case MEM_TYPE_SYMBOL
:
4065 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4066 XSETSYMBOL (obj
, p
);
4069 case MEM_TYPE_FLOAT
:
4070 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4074 case MEM_TYPE_VECTORLIKE
:
4075 if (live_vector_p (m
, p
))
4078 XSETVECTOR (tem
, p
);
4079 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4094 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4095 or END+OFFSET..START. */
4098 mark_memory (void *start
, void *end
, int offset
)
4103 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4107 /* Make START the pointer to the start of the memory region,
4108 if it isn't already. */
4116 /* Mark Lisp_Objects. */
4117 for (p
= (Lisp_Object
*) ((char *) start
+ offset
); (void *) p
< end
; ++p
)
4118 mark_maybe_object (*p
);
4120 /* Mark Lisp data pointed to. This is necessary because, in some
4121 situations, the C compiler optimizes Lisp objects away, so that
4122 only a pointer to them remains. Example:
4124 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4127 Lisp_Object obj = build_string ("test");
4128 struct Lisp_String *s = XSTRING (obj);
4129 Fgarbage_collect ();
4130 fprintf (stderr, "test `%s'\n", s->data);
4134 Here, `obj' isn't really used, and the compiler optimizes it
4135 away. The only reference to the life string is through the
4138 for (pp
= (void **) ((char *) start
+ offset
); (void *) pp
< end
; ++pp
)
4139 mark_maybe_pointer (*pp
);
4142 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4143 the GCC system configuration. In gcc 3.2, the only systems for
4144 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4145 by others?) and ns32k-pc532-min. */
4147 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4149 static int setjmp_tested_p
, longjmps_done
;
4151 #define SETJMP_WILL_LIKELY_WORK "\
4153 Emacs garbage collector has been changed to use conservative stack\n\
4154 marking. Emacs has determined that the method it uses to do the\n\
4155 marking will likely work on your system, but this isn't sure.\n\
4157 If you are a system-programmer, or can get the help of a local wizard\n\
4158 who is, please take a look at the function mark_stack in alloc.c, and\n\
4159 verify that the methods used are appropriate for your system.\n\
4161 Please mail the result to <emacs-devel@gnu.org>.\n\
4164 #define SETJMP_WILL_NOT_WORK "\
4166 Emacs garbage collector has been changed to use conservative stack\n\
4167 marking. Emacs has determined that the default method it uses to do the\n\
4168 marking will not work on your system. We will need a system-dependent\n\
4169 solution for your system.\n\
4171 Please take a look at the function mark_stack in alloc.c, and\n\
4172 try to find a way to make it work on your system.\n\
4174 Note that you may get false negatives, depending on the compiler.\n\
4175 In particular, you need to use -O with GCC for this test.\n\
4177 Please mail the result to <emacs-devel@gnu.org>.\n\
4181 /* Perform a quick check if it looks like setjmp saves registers in a
4182 jmp_buf. Print a message to stderr saying so. When this test
4183 succeeds, this is _not_ a proof that setjmp is sufficient for
4184 conservative stack marking. Only the sources or a disassembly
4195 /* Arrange for X to be put in a register. */
4201 if (longjmps_done
== 1)
4203 /* Came here after the longjmp at the end of the function.
4205 If x == 1, the longjmp has restored the register to its
4206 value before the setjmp, and we can hope that setjmp
4207 saves all such registers in the jmp_buf, although that
4210 For other values of X, either something really strange is
4211 taking place, or the setjmp just didn't save the register. */
4214 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4217 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4224 if (longjmps_done
== 1)
4228 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4231 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4233 /* Abort if anything GCPRO'd doesn't survive the GC. */
4241 for (p
= gcprolist
; p
; p
= p
->next
)
4242 for (i
= 0; i
< p
->nvars
; ++i
)
4243 if (!survives_gc_p (p
->var
[i
]))
4244 /* FIXME: It's not necessarily a bug. It might just be that the
4245 GCPRO is unnecessary or should release the object sooner. */
4249 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4256 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4257 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4259 fprintf (stderr
, " %d = ", i
);
4260 debug_print (zombies
[i
]);
4264 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4267 /* Mark live Lisp objects on the C stack.
4269 There are several system-dependent problems to consider when
4270 porting this to new architectures:
4274 We have to mark Lisp objects in CPU registers that can hold local
4275 variables or are used to pass parameters.
4277 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4278 something that either saves relevant registers on the stack, or
4279 calls mark_maybe_object passing it each register's contents.
4281 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4282 implementation assumes that calling setjmp saves registers we need
4283 to see in a jmp_buf which itself lies on the stack. This doesn't
4284 have to be true! It must be verified for each system, possibly
4285 by taking a look at the source code of setjmp.
4287 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4288 can use it as a machine independent method to store all registers
4289 to the stack. In this case the macros described in the previous
4290 two paragraphs are not used.
4294 Architectures differ in the way their processor stack is organized.
4295 For example, the stack might look like this
4298 | Lisp_Object | size = 4
4300 | something else | size = 2
4302 | Lisp_Object | size = 4
4306 In such a case, not every Lisp_Object will be aligned equally. To
4307 find all Lisp_Object on the stack it won't be sufficient to walk
4308 the stack in steps of 4 bytes. Instead, two passes will be
4309 necessary, one starting at the start of the stack, and a second
4310 pass starting at the start of the stack + 2. Likewise, if the
4311 minimal alignment of Lisp_Objects on the stack is 1, four passes
4312 would be necessary, each one starting with one byte more offset
4313 from the stack start.
4315 The current code assumes by default that Lisp_Objects are aligned
4316 equally on the stack. */
4322 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4323 union aligned_jmpbuf
{
4327 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4330 #ifdef HAVE___BUILTIN_UNWIND_INIT
4331 /* Force callee-saved registers and register windows onto the stack.
4332 This is the preferred method if available, obviating the need for
4333 machine dependent methods. */
4334 __builtin_unwind_init ();
4336 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4337 /* This trick flushes the register windows so that all the state of
4338 the process is contained in the stack. */
4339 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4340 needed on ia64 too. See mach_dep.c, where it also says inline
4341 assembler doesn't work with relevant proprietary compilers. */
4343 #if defined (__sparc64__) && defined (__FreeBSD__)
4344 /* FreeBSD does not have a ta 3 handler. */
4351 /* Save registers that we need to see on the stack. We need to see
4352 registers used to hold register variables and registers used to
4354 #ifdef GC_SAVE_REGISTERS_ON_STACK
4355 GC_SAVE_REGISTERS_ON_STACK (end
);
4356 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4358 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4359 setjmp will definitely work, test it
4360 and print a message with the result
4362 if (!setjmp_tested_p
)
4364 setjmp_tested_p
= 1;
4367 #endif /* GC_SETJMP_WORKS */
4370 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4371 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4372 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4374 /* This assumes that the stack is a contiguous region in memory. If
4375 that's not the case, something has to be done here to iterate
4376 over the stack segments. */
4377 #ifndef GC_LISP_OBJECT_ALIGNMENT
4379 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4381 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4384 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4385 mark_memory (stack_base
, end
, i
);
4386 /* Allow for marking a secondary stack, like the register stack on the
4388 #ifdef GC_MARK_SECONDARY_STACK
4389 GC_MARK_SECONDARY_STACK ();
4392 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4397 #endif /* GC_MARK_STACK != 0 */
4400 /* Determine whether it is safe to access memory at address P. */
4402 valid_pointer_p (void *p
)
4405 return w32_valid_pointer_p (p
, 16);
4409 /* Obviously, we cannot just access it (we would SEGV trying), so we
4410 trick the o/s to tell us whether p is a valid pointer.
4411 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4412 not validate p in that case. */
4414 if ((fd
= emacs_open ("__Valid__Lisp__Object__", O_CREAT
| O_WRONLY
| O_TRUNC
, 0666)) >= 0)
4416 int valid
= (emacs_write (fd
, (char *)p
, 16) == 16);
4418 unlink ("__Valid__Lisp__Object__");
4426 /* Return 1 if OBJ is a valid lisp object.
4427 Return 0 if OBJ is NOT a valid lisp object.
4428 Return -1 if we cannot validate OBJ.
4429 This function can be quite slow,
4430 so it should only be used in code for manual debugging. */
4433 valid_lisp_object_p (Lisp_Object obj
)
4443 p
= (void *) XPNTR (obj
);
4444 if (PURE_POINTER_P (p
))
4448 return valid_pointer_p (p
);
4455 int valid
= valid_pointer_p (p
);
4467 case MEM_TYPE_NON_LISP
:
4470 case MEM_TYPE_BUFFER
:
4471 return live_buffer_p (m
, p
);
4474 return live_cons_p (m
, p
);
4476 case MEM_TYPE_STRING
:
4477 return live_string_p (m
, p
);
4480 return live_misc_p (m
, p
);
4482 case MEM_TYPE_SYMBOL
:
4483 return live_symbol_p (m
, p
);
4485 case MEM_TYPE_FLOAT
:
4486 return live_float_p (m
, p
);
4488 case MEM_TYPE_VECTORLIKE
:
4489 return live_vector_p (m
, p
);
4502 /***********************************************************************
4503 Pure Storage Management
4504 ***********************************************************************/
4506 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4507 pointer to it. TYPE is the Lisp type for which the memory is
4508 allocated. TYPE < 0 means it's not used for a Lisp object. */
4510 static POINTER_TYPE
*
4511 pure_alloc (size_t size
, int type
)
4513 POINTER_TYPE
*result
;
4515 size_t alignment
= (1 << GCTYPEBITS
);
4517 size_t alignment
= sizeof (EMACS_INT
);
4519 /* Give Lisp_Floats an extra alignment. */
4520 if (type
== Lisp_Float
)
4522 #if defined __GNUC__ && __GNUC__ >= 2
4523 alignment
= __alignof (struct Lisp_Float
);
4525 alignment
= sizeof (struct Lisp_Float
);
4533 /* Allocate space for a Lisp object from the beginning of the free
4534 space with taking account of alignment. */
4535 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4536 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4540 /* Allocate space for a non-Lisp object from the end of the free
4542 pure_bytes_used_non_lisp
+= size
;
4543 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4545 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4547 if (pure_bytes_used
<= pure_size
)
4550 /* Don't allocate a large amount here,
4551 because it might get mmap'd and then its address
4552 might not be usable. */
4553 purebeg
= (char *) xmalloc (10000);
4555 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4556 pure_bytes_used
= 0;
4557 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4562 /* Print a warning if PURESIZE is too small. */
4565 check_pure_size (void)
4567 if (pure_bytes_used_before_overflow
)
4568 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4569 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4573 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4574 the non-Lisp data pool of the pure storage, and return its start
4575 address. Return NULL if not found. */
4578 find_string_data_in_pure (const char *data
, EMACS_INT nbytes
)
4581 EMACS_INT skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4582 const unsigned char *p
;
4585 if (pure_bytes_used_non_lisp
< nbytes
+ 1)
4588 /* Set up the Boyer-Moore table. */
4590 for (i
= 0; i
< 256; i
++)
4593 p
= (const unsigned char *) data
;
4595 bm_skip
[*p
++] = skip
;
4597 last_char_skip
= bm_skip
['\0'];
4599 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4600 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4602 /* See the comments in the function `boyer_moore' (search.c) for the
4603 use of `infinity'. */
4604 infinity
= pure_bytes_used_non_lisp
+ 1;
4605 bm_skip
['\0'] = infinity
;
4607 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4611 /* Check the last character (== '\0'). */
4614 start
+= bm_skip
[*(p
+ start
)];
4616 while (start
<= start_max
);
4618 if (start
< infinity
)
4619 /* Couldn't find the last character. */
4622 /* No less than `infinity' means we could find the last
4623 character at `p[start - infinity]'. */
4626 /* Check the remaining characters. */
4627 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4629 return non_lisp_beg
+ start
;
4631 start
+= last_char_skip
;
4633 while (start
<= start_max
);
4639 /* Return a string allocated in pure space. DATA is a buffer holding
4640 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4641 non-zero means make the result string multibyte.
4643 Must get an error if pure storage is full, since if it cannot hold
4644 a large string it may be able to hold conses that point to that
4645 string; then the string is not protected from gc. */
4648 make_pure_string (const char *data
,
4649 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
4652 struct Lisp_String
*s
;
4654 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4655 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4656 if (s
->data
== NULL
)
4658 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4659 memcpy (s
->data
, data
, nbytes
);
4660 s
->data
[nbytes
] = '\0';
4663 s
->size_byte
= multibyte
? nbytes
: -1;
4664 s
->intervals
= NULL_INTERVAL
;
4665 XSETSTRING (string
, s
);
4669 /* Return a string a string allocated in pure space. Do not allocate
4670 the string data, just point to DATA. */
4673 make_pure_c_string (const char *data
)
4676 struct Lisp_String
*s
;
4677 EMACS_INT nchars
= strlen (data
);
4679 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4682 s
->data
= (unsigned char *) data
;
4683 s
->intervals
= NULL_INTERVAL
;
4684 XSETSTRING (string
, s
);
4688 /* Return a cons allocated from pure space. Give it pure copies
4689 of CAR as car and CDR as cdr. */
4692 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4694 register Lisp_Object
new;
4695 struct Lisp_Cons
*p
;
4697 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4699 XSETCAR (new, Fpurecopy (car
));
4700 XSETCDR (new, Fpurecopy (cdr
));
4705 /* Value is a float object with value NUM allocated from pure space. */
4708 make_pure_float (double num
)
4710 register Lisp_Object
new;
4711 struct Lisp_Float
*p
;
4713 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4715 XFLOAT_INIT (new, num
);
4720 /* Return a vector with room for LEN Lisp_Objects allocated from
4724 make_pure_vector (EMACS_INT len
)
4727 struct Lisp_Vector
*p
;
4728 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4730 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4731 XSETVECTOR (new, p
);
4732 XVECTOR (new)->size
= len
;
4737 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4738 doc
: /* Make a copy of object OBJ in pure storage.
4739 Recursively copies contents of vectors and cons cells.
4740 Does not copy symbols. Copies strings without text properties. */)
4741 (register Lisp_Object obj
)
4743 if (NILP (Vpurify_flag
))
4746 if (PURE_POINTER_P (XPNTR (obj
)))
4749 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4751 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
4757 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
4758 else if (FLOATP (obj
))
4759 obj
= make_pure_float (XFLOAT_DATA (obj
));
4760 else if (STRINGP (obj
))
4761 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
4763 STRING_MULTIBYTE (obj
));
4764 else if (COMPILEDP (obj
) || VECTORP (obj
))
4766 register struct Lisp_Vector
*vec
;
4767 register EMACS_INT i
;
4770 size
= XVECTOR (obj
)->size
;
4771 if (size
& PSEUDOVECTOR_FLAG
)
4772 size
&= PSEUDOVECTOR_SIZE_MASK
;
4773 vec
= XVECTOR (make_pure_vector (size
));
4774 for (i
= 0; i
< size
; i
++)
4775 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4776 if (COMPILEDP (obj
))
4778 XSETPVECTYPE (vec
, PVEC_COMPILED
);
4779 XSETCOMPILED (obj
, vec
);
4782 XSETVECTOR (obj
, vec
);
4784 else if (MARKERP (obj
))
4785 error ("Attempt to copy a marker to pure storage");
4787 /* Not purified, don't hash-cons. */
4790 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4791 Fputhash (obj
, obj
, Vpurify_flag
);
4798 /***********************************************************************
4800 ***********************************************************************/
4802 /* Put an entry in staticvec, pointing at the variable with address
4806 staticpro (Lisp_Object
*varaddress
)
4808 staticvec
[staticidx
++] = varaddress
;
4809 if (staticidx
>= NSTATICS
)
4814 /***********************************************************************
4816 ***********************************************************************/
4818 /* Temporarily prevent garbage collection. */
4821 inhibit_garbage_collection (void)
4823 int count
= SPECPDL_INDEX ();
4824 int nbits
= min (VALBITS
, BITS_PER_INT
);
4826 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4831 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4832 doc
: /* Reclaim storage for Lisp objects no longer needed.
4833 Garbage collection happens automatically if you cons more than
4834 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4835 `garbage-collect' normally returns a list with info on amount of space in use:
4836 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4837 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4838 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4839 (USED-STRINGS . FREE-STRINGS))
4840 However, if there was overflow in pure space, `garbage-collect'
4841 returns nil, because real GC can't be done. */)
4844 register struct specbinding
*bind
;
4845 char stack_top_variable
;
4848 Lisp_Object total
[8];
4849 int count
= SPECPDL_INDEX ();
4850 EMACS_TIME t1
, t2
, t3
;
4855 /* Can't GC if pure storage overflowed because we can't determine
4856 if something is a pure object or not. */
4857 if (pure_bytes_used_before_overflow
)
4862 /* Don't keep undo information around forever.
4863 Do this early on, so it is no problem if the user quits. */
4865 register struct buffer
*nextb
= all_buffers
;
4869 /* If a buffer's undo list is Qt, that means that undo is
4870 turned off in that buffer. Calling truncate_undo_list on
4871 Qt tends to return NULL, which effectively turns undo back on.
4872 So don't call truncate_undo_list if undo_list is Qt. */
4873 if (! NILP (nextb
->BUFFER_INTERNAL_FIELD (name
)) && ! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
4874 truncate_undo_list (nextb
);
4876 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4877 if (nextb
->base_buffer
== 0 && !NILP (nextb
->BUFFER_INTERNAL_FIELD (name
))
4878 && ! nextb
->text
->inhibit_shrinking
)
4880 /* If a buffer's gap size is more than 10% of the buffer
4881 size, or larger than 2000 bytes, then shrink it
4882 accordingly. Keep a minimum size of 20 bytes. */
4883 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4885 if (nextb
->text
->gap_size
> size
)
4887 struct buffer
*save_current
= current_buffer
;
4888 current_buffer
= nextb
;
4889 make_gap (-(nextb
->text
->gap_size
- size
));
4890 current_buffer
= save_current
;
4894 nextb
= nextb
->next
;
4898 EMACS_GET_TIME (t1
);
4900 /* In case user calls debug_print during GC,
4901 don't let that cause a recursive GC. */
4902 consing_since_gc
= 0;
4904 /* Save what's currently displayed in the echo area. */
4905 message_p
= push_message ();
4906 record_unwind_protect (pop_message_unwind
, Qnil
);
4908 /* Save a copy of the contents of the stack, for debugging. */
4909 #if MAX_SAVE_STACK > 0
4910 if (NILP (Vpurify_flag
))
4912 i
= &stack_top_variable
- stack_bottom
;
4914 if (i
< MAX_SAVE_STACK
)
4916 if (stack_copy
== 0)
4917 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4918 else if (stack_copy_size
< i
)
4919 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4922 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4923 memcpy (stack_copy
, stack_bottom
, i
);
4925 memcpy (stack_copy
, &stack_top_variable
, i
);
4929 #endif /* MAX_SAVE_STACK > 0 */
4931 if (garbage_collection_messages
)
4932 message1_nolog ("Garbage collecting...");
4936 shrink_regexp_cache ();
4940 /* clear_marks (); */
4942 /* Mark all the special slots that serve as the roots of accessibility. */
4944 for (i
= 0; i
< staticidx
; i
++)
4945 mark_object (*staticvec
[i
]);
4947 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4949 mark_object (bind
->symbol
);
4950 mark_object (bind
->old_value
);
4958 extern void xg_mark_data (void);
4963 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4964 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4968 register struct gcpro
*tail
;
4969 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4970 for (i
= 0; i
< tail
->nvars
; i
++)
4971 mark_object (tail
->var
[i
]);
4975 struct catchtag
*catch;
4976 struct handler
*handler
;
4978 for (catch = catchlist
; catch; catch = catch->next
)
4980 mark_object (catch->tag
);
4981 mark_object (catch->val
);
4983 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4985 mark_object (handler
->handler
);
4986 mark_object (handler
->var
);
4992 #ifdef HAVE_WINDOW_SYSTEM
4993 mark_fringe_data ();
4996 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5000 /* Everything is now marked, except for the things that require special
5001 finalization, i.e. the undo_list.
5002 Look thru every buffer's undo list
5003 for elements that update markers that were not marked,
5006 register struct buffer
*nextb
= all_buffers
;
5010 /* If a buffer's undo list is Qt, that means that undo is
5011 turned off in that buffer. Calling truncate_undo_list on
5012 Qt tends to return NULL, which effectively turns undo back on.
5013 So don't call truncate_undo_list if undo_list is Qt. */
5014 if (! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5016 Lisp_Object tail
, prev
;
5017 tail
= nextb
->BUFFER_INTERNAL_FIELD (undo_list
);
5019 while (CONSP (tail
))
5021 if (CONSP (XCAR (tail
))
5022 && MARKERP (XCAR (XCAR (tail
)))
5023 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5026 nextb
->BUFFER_INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5030 XSETCDR (prev
, tail
);
5040 /* Now that we have stripped the elements that need not be in the
5041 undo_list any more, we can finally mark the list. */
5042 mark_object (nextb
->BUFFER_INTERNAL_FIELD (undo_list
));
5044 nextb
= nextb
->next
;
5050 /* Clear the mark bits that we set in certain root slots. */
5052 unmark_byte_stack ();
5053 VECTOR_UNMARK (&buffer_defaults
);
5054 VECTOR_UNMARK (&buffer_local_symbols
);
5056 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5064 /* clear_marks (); */
5067 consing_since_gc
= 0;
5068 if (gc_cons_threshold
< 10000)
5069 gc_cons_threshold
= 10000;
5071 if (FLOATP (Vgc_cons_percentage
))
5072 { /* Set gc_cons_combined_threshold. */
5073 EMACS_INT total
= 0;
5075 total
+= total_conses
* sizeof (struct Lisp_Cons
);
5076 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5077 total
+= total_markers
* sizeof (union Lisp_Misc
);
5078 total
+= total_string_size
;
5079 total
+= total_vector_size
* sizeof (Lisp_Object
);
5080 total
+= total_floats
* sizeof (struct Lisp_Float
);
5081 total
+= total_intervals
* sizeof (struct interval
);
5082 total
+= total_strings
* sizeof (struct Lisp_String
);
5084 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
5087 gc_relative_threshold
= 0;
5089 if (garbage_collection_messages
)
5091 if (message_p
|| minibuf_level
> 0)
5094 message1_nolog ("Garbage collecting...done");
5097 unbind_to (count
, Qnil
);
5099 total
[0] = Fcons (make_number (total_conses
),
5100 make_number (total_free_conses
));
5101 total
[1] = Fcons (make_number (total_symbols
),
5102 make_number (total_free_symbols
));
5103 total
[2] = Fcons (make_number (total_markers
),
5104 make_number (total_free_markers
));
5105 total
[3] = make_number (total_string_size
);
5106 total
[4] = make_number (total_vector_size
);
5107 total
[5] = Fcons (make_number (total_floats
),
5108 make_number (total_free_floats
));
5109 total
[6] = Fcons (make_number (total_intervals
),
5110 make_number (total_free_intervals
));
5111 total
[7] = Fcons (make_number (total_strings
),
5112 make_number (total_free_strings
));
5114 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5116 /* Compute average percentage of zombies. */
5119 for (i
= 0; i
< 7; ++i
)
5120 if (CONSP (total
[i
]))
5121 nlive
+= XFASTINT (XCAR (total
[i
]));
5123 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5124 max_live
= max (nlive
, max_live
);
5125 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5126 max_zombies
= max (nzombies
, max_zombies
);
5131 if (!NILP (Vpost_gc_hook
))
5133 int count
= inhibit_garbage_collection ();
5134 safe_run_hooks (Qpost_gc_hook
);
5135 unbind_to (count
, Qnil
);
5138 /* Accumulate statistics. */
5139 EMACS_GET_TIME (t2
);
5140 EMACS_SUB_TIME (t3
, t2
, t1
);
5141 if (FLOATP (Vgc_elapsed
))
5142 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5144 EMACS_USECS (t3
) * 1.0e-6);
5147 return Flist (sizeof total
/ sizeof *total
, total
);
5151 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5152 only interesting objects referenced from glyphs are strings. */
5155 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5157 struct glyph_row
*row
= matrix
->rows
;
5158 struct glyph_row
*end
= row
+ matrix
->nrows
;
5160 for (; row
< end
; ++row
)
5164 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5166 struct glyph
*glyph
= row
->glyphs
[area
];
5167 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5169 for (; glyph
< end_glyph
; ++glyph
)
5170 if (STRINGP (glyph
->object
)
5171 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5172 mark_object (glyph
->object
);
5178 /* Mark Lisp faces in the face cache C. */
5181 mark_face_cache (struct face_cache
*c
)
5186 for (i
= 0; i
< c
->used
; ++i
)
5188 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5192 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5193 mark_object (face
->lface
[j
]);
5201 /* Mark reference to a Lisp_Object.
5202 If the object referred to has not been seen yet, recursively mark
5203 all the references contained in it. */
5205 #define LAST_MARKED_SIZE 500
5206 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5207 int last_marked_index
;
5209 /* For debugging--call abort when we cdr down this many
5210 links of a list, in mark_object. In debugging,
5211 the call to abort will hit a breakpoint.
5212 Normally this is zero and the check never goes off. */
5213 static int mark_object_loop_halt
;
5216 mark_vectorlike (struct Lisp_Vector
*ptr
)
5218 register EMACS_UINT size
= ptr
->size
;
5219 register EMACS_UINT i
;
5221 eassert (!VECTOR_MARKED_P (ptr
));
5222 VECTOR_MARK (ptr
); /* Else mark it */
5223 if (size
& PSEUDOVECTOR_FLAG
)
5224 size
&= PSEUDOVECTOR_SIZE_MASK
;
5226 /* Note that this size is not the memory-footprint size, but only
5227 the number of Lisp_Object fields that we should trace.
5228 The distinction is used e.g. by Lisp_Process which places extra
5229 non-Lisp_Object fields at the end of the structure. */
5230 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5231 mark_object (ptr
->contents
[i
]);
5234 /* Like mark_vectorlike but optimized for char-tables (and
5235 sub-char-tables) assuming that the contents are mostly integers or
5239 mark_char_table (struct Lisp_Vector
*ptr
)
5241 register EMACS_UINT size
= ptr
->size
& PSEUDOVECTOR_SIZE_MASK
;
5242 register EMACS_UINT i
;
5244 eassert (!VECTOR_MARKED_P (ptr
));
5246 for (i
= 0; i
< size
; i
++)
5248 Lisp_Object val
= ptr
->contents
[i
];
5250 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5252 if (SUB_CHAR_TABLE_P (val
))
5254 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5255 mark_char_table (XVECTOR (val
));
5263 mark_object (Lisp_Object arg
)
5265 register Lisp_Object obj
= arg
;
5266 #ifdef GC_CHECK_MARKED_OBJECTS
5274 if (PURE_POINTER_P (XPNTR (obj
)))
5277 last_marked
[last_marked_index
++] = obj
;
5278 if (last_marked_index
== LAST_MARKED_SIZE
)
5279 last_marked_index
= 0;
5281 /* Perform some sanity checks on the objects marked here. Abort if
5282 we encounter an object we know is bogus. This increases GC time
5283 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5284 #ifdef GC_CHECK_MARKED_OBJECTS
5286 po
= (void *) XPNTR (obj
);
5288 /* Check that the object pointed to by PO is known to be a Lisp
5289 structure allocated from the heap. */
5290 #define CHECK_ALLOCATED() \
5292 m = mem_find (po); \
5297 /* Check that the object pointed to by PO is live, using predicate
5299 #define CHECK_LIVE(LIVEP) \
5301 if (!LIVEP (m, po)) \
5305 /* Check both of the above conditions. */
5306 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5308 CHECK_ALLOCATED (); \
5309 CHECK_LIVE (LIVEP); \
5312 #else /* not GC_CHECK_MARKED_OBJECTS */
5314 #define CHECK_ALLOCATED() (void) 0
5315 #define CHECK_LIVE(LIVEP) (void) 0
5316 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5318 #endif /* not GC_CHECK_MARKED_OBJECTS */
5320 switch (SWITCH_ENUM_CAST (XTYPE (obj
)))
5324 register struct Lisp_String
*ptr
= XSTRING (obj
);
5325 if (STRING_MARKED_P (ptr
))
5327 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5328 MARK_INTERVAL_TREE (ptr
->intervals
);
5330 #ifdef GC_CHECK_STRING_BYTES
5331 /* Check that the string size recorded in the string is the
5332 same as the one recorded in the sdata structure. */
5333 CHECK_STRING_BYTES (ptr
);
5334 #endif /* GC_CHECK_STRING_BYTES */
5338 case Lisp_Vectorlike
:
5339 if (VECTOR_MARKED_P (XVECTOR (obj
)))
5341 #ifdef GC_CHECK_MARKED_OBJECTS
5343 if (m
== MEM_NIL
&& !SUBRP (obj
)
5344 && po
!= &buffer_defaults
5345 && po
!= &buffer_local_symbols
)
5347 #endif /* GC_CHECK_MARKED_OBJECTS */
5351 #ifdef GC_CHECK_MARKED_OBJECTS
5352 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5355 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5360 #endif /* GC_CHECK_MARKED_OBJECTS */
5363 else if (SUBRP (obj
))
5365 else if (COMPILEDP (obj
))
5366 /* We could treat this just like a vector, but it is better to
5367 save the COMPILED_CONSTANTS element for last and avoid
5370 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5371 register EMACS_UINT size
= ptr
->size
;
5372 register EMACS_UINT i
;
5374 CHECK_LIVE (live_vector_p
);
5375 VECTOR_MARK (ptr
); /* Else mark it */
5376 size
&= PSEUDOVECTOR_SIZE_MASK
;
5377 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5379 if (i
!= COMPILED_CONSTANTS
)
5380 mark_object (ptr
->contents
[i
]);
5382 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5385 else if (FRAMEP (obj
))
5387 register struct frame
*ptr
= XFRAME (obj
);
5388 mark_vectorlike (XVECTOR (obj
));
5389 mark_face_cache (ptr
->face_cache
);
5391 else if (WINDOWP (obj
))
5393 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5394 struct window
*w
= XWINDOW (obj
);
5395 mark_vectorlike (ptr
);
5396 /* Mark glyphs for leaf windows. Marking window matrices is
5397 sufficient because frame matrices use the same glyph
5399 if (NILP (w
->hchild
)
5401 && w
->current_matrix
)
5403 mark_glyph_matrix (w
->current_matrix
);
5404 mark_glyph_matrix (w
->desired_matrix
);
5407 else if (HASH_TABLE_P (obj
))
5409 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5410 mark_vectorlike ((struct Lisp_Vector
*)h
);
5411 /* If hash table is not weak, mark all keys and values.
5412 For weak tables, mark only the vector. */
5414 mark_object (h
->key_and_value
);
5416 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5418 else if (CHAR_TABLE_P (obj
))
5419 mark_char_table (XVECTOR (obj
));
5421 mark_vectorlike (XVECTOR (obj
));
5426 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5427 struct Lisp_Symbol
*ptrx
;
5431 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5433 mark_object (ptr
->function
);
5434 mark_object (ptr
->plist
);
5435 switch (ptr
->redirect
)
5437 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5438 case SYMBOL_VARALIAS
:
5441 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5445 case SYMBOL_LOCALIZED
:
5447 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5448 /* If the value is forwarded to a buffer or keyboard field,
5449 these are marked when we see the corresponding object.
5450 And if it's forwarded to a C variable, either it's not
5451 a Lisp_Object var, or it's staticpro'd already. */
5452 mark_object (blv
->where
);
5453 mark_object (blv
->valcell
);
5454 mark_object (blv
->defcell
);
5457 case SYMBOL_FORWARDED
:
5458 /* If the value is forwarded to a buffer or keyboard field,
5459 these are marked when we see the corresponding object.
5460 And if it's forwarded to a C variable, either it's not
5461 a Lisp_Object var, or it's staticpro'd already. */
5465 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5466 MARK_STRING (XSTRING (ptr
->xname
));
5467 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5472 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5473 XSETSYMBOL (obj
, ptrx
);
5480 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5481 if (XMISCANY (obj
)->gcmarkbit
)
5483 XMISCANY (obj
)->gcmarkbit
= 1;
5485 switch (XMISCTYPE (obj
))
5488 case Lisp_Misc_Marker
:
5489 /* DO NOT mark thru the marker's chain.
5490 The buffer's markers chain does not preserve markers from gc;
5491 instead, markers are removed from the chain when freed by gc. */
5494 case Lisp_Misc_Save_Value
:
5497 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5498 /* If DOGC is set, POINTER is the address of a memory
5499 area containing INTEGER potential Lisp_Objects. */
5502 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5504 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5505 mark_maybe_object (*p
);
5511 case Lisp_Misc_Overlay
:
5513 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5514 mark_object (ptr
->start
);
5515 mark_object (ptr
->end
);
5516 mark_object (ptr
->plist
);
5519 XSETMISC (obj
, ptr
->next
);
5532 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5533 if (CONS_MARKED_P (ptr
))
5535 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5537 /* If the cdr is nil, avoid recursion for the car. */
5538 if (EQ (ptr
->u
.cdr
, Qnil
))
5544 mark_object (ptr
->car
);
5547 if (cdr_count
== mark_object_loop_halt
)
5553 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5554 FLOAT_MARK (XFLOAT (obj
));
5565 #undef CHECK_ALLOCATED
5566 #undef CHECK_ALLOCATED_AND_LIVE
5569 /* Mark the pointers in a buffer structure. */
5572 mark_buffer (Lisp_Object buf
)
5574 register struct buffer
*buffer
= XBUFFER (buf
);
5575 register Lisp_Object
*ptr
, tmp
;
5576 Lisp_Object base_buffer
;
5578 eassert (!VECTOR_MARKED_P (buffer
));
5579 VECTOR_MARK (buffer
);
5581 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5583 /* For now, we just don't mark the undo_list. It's done later in
5584 a special way just before the sweep phase, and after stripping
5585 some of its elements that are not needed any more. */
5587 if (buffer
->overlays_before
)
5589 XSETMISC (tmp
, buffer
->overlays_before
);
5592 if (buffer
->overlays_after
)
5594 XSETMISC (tmp
, buffer
->overlays_after
);
5598 /* buffer-local Lisp variables start at `undo_list',
5599 tho only the ones from `name' on are GC'd normally. */
5600 for (ptr
= &buffer
->BUFFER_INTERNAL_FIELD (name
);
5601 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5605 /* If this is an indirect buffer, mark its base buffer. */
5606 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5608 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5609 mark_buffer (base_buffer
);
5613 /* Mark the Lisp pointers in the terminal objects.
5614 Called by the Fgarbage_collector. */
5617 mark_terminals (void)
5620 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5622 eassert (t
->name
!= NULL
);
5623 #ifdef HAVE_WINDOW_SYSTEM
5624 /* If a terminal object is reachable from a stacpro'ed object,
5625 it might have been marked already. Make sure the image cache
5627 mark_image_cache (t
->image_cache
);
5628 #endif /* HAVE_WINDOW_SYSTEM */
5629 if (!VECTOR_MARKED_P (t
))
5630 mark_vectorlike ((struct Lisp_Vector
*)t
);
5636 /* Value is non-zero if OBJ will survive the current GC because it's
5637 either marked or does not need to be marked to survive. */
5640 survives_gc_p (Lisp_Object obj
)
5644 switch (XTYPE (obj
))
5651 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5655 survives_p
= XMISCANY (obj
)->gcmarkbit
;
5659 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5662 case Lisp_Vectorlike
:
5663 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5667 survives_p
= CONS_MARKED_P (XCONS (obj
));
5671 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5678 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5683 /* Sweep: find all structures not marked, and free them. */
5688 /* Remove or mark entries in weak hash tables.
5689 This must be done before any object is unmarked. */
5690 sweep_weak_hash_tables ();
5693 #ifdef GC_CHECK_STRING_BYTES
5694 if (!noninteractive
)
5695 check_string_bytes (1);
5698 /* Put all unmarked conses on free list */
5700 register struct cons_block
*cblk
;
5701 struct cons_block
**cprev
= &cons_block
;
5702 register int lim
= cons_block_index
;
5703 register int num_free
= 0, num_used
= 0;
5707 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5711 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
5713 /* Scan the mark bits an int at a time. */
5714 for (i
= 0; i
<= ilim
; i
++)
5716 if (cblk
->gcmarkbits
[i
] == -1)
5718 /* Fast path - all cons cells for this int are marked. */
5719 cblk
->gcmarkbits
[i
] = 0;
5720 num_used
+= BITS_PER_INT
;
5724 /* Some cons cells for this int are not marked.
5725 Find which ones, and free them. */
5726 int start
, pos
, stop
;
5728 start
= i
* BITS_PER_INT
;
5730 if (stop
> BITS_PER_INT
)
5731 stop
= BITS_PER_INT
;
5734 for (pos
= start
; pos
< stop
; pos
++)
5736 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
5739 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
5740 cons_free_list
= &cblk
->conses
[pos
];
5742 cons_free_list
->car
= Vdead
;
5748 CONS_UNMARK (&cblk
->conses
[pos
]);
5754 lim
= CONS_BLOCK_SIZE
;
5755 /* If this block contains only free conses and we have already
5756 seen more than two blocks worth of free conses then deallocate
5758 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5760 *cprev
= cblk
->next
;
5761 /* Unhook from the free list. */
5762 cons_free_list
= cblk
->conses
[0].u
.chain
;
5763 lisp_align_free (cblk
);
5768 num_free
+= this_free
;
5769 cprev
= &cblk
->next
;
5772 total_conses
= num_used
;
5773 total_free_conses
= num_free
;
5776 /* Put all unmarked floats on free list */
5778 register struct float_block
*fblk
;
5779 struct float_block
**fprev
= &float_block
;
5780 register int lim
= float_block_index
;
5781 register int num_free
= 0, num_used
= 0;
5783 float_free_list
= 0;
5785 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5789 for (i
= 0; i
< lim
; i
++)
5790 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5793 fblk
->floats
[i
].u
.chain
= float_free_list
;
5794 float_free_list
= &fblk
->floats
[i
];
5799 FLOAT_UNMARK (&fblk
->floats
[i
]);
5801 lim
= FLOAT_BLOCK_SIZE
;
5802 /* If this block contains only free floats and we have already
5803 seen more than two blocks worth of free floats then deallocate
5805 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5807 *fprev
= fblk
->next
;
5808 /* Unhook from the free list. */
5809 float_free_list
= fblk
->floats
[0].u
.chain
;
5810 lisp_align_free (fblk
);
5815 num_free
+= this_free
;
5816 fprev
= &fblk
->next
;
5819 total_floats
= num_used
;
5820 total_free_floats
= num_free
;
5823 /* Put all unmarked intervals on free list */
5825 register struct interval_block
*iblk
;
5826 struct interval_block
**iprev
= &interval_block
;
5827 register int lim
= interval_block_index
;
5828 register int num_free
= 0, num_used
= 0;
5830 interval_free_list
= 0;
5832 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5837 for (i
= 0; i
< lim
; i
++)
5839 if (!iblk
->intervals
[i
].gcmarkbit
)
5841 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5842 interval_free_list
= &iblk
->intervals
[i
];
5848 iblk
->intervals
[i
].gcmarkbit
= 0;
5851 lim
= INTERVAL_BLOCK_SIZE
;
5852 /* If this block contains only free intervals and we have already
5853 seen more than two blocks worth of free intervals then
5854 deallocate this block. */
5855 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5857 *iprev
= iblk
->next
;
5858 /* Unhook from the free list. */
5859 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5861 n_interval_blocks
--;
5865 num_free
+= this_free
;
5866 iprev
= &iblk
->next
;
5869 total_intervals
= num_used
;
5870 total_free_intervals
= num_free
;
5873 /* Put all unmarked symbols on free list */
5875 register struct symbol_block
*sblk
;
5876 struct symbol_block
**sprev
= &symbol_block
;
5877 register int lim
= symbol_block_index
;
5878 register int num_free
= 0, num_used
= 0;
5880 symbol_free_list
= NULL
;
5882 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5885 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5886 struct Lisp_Symbol
*end
= sym
+ lim
;
5888 for (; sym
< end
; ++sym
)
5890 /* Check if the symbol was created during loadup. In such a case
5891 it might be pointed to by pure bytecode which we don't trace,
5892 so we conservatively assume that it is live. */
5893 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5895 if (!sym
->gcmarkbit
&& !pure_p
)
5897 if (sym
->redirect
== SYMBOL_LOCALIZED
)
5898 xfree (SYMBOL_BLV (sym
));
5899 sym
->next
= symbol_free_list
;
5900 symbol_free_list
= sym
;
5902 symbol_free_list
->function
= Vdead
;
5910 UNMARK_STRING (XSTRING (sym
->xname
));
5915 lim
= SYMBOL_BLOCK_SIZE
;
5916 /* If this block contains only free symbols and we have already
5917 seen more than two blocks worth of free symbols then deallocate
5919 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5921 *sprev
= sblk
->next
;
5922 /* Unhook from the free list. */
5923 symbol_free_list
= sblk
->symbols
[0].next
;
5929 num_free
+= this_free
;
5930 sprev
= &sblk
->next
;
5933 total_symbols
= num_used
;
5934 total_free_symbols
= num_free
;
5937 /* Put all unmarked misc's on free list.
5938 For a marker, first unchain it from the buffer it points into. */
5940 register struct marker_block
*mblk
;
5941 struct marker_block
**mprev
= &marker_block
;
5942 register int lim
= marker_block_index
;
5943 register int num_free
= 0, num_used
= 0;
5945 marker_free_list
= 0;
5947 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5952 for (i
= 0; i
< lim
; i
++)
5954 if (!mblk
->markers
[i
].u_any
.gcmarkbit
)
5956 if (mblk
->markers
[i
].u_any
.type
== Lisp_Misc_Marker
)
5957 unchain_marker (&mblk
->markers
[i
].u_marker
);
5958 /* Set the type of the freed object to Lisp_Misc_Free.
5959 We could leave the type alone, since nobody checks it,
5960 but this might catch bugs faster. */
5961 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5962 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5963 marker_free_list
= &mblk
->markers
[i
];
5969 mblk
->markers
[i
].u_any
.gcmarkbit
= 0;
5972 lim
= MARKER_BLOCK_SIZE
;
5973 /* If this block contains only free markers and we have already
5974 seen more than two blocks worth of free markers then deallocate
5976 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5978 *mprev
= mblk
->next
;
5979 /* Unhook from the free list. */
5980 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5986 num_free
+= this_free
;
5987 mprev
= &mblk
->next
;
5991 total_markers
= num_used
;
5992 total_free_markers
= num_free
;
5995 /* Free all unmarked buffers */
5997 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6000 if (!VECTOR_MARKED_P (buffer
))
6003 prev
->next
= buffer
->next
;
6005 all_buffers
= buffer
->next
;
6006 next
= buffer
->next
;
6012 VECTOR_UNMARK (buffer
);
6013 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6014 prev
= buffer
, buffer
= buffer
->next
;
6018 /* Free all unmarked vectors */
6020 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6021 total_vector_size
= 0;
6024 if (!VECTOR_MARKED_P (vector
))
6027 prev
->next
= vector
->next
;
6029 all_vectors
= vector
->next
;
6030 next
= vector
->next
;
6038 VECTOR_UNMARK (vector
);
6039 if (vector
->size
& PSEUDOVECTOR_FLAG
)
6040 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
6042 total_vector_size
+= vector
->size
;
6043 prev
= vector
, vector
= vector
->next
;
6047 #ifdef GC_CHECK_STRING_BYTES
6048 if (!noninteractive
)
6049 check_string_bytes (1);
6056 /* Debugging aids. */
6058 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6059 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6060 This may be helpful in debugging Emacs's memory usage.
6061 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6066 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
6071 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6072 doc
: /* Return a list of counters that measure how much consing there has been.
6073 Each of these counters increments for a certain kind of object.
6074 The counters wrap around from the largest positive integer to zero.
6075 Garbage collection does not decrease them.
6076 The elements of the value are as follows:
6077 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6078 All are in units of 1 = one object consed
6079 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6081 MISCS include overlays, markers, and some internal types.
6082 Frames, windows, buffers, and subprocesses count as vectors
6083 (but the contents of a buffer's text do not count here). */)
6086 Lisp_Object consed
[8];
6088 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6089 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6090 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6091 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6092 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6093 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6094 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6095 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6097 return Flist (8, consed
);
6100 int suppress_checking
;
6103 die (const char *msg
, const char *file
, int line
)
6105 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6110 /* Initialization */
6113 init_alloc_once (void)
6115 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6117 pure_size
= PURESIZE
;
6118 pure_bytes_used
= 0;
6119 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6120 pure_bytes_used_before_overflow
= 0;
6122 /* Initialize the list of free aligned blocks. */
6125 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6127 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6131 ignore_warnings
= 1;
6132 #ifdef DOUG_LEA_MALLOC
6133 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6134 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6135 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6143 init_weak_hash_tables ();
6146 malloc_hysteresis
= 32;
6148 malloc_hysteresis
= 0;
6151 refill_memory_reserve ();
6153 ignore_warnings
= 0;
6155 byte_stack_list
= 0;
6157 consing_since_gc
= 0;
6158 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6159 gc_relative_threshold
= 0;
6166 byte_stack_list
= 0;
6168 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6169 setjmp_tested_p
= longjmps_done
= 0;
6172 Vgc_elapsed
= make_float (0.0);
6177 syms_of_alloc (void)
6179 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6180 doc
: /* *Number of bytes of consing between garbage collections.
6181 Garbage collection can happen automatically once this many bytes have been
6182 allocated since the last garbage collection. All data types count.
6184 Garbage collection happens automatically only when `eval' is called.
6186 By binding this temporarily to a large number, you can effectively
6187 prevent garbage collection during a part of the program.
6188 See also `gc-cons-percentage'. */);
6190 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6191 doc
: /* *Portion of the heap used for allocation.
6192 Garbage collection can happen automatically once this portion of the heap
6193 has been allocated since the last garbage collection.
6194 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6195 Vgc_cons_percentage
= make_float (0.1);
6197 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6198 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6200 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6201 doc
: /* Number of cons cells that have been consed so far. */);
6203 DEFVAR_INT ("floats-consed", floats_consed
,
6204 doc
: /* Number of floats that have been consed so far. */);
6206 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6207 doc
: /* Number of vector cells that have been consed so far. */);
6209 DEFVAR_INT ("symbols-consed", symbols_consed
,
6210 doc
: /* Number of symbols that have been consed so far. */);
6212 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6213 doc
: /* Number of string characters that have been consed so far. */);
6215 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6216 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6218 DEFVAR_INT ("intervals-consed", intervals_consed
,
6219 doc
: /* Number of intervals that have been consed so far. */);
6221 DEFVAR_INT ("strings-consed", strings_consed
,
6222 doc
: /* Number of strings that have been consed so far. */);
6224 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6225 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6226 This means that certain objects should be allocated in shared (pure) space.
6227 It can also be set to a hash-table, in which case this table is used to
6228 do hash-consing of the objects allocated to pure space. */);
6230 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6231 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6232 garbage_collection_messages
= 0;
6234 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6235 doc
: /* Hook run after garbage collection has finished. */);
6236 Vpost_gc_hook
= Qnil
;
6237 Qpost_gc_hook
= intern_c_string ("post-gc-hook");
6238 staticpro (&Qpost_gc_hook
);
6240 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6241 doc
: /* Precomputed `signal' argument for memory-full error. */);
6242 /* We build this in advance because if we wait until we need it, we might
6243 not be able to allocate the memory to hold it. */
6245 = pure_cons (Qerror
,
6246 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil
));
6248 DEFVAR_LISP ("memory-full", Vmemory_full
,
6249 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6250 Vmemory_full
= Qnil
;
6252 staticpro (&Qgc_cons_threshold
);
6253 Qgc_cons_threshold
= intern_c_string ("gc-cons-threshold");
6255 staticpro (&Qchar_table_extra_slots
);
6256 Qchar_table_extra_slots
= intern_c_string ("char-table-extra-slots");
6258 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6259 doc
: /* Accumulated time elapsed in garbage collections.
6260 The time is in seconds as a floating point value. */);
6261 DEFVAR_INT ("gcs-done", gcs_done
,
6262 doc
: /* Accumulated number of garbage collections done. */);
6267 defsubr (&Smake_byte_code
);
6268 defsubr (&Smake_list
);
6269 defsubr (&Smake_vector
);
6270 defsubr (&Smake_string
);
6271 defsubr (&Smake_bool_vector
);
6272 defsubr (&Smake_symbol
);
6273 defsubr (&Smake_marker
);
6274 defsubr (&Spurecopy
);
6275 defsubr (&Sgarbage_collect
);
6276 defsubr (&Smemory_limit
);
6277 defsubr (&Smemory_use_counts
);
6279 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6280 defsubr (&Sgc_status
);