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_backtrace (void);
275 static void gc_sweep (void);
276 static void mark_glyph_matrix (struct glyph_matrix
*);
277 static void mark_face_cache (struct face_cache
*);
279 #ifdef HAVE_WINDOW_SYSTEM
280 extern void mark_fringe_data (void);
281 #endif /* HAVE_WINDOW_SYSTEM */
283 static struct Lisp_String
*allocate_string (void);
284 static void compact_small_strings (void);
285 static void free_large_strings (void);
286 static void sweep_strings (void);
288 extern int message_enable_multibyte
;
290 /* When scanning the C stack for live Lisp objects, Emacs keeps track
291 of what memory allocated via lisp_malloc is intended for what
292 purpose. This enumeration specifies the type of memory. */
303 /* We used to keep separate mem_types for subtypes of vectors such as
304 process, hash_table, frame, terminal, and window, but we never made
305 use of the distinction, so it only caused source-code complexity
306 and runtime slowdown. Minor but pointless. */
310 static POINTER_TYPE
*lisp_align_malloc (size_t, enum mem_type
);
311 static POINTER_TYPE
*lisp_malloc (size_t, enum mem_type
);
314 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
316 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
317 #include <stdio.h> /* For fprintf. */
320 /* A unique object in pure space used to make some Lisp objects
321 on free lists recognizable in O(1). */
323 static Lisp_Object Vdead
;
325 #ifdef GC_MALLOC_CHECK
327 enum mem_type allocated_mem_type
;
328 static int dont_register_blocks
;
330 #endif /* GC_MALLOC_CHECK */
332 /* A node in the red-black tree describing allocated memory containing
333 Lisp data. Each such block is recorded with its start and end
334 address when it is allocated, and removed from the tree when it
337 A red-black tree is a balanced binary tree with the following
340 1. Every node is either red or black.
341 2. Every leaf is black.
342 3. If a node is red, then both of its children are black.
343 4. Every simple path from a node to a descendant leaf contains
344 the same number of black nodes.
345 5. The root is always black.
347 When nodes are inserted into the tree, or deleted from the tree,
348 the tree is "fixed" so that these properties are always true.
350 A red-black tree with N internal nodes has height at most 2
351 log(N+1). Searches, insertions and deletions are done in O(log N).
352 Please see a text book about data structures for a detailed
353 description of red-black trees. Any book worth its salt should
358 /* Children of this node. These pointers are never NULL. When there
359 is no child, the value is MEM_NIL, which points to a dummy node. */
360 struct mem_node
*left
, *right
;
362 /* The parent of this node. In the root node, this is NULL. */
363 struct mem_node
*parent
;
365 /* Start and end of allocated region. */
369 enum {MEM_BLACK
, MEM_RED
} color
;
375 /* Base address of stack. Set in main. */
377 Lisp_Object
*stack_base
;
379 /* Root of the tree describing allocated Lisp memory. */
381 static struct mem_node
*mem_root
;
383 /* Lowest and highest known address in the heap. */
385 static void *min_heap_address
, *max_heap_address
;
387 /* Sentinel node of the tree. */
389 static struct mem_node mem_z
;
390 #define MEM_NIL &mem_z
392 static struct Lisp_Vector
*allocate_vectorlike (EMACS_INT
);
393 static void lisp_free (POINTER_TYPE
*);
394 static void mark_stack (void);
395 static int live_vector_p (struct mem_node
*, void *);
396 static int live_buffer_p (struct mem_node
*, void *);
397 static int live_string_p (struct mem_node
*, void *);
398 static int live_cons_p (struct mem_node
*, void *);
399 static int live_symbol_p (struct mem_node
*, void *);
400 static int live_float_p (struct mem_node
*, void *);
401 static int live_misc_p (struct mem_node
*, void *);
402 static void mark_maybe_object (Lisp_Object
);
403 static void mark_memory (void *, void *, int);
404 static void mem_init (void);
405 static struct mem_node
*mem_insert (void *, void *, enum mem_type
);
406 static void mem_insert_fixup (struct mem_node
*);
407 static void mem_rotate_left (struct mem_node
*);
408 static void mem_rotate_right (struct mem_node
*);
409 static void mem_delete (struct mem_node
*);
410 static void mem_delete_fixup (struct mem_node
*);
411 static INLINE
struct mem_node
*mem_find (void *);
414 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
415 static void check_gcpros (void);
418 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
420 /* Recording what needs to be marked for gc. */
422 struct gcpro
*gcprolist
;
424 /* Addresses of staticpro'd variables. Initialize it to a nonzero
425 value; otherwise some compilers put it into BSS. */
427 #define NSTATICS 0x640
428 static Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
430 /* Index of next unused slot in staticvec. */
432 static int staticidx
= 0;
434 static POINTER_TYPE
*pure_alloc (size_t, int);
437 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
438 ALIGNMENT must be a power of 2. */
440 #define ALIGN(ptr, ALIGNMENT) \
441 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
442 & ~((ALIGNMENT) - 1)))
446 /************************************************************************
448 ************************************************************************/
450 /* Function malloc calls this if it finds we are near exhausting storage. */
453 malloc_warning (const char *str
)
455 pending_malloc_warning
= str
;
459 /* Display an already-pending malloc warning. */
462 display_malloc_warning (void)
464 call3 (intern ("display-warning"),
466 build_string (pending_malloc_warning
),
467 intern ("emergency"));
468 pending_malloc_warning
= 0;
472 #ifdef DOUG_LEA_MALLOC
473 # define BYTES_USED (mallinfo ().uordblks)
475 # define BYTES_USED _bytes_used
478 /* Called if we can't allocate relocatable space for a buffer. */
481 buffer_memory_full (void)
483 /* If buffers use the relocating allocator, no need to free
484 spare_memory, because we may have plenty of malloc space left
485 that we could get, and if we don't, the malloc that fails will
486 itself cause spare_memory to be freed. If buffers don't use the
487 relocating allocator, treat this like any other failing
494 /* This used to call error, but if we've run out of memory, we could
495 get infinite recursion trying to build the string. */
496 xsignal (Qnil
, Vmemory_signal_data
);
500 #ifdef XMALLOC_OVERRUN_CHECK
502 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
503 and a 16 byte trailer around each block.
505 The header consists of 12 fixed bytes + a 4 byte integer contaning the
506 original block size, while the trailer consists of 16 fixed bytes.
508 The header is used to detect whether this block has been allocated
509 through these functions -- as it seems that some low-level libc
510 functions may bypass the malloc hooks.
514 #define XMALLOC_OVERRUN_CHECK_SIZE 16
516 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
517 { 0x9a, 0x9b, 0xae, 0xaf,
518 0xbf, 0xbe, 0xce, 0xcf,
519 0xea, 0xeb, 0xec, 0xed };
521 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
522 { 0xaa, 0xab, 0xac, 0xad,
523 0xba, 0xbb, 0xbc, 0xbd,
524 0xca, 0xcb, 0xcc, 0xcd,
525 0xda, 0xdb, 0xdc, 0xdd };
527 /* Macros to insert and extract the block size in the header. */
529 #define XMALLOC_PUT_SIZE(ptr, size) \
530 (ptr[-1] = (size & 0xff), \
531 ptr[-2] = ((size >> 8) & 0xff), \
532 ptr[-3] = ((size >> 16) & 0xff), \
533 ptr[-4] = ((size >> 24) & 0xff))
535 #define XMALLOC_GET_SIZE(ptr) \
536 (size_t)((unsigned)(ptr[-1]) | \
537 ((unsigned)(ptr[-2]) << 8) | \
538 ((unsigned)(ptr[-3]) << 16) | \
539 ((unsigned)(ptr[-4]) << 24))
542 /* The call depth in overrun_check functions. For example, this might happen:
544 overrun_check_malloc()
545 -> malloc -> (via hook)_-> emacs_blocked_malloc
546 -> overrun_check_malloc
547 call malloc (hooks are NULL, so real malloc is called).
548 malloc returns 10000.
549 add overhead, return 10016.
550 <- (back in overrun_check_malloc)
551 add overhead again, return 10032
552 xmalloc returns 10032.
557 overrun_check_free(10032)
559 free(10016) <- crash, because 10000 is the original pointer. */
561 static int check_depth
;
563 /* Like malloc, but wraps allocated block with header and trailer. */
566 overrun_check_malloc (size
)
569 register unsigned char *val
;
570 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
572 val
= (unsigned char *) malloc (size
+ overhead
);
573 if (val
&& check_depth
== 1)
575 memcpy (val
, xmalloc_overrun_check_header
,
576 XMALLOC_OVERRUN_CHECK_SIZE
- 4);
577 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
578 XMALLOC_PUT_SIZE(val
, size
);
579 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
580 XMALLOC_OVERRUN_CHECK_SIZE
);
583 return (POINTER_TYPE
*)val
;
587 /* Like realloc, but checks old block for overrun, and wraps new block
588 with header and trailer. */
591 overrun_check_realloc (block
, size
)
595 register unsigned char *val
= (unsigned char *)block
;
596 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
600 && memcmp (xmalloc_overrun_check_header
,
601 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
602 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
604 size_t osize
= XMALLOC_GET_SIZE (val
);
605 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
606 XMALLOC_OVERRUN_CHECK_SIZE
))
608 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
609 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
610 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
613 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
615 if (val
&& check_depth
== 1)
617 memcpy (val
, xmalloc_overrun_check_header
,
618 XMALLOC_OVERRUN_CHECK_SIZE
- 4);
619 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
620 XMALLOC_PUT_SIZE(val
, size
);
621 memcpy (val
+ size
, xmalloc_overrun_check_trailer
,
622 XMALLOC_OVERRUN_CHECK_SIZE
);
625 return (POINTER_TYPE
*)val
;
628 /* Like free, but checks block for overrun. */
631 overrun_check_free (block
)
634 unsigned char *val
= (unsigned char *)block
;
639 && memcmp (xmalloc_overrun_check_header
,
640 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
641 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
643 size_t osize
= XMALLOC_GET_SIZE (val
);
644 if (memcmp (xmalloc_overrun_check_trailer
, val
+ osize
,
645 XMALLOC_OVERRUN_CHECK_SIZE
))
647 #ifdef XMALLOC_CLEAR_FREE_MEMORY
648 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
649 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
651 memset (val
+ osize
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
652 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
653 memset (val
, 0, XMALLOC_OVERRUN_CHECK_SIZE
);
664 #define malloc overrun_check_malloc
665 #define realloc overrun_check_realloc
666 #define free overrun_check_free
670 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
671 there's no need to block input around malloc. */
672 #define MALLOC_BLOCK_INPUT ((void)0)
673 #define MALLOC_UNBLOCK_INPUT ((void)0)
675 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
676 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
679 /* Like malloc but check for no memory and block interrupt input.. */
682 xmalloc (size_t size
)
684 register POINTER_TYPE
*val
;
687 val
= (POINTER_TYPE
*) malloc (size
);
688 MALLOC_UNBLOCK_INPUT
;
696 /* Like realloc but check for no memory and block interrupt input.. */
699 xrealloc (POINTER_TYPE
*block
, size_t size
)
701 register POINTER_TYPE
*val
;
704 /* We must call malloc explicitly when BLOCK is 0, since some
705 reallocs don't do this. */
707 val
= (POINTER_TYPE
*) malloc (size
);
709 val
= (POINTER_TYPE
*) realloc (block
, size
);
710 MALLOC_UNBLOCK_INPUT
;
712 if (!val
&& size
) memory_full ();
717 /* Like free but block interrupt input. */
720 xfree (POINTER_TYPE
*block
)
726 MALLOC_UNBLOCK_INPUT
;
727 /* We don't call refill_memory_reserve here
728 because that duplicates doing so in emacs_blocked_free
729 and the criterion should go there. */
733 /* Like strdup, but uses xmalloc. */
736 xstrdup (const char *s
)
738 size_t len
= strlen (s
) + 1;
739 char *p
= (char *) xmalloc (len
);
745 /* Unwind for SAFE_ALLOCA */
748 safe_alloca_unwind (Lisp_Object arg
)
750 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
760 /* Like malloc but used for allocating Lisp data. NBYTES is the
761 number of bytes to allocate, TYPE describes the intended use of the
762 allcated memory block (for strings, for conses, ...). */
765 static void *lisp_malloc_loser
;
768 static POINTER_TYPE
*
769 lisp_malloc (size_t nbytes
, enum mem_type type
)
775 #ifdef GC_MALLOC_CHECK
776 allocated_mem_type
= type
;
779 val
= (void *) malloc (nbytes
);
782 /* If the memory just allocated cannot be addressed thru a Lisp
783 object's pointer, and it needs to be,
784 that's equivalent to running out of memory. */
785 if (val
&& type
!= MEM_TYPE_NON_LISP
)
788 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
789 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
791 lisp_malloc_loser
= val
;
798 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
799 if (val
&& type
!= MEM_TYPE_NON_LISP
)
800 mem_insert (val
, (char *) val
+ nbytes
, type
);
803 MALLOC_UNBLOCK_INPUT
;
809 /* Free BLOCK. This must be called to free memory allocated with a
810 call to lisp_malloc. */
813 lisp_free (POINTER_TYPE
*block
)
817 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
818 mem_delete (mem_find (block
));
820 MALLOC_UNBLOCK_INPUT
;
823 /* Allocation of aligned blocks of memory to store Lisp data. */
824 /* The entry point is lisp_align_malloc which returns blocks of at most */
825 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
827 /* Use posix_memalloc if the system has it and we're using the system's
828 malloc (because our gmalloc.c routines don't have posix_memalign although
829 its memalloc could be used). */
830 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
831 #define USE_POSIX_MEMALIGN 1
834 /* BLOCK_ALIGN has to be a power of 2. */
835 #define BLOCK_ALIGN (1 << 10)
837 /* Padding to leave at the end of a malloc'd block. This is to give
838 malloc a chance to minimize the amount of memory wasted to alignment.
839 It should be tuned to the particular malloc library used.
840 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
841 posix_memalign on the other hand would ideally prefer a value of 4
842 because otherwise, there's 1020 bytes wasted between each ablocks.
843 In Emacs, testing shows that those 1020 can most of the time be
844 efficiently used by malloc to place other objects, so a value of 0 can
845 still preferable unless you have a lot of aligned blocks and virtually
847 #define BLOCK_PADDING 0
848 #define BLOCK_BYTES \
849 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
851 /* Internal data structures and constants. */
853 #define ABLOCKS_SIZE 16
855 /* An aligned block of memory. */
860 char payload
[BLOCK_BYTES
];
861 struct ablock
*next_free
;
863 /* `abase' is the aligned base of the ablocks. */
864 /* It is overloaded to hold the virtual `busy' field that counts
865 the number of used ablock in the parent ablocks.
866 The first ablock has the `busy' field, the others have the `abase'
867 field. To tell the difference, we assume that pointers will have
868 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
869 is used to tell whether the real base of the parent ablocks is `abase'
870 (if not, the word before the first ablock holds a pointer to the
872 struct ablocks
*abase
;
873 /* The padding of all but the last ablock is unused. The padding of
874 the last ablock in an ablocks is not allocated. */
876 char padding
[BLOCK_PADDING
];
880 /* A bunch of consecutive aligned blocks. */
883 struct ablock blocks
[ABLOCKS_SIZE
];
886 /* Size of the block requested from malloc or memalign. */
887 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
889 #define ABLOCK_ABASE(block) \
890 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
891 ? (struct ablocks *)(block) \
894 /* Virtual `busy' field. */
895 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
897 /* Pointer to the (not necessarily aligned) malloc block. */
898 #ifdef USE_POSIX_MEMALIGN
899 #define ABLOCKS_BASE(abase) (abase)
901 #define ABLOCKS_BASE(abase) \
902 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
905 /* The list of free ablock. */
906 static struct ablock
*free_ablock
;
908 /* Allocate an aligned block of nbytes.
909 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
910 smaller or equal to BLOCK_BYTES. */
911 static POINTER_TYPE
*
912 lisp_align_malloc (size_t nbytes
, enum mem_type type
)
915 struct ablocks
*abase
;
917 eassert (nbytes
<= BLOCK_BYTES
);
921 #ifdef GC_MALLOC_CHECK
922 allocated_mem_type
= type
;
928 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
930 #ifdef DOUG_LEA_MALLOC
931 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
932 because mapped region contents are not preserved in
934 mallopt (M_MMAP_MAX
, 0);
937 #ifdef USE_POSIX_MEMALIGN
939 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
945 base
= malloc (ABLOCKS_BYTES
);
946 abase
= ALIGN (base
, BLOCK_ALIGN
);
951 MALLOC_UNBLOCK_INPUT
;
955 aligned
= (base
== abase
);
957 ((void**)abase
)[-1] = base
;
959 #ifdef DOUG_LEA_MALLOC
960 /* Back to a reasonable maximum of mmap'ed areas. */
961 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
965 /* If the memory just allocated cannot be addressed thru a Lisp
966 object's pointer, and it needs to be, that's equivalent to
967 running out of memory. */
968 if (type
!= MEM_TYPE_NON_LISP
)
971 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
973 if ((char *) XCONS (tem
) != end
)
975 lisp_malloc_loser
= base
;
977 MALLOC_UNBLOCK_INPUT
;
983 /* Initialize the blocks and put them on the free list.
984 Is `base' was not properly aligned, we can't use the last block. */
985 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
987 abase
->blocks
[i
].abase
= abase
;
988 abase
->blocks
[i
].x
.next_free
= free_ablock
;
989 free_ablock
= &abase
->blocks
[i
];
991 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
993 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
994 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
995 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
996 eassert (ABLOCKS_BASE (abase
) == base
);
997 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1000 abase
= ABLOCK_ABASE (free_ablock
);
1001 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1003 free_ablock
= free_ablock
->x
.next_free
;
1005 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1006 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1007 mem_insert (val
, (char *) val
+ nbytes
, type
);
1010 MALLOC_UNBLOCK_INPUT
;
1014 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1019 lisp_align_free (POINTER_TYPE
*block
)
1021 struct ablock
*ablock
= block
;
1022 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1025 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1026 mem_delete (mem_find (block
));
1028 /* Put on free list. */
1029 ablock
->x
.next_free
= free_ablock
;
1030 free_ablock
= ablock
;
1031 /* Update busy count. */
1032 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1034 if (2 > (long) ABLOCKS_BUSY (abase
))
1035 { /* All the blocks are free. */
1036 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1037 struct ablock
**tem
= &free_ablock
;
1038 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1042 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1045 *tem
= (*tem
)->x
.next_free
;
1048 tem
= &(*tem
)->x
.next_free
;
1050 eassert ((aligned
& 1) == aligned
);
1051 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1052 #ifdef USE_POSIX_MEMALIGN
1053 eassert ((unsigned long)ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1055 free (ABLOCKS_BASE (abase
));
1057 MALLOC_UNBLOCK_INPUT
;
1060 /* Return a new buffer structure allocated from the heap with
1061 a call to lisp_malloc. */
1064 allocate_buffer (void)
1067 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1069 b
->size
= sizeof (struct buffer
) / sizeof (EMACS_INT
);
1070 XSETPVECTYPE (b
, PVEC_BUFFER
);
1075 #ifndef SYSTEM_MALLOC
1077 /* Arranging to disable input signals while we're in malloc.
1079 This only works with GNU malloc. To help out systems which can't
1080 use GNU malloc, all the calls to malloc, realloc, and free
1081 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1082 pair; unfortunately, we have no idea what C library functions
1083 might call malloc, so we can't really protect them unless you're
1084 using GNU malloc. Fortunately, most of the major operating systems
1085 can use GNU malloc. */
1088 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1089 there's no need to block input around malloc. */
1091 #ifndef DOUG_LEA_MALLOC
1092 extern void * (*__malloc_hook
) (size_t, const void *);
1093 extern void * (*__realloc_hook
) (void *, size_t, const void *);
1094 extern void (*__free_hook
) (void *, const void *);
1095 /* Else declared in malloc.h, perhaps with an extra arg. */
1096 #endif /* DOUG_LEA_MALLOC */
1097 static void * (*old_malloc_hook
) (size_t, const void *);
1098 static void * (*old_realloc_hook
) (void *, size_t, const void*);
1099 static void (*old_free_hook
) (void*, const void*);
1101 static __malloc_size_t bytes_used_when_reconsidered
;
1103 /* This function is used as the hook for free to call. */
1106 emacs_blocked_free (void *ptr
, const void *ptr2
)
1110 #ifdef GC_MALLOC_CHECK
1116 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1119 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1124 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1128 #endif /* GC_MALLOC_CHECK */
1130 __free_hook
= old_free_hook
;
1133 /* If we released our reserve (due to running out of memory),
1134 and we have a fair amount free once again,
1135 try to set aside another reserve in case we run out once more. */
1136 if (! NILP (Vmemory_full
)
1137 /* Verify there is enough space that even with the malloc
1138 hysteresis this call won't run out again.
1139 The code here is correct as long as SPARE_MEMORY
1140 is substantially larger than the block size malloc uses. */
1141 && (bytes_used_when_full
1142 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1143 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1144 refill_memory_reserve ();
1146 __free_hook
= emacs_blocked_free
;
1147 UNBLOCK_INPUT_ALLOC
;
1151 /* This function is the malloc hook that Emacs uses. */
1154 emacs_blocked_malloc (size_t size
, const void *ptr
)
1159 __malloc_hook
= old_malloc_hook
;
1160 #ifdef DOUG_LEA_MALLOC
1161 /* Segfaults on my system. --lorentey */
1162 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1164 __malloc_extra_blocks
= malloc_hysteresis
;
1167 value
= (void *) malloc (size
);
1169 #ifdef GC_MALLOC_CHECK
1171 struct mem_node
*m
= mem_find (value
);
1174 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1176 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1177 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1182 if (!dont_register_blocks
)
1184 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1185 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1188 #endif /* GC_MALLOC_CHECK */
1190 __malloc_hook
= emacs_blocked_malloc
;
1191 UNBLOCK_INPUT_ALLOC
;
1193 /* fprintf (stderr, "%p malloc\n", value); */
1198 /* This function is the realloc hook that Emacs uses. */
1201 emacs_blocked_realloc (void *ptr
, size_t size
, const void *ptr2
)
1206 __realloc_hook
= old_realloc_hook
;
1208 #ifdef GC_MALLOC_CHECK
1211 struct mem_node
*m
= mem_find (ptr
);
1212 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1215 "Realloc of %p which wasn't allocated with malloc\n",
1223 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1225 /* Prevent malloc from registering blocks. */
1226 dont_register_blocks
= 1;
1227 #endif /* GC_MALLOC_CHECK */
1229 value
= (void *) realloc (ptr
, size
);
1231 #ifdef GC_MALLOC_CHECK
1232 dont_register_blocks
= 0;
1235 struct mem_node
*m
= mem_find (value
);
1238 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1242 /* Can't handle zero size regions in the red-black tree. */
1243 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1246 /* fprintf (stderr, "%p <- realloc\n", value); */
1247 #endif /* GC_MALLOC_CHECK */
1249 __realloc_hook
= emacs_blocked_realloc
;
1250 UNBLOCK_INPUT_ALLOC
;
1256 #ifdef HAVE_GTK_AND_PTHREAD
1257 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1258 normal malloc. Some thread implementations need this as they call
1259 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1260 calls malloc because it is the first call, and we have an endless loop. */
1263 reset_malloc_hooks ()
1265 __free_hook
= old_free_hook
;
1266 __malloc_hook
= old_malloc_hook
;
1267 __realloc_hook
= old_realloc_hook
;
1269 #endif /* HAVE_GTK_AND_PTHREAD */
1272 /* Called from main to set up malloc to use our hooks. */
1275 uninterrupt_malloc (void)
1277 #ifdef HAVE_GTK_AND_PTHREAD
1278 #ifdef DOUG_LEA_MALLOC
1279 pthread_mutexattr_t attr
;
1281 /* GLIBC has a faster way to do this, but lets keep it portable.
1282 This is according to the Single UNIX Specification. */
1283 pthread_mutexattr_init (&attr
);
1284 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1285 pthread_mutex_init (&alloc_mutex
, &attr
);
1286 #else /* !DOUG_LEA_MALLOC */
1287 /* Some systems such as Solaris 2.6 don't have a recursive mutex,
1288 and the bundled gmalloc.c doesn't require it. */
1289 pthread_mutex_init (&alloc_mutex
, NULL
);
1290 #endif /* !DOUG_LEA_MALLOC */
1291 #endif /* HAVE_GTK_AND_PTHREAD */
1293 if (__free_hook
!= emacs_blocked_free
)
1294 old_free_hook
= __free_hook
;
1295 __free_hook
= emacs_blocked_free
;
1297 if (__malloc_hook
!= emacs_blocked_malloc
)
1298 old_malloc_hook
= __malloc_hook
;
1299 __malloc_hook
= emacs_blocked_malloc
;
1301 if (__realloc_hook
!= emacs_blocked_realloc
)
1302 old_realloc_hook
= __realloc_hook
;
1303 __realloc_hook
= emacs_blocked_realloc
;
1306 #endif /* not SYNC_INPUT */
1307 #endif /* not SYSTEM_MALLOC */
1311 /***********************************************************************
1313 ***********************************************************************/
1315 /* Number of intervals allocated in an interval_block structure.
1316 The 1020 is 1024 minus malloc overhead. */
1318 #define INTERVAL_BLOCK_SIZE \
1319 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1321 /* Intervals are allocated in chunks in form of an interval_block
1324 struct interval_block
1326 /* Place `intervals' first, to preserve alignment. */
1327 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1328 struct interval_block
*next
;
1331 /* Current interval block. Its `next' pointer points to older
1334 static struct interval_block
*interval_block
;
1336 /* Index in interval_block above of the next unused interval
1339 static int interval_block_index
;
1341 /* Number of free and live intervals. */
1343 static int total_free_intervals
, total_intervals
;
1345 /* List of free intervals. */
1347 INTERVAL interval_free_list
;
1349 /* Total number of interval blocks now in use. */
1351 static int n_interval_blocks
;
1354 /* Initialize interval allocation. */
1357 init_intervals (void)
1359 interval_block
= NULL
;
1360 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1361 interval_free_list
= 0;
1362 n_interval_blocks
= 0;
1366 /* Return a new interval. */
1369 make_interval (void)
1373 /* eassert (!handling_signal); */
1377 if (interval_free_list
)
1379 val
= interval_free_list
;
1380 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1384 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1386 register struct interval_block
*newi
;
1388 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1391 newi
->next
= interval_block
;
1392 interval_block
= newi
;
1393 interval_block_index
= 0;
1394 n_interval_blocks
++;
1396 val
= &interval_block
->intervals
[interval_block_index
++];
1399 MALLOC_UNBLOCK_INPUT
;
1401 consing_since_gc
+= sizeof (struct interval
);
1403 RESET_INTERVAL (val
);
1409 /* Mark Lisp objects in interval I. */
1412 mark_interval (register INTERVAL i
, Lisp_Object dummy
)
1414 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1416 mark_object (i
->plist
);
1420 /* Mark the interval tree rooted in TREE. Don't call this directly;
1421 use the macro MARK_INTERVAL_TREE instead. */
1424 mark_interval_tree (register INTERVAL tree
)
1426 /* No need to test if this tree has been marked already; this
1427 function is always called through the MARK_INTERVAL_TREE macro,
1428 which takes care of that. */
1430 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1434 /* Mark the interval tree rooted in I. */
1436 #define MARK_INTERVAL_TREE(i) \
1438 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1439 mark_interval_tree (i); \
1443 #define UNMARK_BALANCE_INTERVALS(i) \
1445 if (! NULL_INTERVAL_P (i)) \
1446 (i) = balance_intervals (i); \
1450 /* Number support. If USE_LISP_UNION_TYPE is in effect, we
1451 can't create number objects in macros. */
1454 make_number (EMACS_INT n
)
1458 obj
.s
.type
= Lisp_Int
;
1463 /***********************************************************************
1465 ***********************************************************************/
1467 /* Lisp_Strings are allocated in string_block structures. When a new
1468 string_block is allocated, all the Lisp_Strings it contains are
1469 added to a free-list string_free_list. When a new Lisp_String is
1470 needed, it is taken from that list. During the sweep phase of GC,
1471 string_blocks that are entirely free are freed, except two which
1474 String data is allocated from sblock structures. Strings larger
1475 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1476 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1478 Sblocks consist internally of sdata structures, one for each
1479 Lisp_String. The sdata structure points to the Lisp_String it
1480 belongs to. The Lisp_String points back to the `u.data' member of
1481 its sdata structure.
1483 When a Lisp_String is freed during GC, it is put back on
1484 string_free_list, and its `data' member and its sdata's `string'
1485 pointer is set to null. The size of the string is recorded in the
1486 `u.nbytes' member of the sdata. So, sdata structures that are no
1487 longer used, can be easily recognized, and it's easy to compact the
1488 sblocks of small strings which we do in compact_small_strings. */
1490 /* Size in bytes of an sblock structure used for small strings. This
1491 is 8192 minus malloc overhead. */
1493 #define SBLOCK_SIZE 8188
1495 /* Strings larger than this are considered large strings. String data
1496 for large strings is allocated from individual sblocks. */
1498 #define LARGE_STRING_BYTES 1024
1500 /* Structure describing string memory sub-allocated from an sblock.
1501 This is where the contents of Lisp strings are stored. */
1505 /* Back-pointer to the string this sdata belongs to. If null, this
1506 structure is free, and the NBYTES member of the union below
1507 contains the string's byte size (the same value that STRING_BYTES
1508 would return if STRING were non-null). If non-null, STRING_BYTES
1509 (STRING) is the size of the data, and DATA contains the string's
1511 struct Lisp_String
*string
;
1513 #ifdef GC_CHECK_STRING_BYTES
1516 unsigned char data
[1];
1518 #define SDATA_NBYTES(S) (S)->nbytes
1519 #define SDATA_DATA(S) (S)->data
1521 #else /* not GC_CHECK_STRING_BYTES */
1525 /* When STRING in non-null. */
1526 unsigned char data
[1];
1528 /* When STRING is null. */
1533 #define SDATA_NBYTES(S) (S)->u.nbytes
1534 #define SDATA_DATA(S) (S)->u.data
1536 #endif /* not GC_CHECK_STRING_BYTES */
1540 /* Structure describing a block of memory which is sub-allocated to
1541 obtain string data memory for strings. Blocks for small strings
1542 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1543 as large as needed. */
1548 struct sblock
*next
;
1550 /* Pointer to the next free sdata block. This points past the end
1551 of the sblock if there isn't any space left in this block. */
1552 struct sdata
*next_free
;
1554 /* Start of data. */
1555 struct sdata first_data
;
1558 /* Number of Lisp strings in a string_block structure. The 1020 is
1559 1024 minus malloc overhead. */
1561 #define STRING_BLOCK_SIZE \
1562 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1564 /* Structure describing a block from which Lisp_String structures
1569 /* Place `strings' first, to preserve alignment. */
1570 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1571 struct string_block
*next
;
1574 /* Head and tail of the list of sblock structures holding Lisp string
1575 data. We always allocate from current_sblock. The NEXT pointers
1576 in the sblock structures go from oldest_sblock to current_sblock. */
1578 static struct sblock
*oldest_sblock
, *current_sblock
;
1580 /* List of sblocks for large strings. */
1582 static struct sblock
*large_sblocks
;
1584 /* List of string_block structures, and how many there are. */
1586 static struct string_block
*string_blocks
;
1587 static int n_string_blocks
;
1589 /* Free-list of Lisp_Strings. */
1591 static struct Lisp_String
*string_free_list
;
1593 /* Number of live and free Lisp_Strings. */
1595 static int total_strings
, total_free_strings
;
1597 /* Number of bytes used by live strings. */
1599 static EMACS_INT total_string_size
;
1601 /* Given a pointer to a Lisp_String S which is on the free-list
1602 string_free_list, return a pointer to its successor in the
1605 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1607 /* Return a pointer to the sdata structure belonging to Lisp string S.
1608 S must be live, i.e. S->data must not be null. S->data is actually
1609 a pointer to the `u.data' member of its sdata structure; the
1610 structure starts at a constant offset in front of that. */
1612 #ifdef GC_CHECK_STRING_BYTES
1614 #define SDATA_OF_STRING(S) \
1615 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1616 - sizeof (EMACS_INT)))
1618 #else /* not GC_CHECK_STRING_BYTES */
1620 #define SDATA_OF_STRING(S) \
1621 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1623 #endif /* not GC_CHECK_STRING_BYTES */
1626 #ifdef GC_CHECK_STRING_OVERRUN
1628 /* We check for overrun in string data blocks by appending a small
1629 "cookie" after each allocated string data block, and check for the
1630 presence of this cookie during GC. */
1632 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1633 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1634 { 0xde, 0xad, 0xbe, 0xef };
1637 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1640 /* Value is the size of an sdata structure large enough to hold NBYTES
1641 bytes of string data. The value returned includes a terminating
1642 NUL byte, the size of the sdata structure, and padding. */
1644 #ifdef GC_CHECK_STRING_BYTES
1646 #define SDATA_SIZE(NBYTES) \
1647 ((sizeof (struct Lisp_String *) \
1649 + sizeof (EMACS_INT) \
1650 + sizeof (EMACS_INT) - 1) \
1651 & ~(sizeof (EMACS_INT) - 1))
1653 #else /* not GC_CHECK_STRING_BYTES */
1655 #define SDATA_SIZE(NBYTES) \
1656 ((sizeof (struct Lisp_String *) \
1658 + sizeof (EMACS_INT) - 1) \
1659 & ~(sizeof (EMACS_INT) - 1))
1661 #endif /* not GC_CHECK_STRING_BYTES */
1663 /* Extra bytes to allocate for each string. */
1665 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1667 /* Initialize string allocation. Called from init_alloc_once. */
1672 total_strings
= total_free_strings
= total_string_size
= 0;
1673 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1674 string_blocks
= NULL
;
1675 n_string_blocks
= 0;
1676 string_free_list
= NULL
;
1677 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1678 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1682 #ifdef GC_CHECK_STRING_BYTES
1684 static int check_string_bytes_count
;
1686 static void check_string_bytes (int);
1687 static void check_sblock (struct sblock
*);
1689 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1692 /* Like GC_STRING_BYTES, but with debugging check. */
1695 string_bytes (struct Lisp_String
*s
)
1698 (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1700 if (!PURE_POINTER_P (s
)
1702 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1707 /* Check validity of Lisp strings' string_bytes member in B. */
1713 struct sdata
*from
, *end
, *from_end
;
1717 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1719 /* Compute the next FROM here because copying below may
1720 overwrite data we need to compute it. */
1723 /* Check that the string size recorded in the string is the
1724 same as the one recorded in the sdata structure. */
1726 CHECK_STRING_BYTES (from
->string
);
1729 nbytes
= GC_STRING_BYTES (from
->string
);
1731 nbytes
= SDATA_NBYTES (from
);
1733 nbytes
= SDATA_SIZE (nbytes
);
1734 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1739 /* Check validity of Lisp strings' string_bytes member. ALL_P
1740 non-zero means check all strings, otherwise check only most
1741 recently allocated strings. Used for hunting a bug. */
1744 check_string_bytes (all_p
)
1751 for (b
= large_sblocks
; b
; b
= b
->next
)
1753 struct Lisp_String
*s
= b
->first_data
.string
;
1755 CHECK_STRING_BYTES (s
);
1758 for (b
= oldest_sblock
; b
; b
= b
->next
)
1762 check_sblock (current_sblock
);
1765 #endif /* GC_CHECK_STRING_BYTES */
1767 #ifdef GC_CHECK_STRING_FREE_LIST
1769 /* Walk through the string free list looking for bogus next pointers.
1770 This may catch buffer overrun from a previous string. */
1773 check_string_free_list ()
1775 struct Lisp_String
*s
;
1777 /* Pop a Lisp_String off the free-list. */
1778 s
= string_free_list
;
1781 if ((unsigned long)s
< 1024)
1783 s
= NEXT_FREE_LISP_STRING (s
);
1787 #define check_string_free_list()
1790 /* Return a new Lisp_String. */
1792 static struct Lisp_String
*
1793 allocate_string (void)
1795 struct Lisp_String
*s
;
1797 /* eassert (!handling_signal); */
1801 /* If the free-list is empty, allocate a new string_block, and
1802 add all the Lisp_Strings in it to the free-list. */
1803 if (string_free_list
== NULL
)
1805 struct string_block
*b
;
1808 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1809 memset (b
, 0, sizeof *b
);
1810 b
->next
= string_blocks
;
1814 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1817 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1818 string_free_list
= s
;
1821 total_free_strings
+= STRING_BLOCK_SIZE
;
1824 check_string_free_list ();
1826 /* Pop a Lisp_String off the free-list. */
1827 s
= string_free_list
;
1828 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1830 MALLOC_UNBLOCK_INPUT
;
1832 /* Probably not strictly necessary, but play it safe. */
1833 memset (s
, 0, sizeof *s
);
1835 --total_free_strings
;
1838 consing_since_gc
+= sizeof *s
;
1840 #ifdef GC_CHECK_STRING_BYTES
1841 if (!noninteractive
)
1843 if (++check_string_bytes_count
== 200)
1845 check_string_bytes_count
= 0;
1846 check_string_bytes (1);
1849 check_string_bytes (0);
1851 #endif /* GC_CHECK_STRING_BYTES */
1857 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1858 plus a NUL byte at the end. Allocate an sdata structure for S, and
1859 set S->data to its `u.data' member. Store a NUL byte at the end of
1860 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1861 S->data if it was initially non-null. */
1864 allocate_string_data (struct Lisp_String
*s
,
1865 EMACS_INT nchars
, EMACS_INT nbytes
)
1867 struct sdata
*data
, *old_data
;
1869 EMACS_INT needed
, old_nbytes
;
1871 /* Determine the number of bytes needed to store NBYTES bytes
1873 needed
= SDATA_SIZE (nbytes
);
1874 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1875 old_nbytes
= GC_STRING_BYTES (s
);
1879 if (nbytes
> LARGE_STRING_BYTES
)
1881 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1883 #ifdef DOUG_LEA_MALLOC
1884 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1885 because mapped region contents are not preserved in
1888 In case you think of allowing it in a dumped Emacs at the
1889 cost of not being able to re-dump, there's another reason:
1890 mmap'ed data typically have an address towards the top of the
1891 address space, which won't fit into an EMACS_INT (at least on
1892 32-bit systems with the current tagging scheme). --fx */
1893 mallopt (M_MMAP_MAX
, 0);
1896 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1898 #ifdef DOUG_LEA_MALLOC
1899 /* Back to a reasonable maximum of mmap'ed areas. */
1900 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1903 b
->next_free
= &b
->first_data
;
1904 b
->first_data
.string
= NULL
;
1905 b
->next
= large_sblocks
;
1908 else if (current_sblock
== NULL
1909 || (((char *) current_sblock
+ SBLOCK_SIZE
1910 - (char *) current_sblock
->next_free
)
1911 < (needed
+ GC_STRING_EXTRA
)))
1913 /* Not enough room in the current sblock. */
1914 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
1915 b
->next_free
= &b
->first_data
;
1916 b
->first_data
.string
= NULL
;
1920 current_sblock
->next
= b
;
1928 data
= b
->next_free
;
1929 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
1931 MALLOC_UNBLOCK_INPUT
;
1934 s
->data
= SDATA_DATA (data
);
1935 #ifdef GC_CHECK_STRING_BYTES
1936 SDATA_NBYTES (data
) = nbytes
;
1939 s
->size_byte
= nbytes
;
1940 s
->data
[nbytes
] = '\0';
1941 #ifdef GC_CHECK_STRING_OVERRUN
1942 memcpy (data
+ needed
, string_overrun_cookie
, GC_STRING_OVERRUN_COOKIE_SIZE
);
1945 /* If S had already data assigned, mark that as free by setting its
1946 string back-pointer to null, and recording the size of the data
1950 SDATA_NBYTES (old_data
) = old_nbytes
;
1951 old_data
->string
= NULL
;
1954 consing_since_gc
+= needed
;
1958 /* Sweep and compact strings. */
1961 sweep_strings (void)
1963 struct string_block
*b
, *next
;
1964 struct string_block
*live_blocks
= NULL
;
1966 string_free_list
= NULL
;
1967 total_strings
= total_free_strings
= 0;
1968 total_string_size
= 0;
1970 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
1971 for (b
= string_blocks
; b
; b
= next
)
1974 struct Lisp_String
*free_list_before
= string_free_list
;
1978 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
1980 struct Lisp_String
*s
= b
->strings
+ i
;
1984 /* String was not on free-list before. */
1985 if (STRING_MARKED_P (s
))
1987 /* String is live; unmark it and its intervals. */
1990 if (!NULL_INTERVAL_P (s
->intervals
))
1991 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1994 total_string_size
+= STRING_BYTES (s
);
1998 /* String is dead. Put it on the free-list. */
1999 struct sdata
*data
= SDATA_OF_STRING (s
);
2001 /* Save the size of S in its sdata so that we know
2002 how large that is. Reset the sdata's string
2003 back-pointer so that we know it's free. */
2004 #ifdef GC_CHECK_STRING_BYTES
2005 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2008 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2010 data
->string
= NULL
;
2012 /* Reset the strings's `data' member so that we
2016 /* Put the string on the free-list. */
2017 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2018 string_free_list
= s
;
2024 /* S was on the free-list before. Put it there again. */
2025 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2026 string_free_list
= s
;
2031 /* Free blocks that contain free Lisp_Strings only, except
2032 the first two of them. */
2033 if (nfree
== STRING_BLOCK_SIZE
2034 && total_free_strings
> STRING_BLOCK_SIZE
)
2038 string_free_list
= free_list_before
;
2042 total_free_strings
+= nfree
;
2043 b
->next
= live_blocks
;
2048 check_string_free_list ();
2050 string_blocks
= live_blocks
;
2051 free_large_strings ();
2052 compact_small_strings ();
2054 check_string_free_list ();
2058 /* Free dead large strings. */
2061 free_large_strings (void)
2063 struct sblock
*b
, *next
;
2064 struct sblock
*live_blocks
= NULL
;
2066 for (b
= large_sblocks
; b
; b
= next
)
2070 if (b
->first_data
.string
== NULL
)
2074 b
->next
= live_blocks
;
2079 large_sblocks
= live_blocks
;
2083 /* Compact data of small strings. Free sblocks that don't contain
2084 data of live strings after compaction. */
2087 compact_small_strings (void)
2089 struct sblock
*b
, *tb
, *next
;
2090 struct sdata
*from
, *to
, *end
, *tb_end
;
2091 struct sdata
*to_end
, *from_end
;
2093 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2094 to, and TB_END is the end of TB. */
2096 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2097 to
= &tb
->first_data
;
2099 /* Step through the blocks from the oldest to the youngest. We
2100 expect that old blocks will stabilize over time, so that less
2101 copying will happen this way. */
2102 for (b
= oldest_sblock
; b
; b
= b
->next
)
2105 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2107 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2109 /* Compute the next FROM here because copying below may
2110 overwrite data we need to compute it. */
2113 #ifdef GC_CHECK_STRING_BYTES
2114 /* Check that the string size recorded in the string is the
2115 same as the one recorded in the sdata structure. */
2117 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2119 #endif /* GC_CHECK_STRING_BYTES */
2122 nbytes
= GC_STRING_BYTES (from
->string
);
2124 nbytes
= SDATA_NBYTES (from
);
2126 if (nbytes
> LARGE_STRING_BYTES
)
2129 nbytes
= SDATA_SIZE (nbytes
);
2130 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2132 #ifdef GC_CHECK_STRING_OVERRUN
2133 if (memcmp (string_overrun_cookie
,
2134 (char *) from_end
- GC_STRING_OVERRUN_COOKIE_SIZE
,
2135 GC_STRING_OVERRUN_COOKIE_SIZE
))
2139 /* FROM->string non-null means it's alive. Copy its data. */
2142 /* If TB is full, proceed with the next sblock. */
2143 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2144 if (to_end
> tb_end
)
2148 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2149 to
= &tb
->first_data
;
2150 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2153 /* Copy, and update the string's `data' pointer. */
2156 xassert (tb
!= b
|| to
<= from
);
2157 memmove (to
, from
, nbytes
+ GC_STRING_EXTRA
);
2158 to
->string
->data
= SDATA_DATA (to
);
2161 /* Advance past the sdata we copied to. */
2167 /* The rest of the sblocks following TB don't contain live data, so
2168 we can free them. */
2169 for (b
= tb
->next
; b
; b
= next
)
2177 current_sblock
= tb
;
2181 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2182 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2183 LENGTH must be an integer.
2184 INIT must be an integer that represents a character. */)
2185 (Lisp_Object length
, Lisp_Object init
)
2187 register Lisp_Object val
;
2188 register unsigned char *p
, *end
;
2192 CHECK_NATNUM (length
);
2193 CHECK_NUMBER (init
);
2196 if (ASCII_CHAR_P (c
))
2198 nbytes
= XINT (length
);
2199 val
= make_uninit_string (nbytes
);
2201 end
= p
+ SCHARS (val
);
2207 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2208 int len
= CHAR_STRING (c
, str
);
2209 EMACS_INT string_len
= XINT (length
);
2211 if (string_len
> MOST_POSITIVE_FIXNUM
/ len
)
2212 error ("Maximum string size exceeded");
2213 nbytes
= len
* string_len
;
2214 val
= make_uninit_multibyte_string (string_len
, nbytes
);
2219 memcpy (p
, str
, len
);
2229 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2230 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2231 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2232 (Lisp_Object length
, Lisp_Object init
)
2234 register Lisp_Object val
;
2235 struct Lisp_Bool_Vector
*p
;
2237 EMACS_INT length_in_chars
, length_in_elts
;
2240 CHECK_NATNUM (length
);
2242 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2244 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2245 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2246 / BOOL_VECTOR_BITS_PER_CHAR
);
2248 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2249 slot `size' of the struct Lisp_Bool_Vector. */
2250 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2252 /* Get rid of any bits that would cause confusion. */
2253 XVECTOR (val
)->size
= 0; /* No Lisp_Object to trace in there. */
2254 /* Use XVECTOR (val) rather than `p' because p->size is not TRT. */
2255 XSETPVECTYPE (XVECTOR (val
), PVEC_BOOL_VECTOR
);
2257 p
= XBOOL_VECTOR (val
);
2258 p
->size
= XFASTINT (length
);
2260 real_init
= (NILP (init
) ? 0 : -1);
2261 for (i
= 0; i
< length_in_chars
; i
++)
2262 p
->data
[i
] = real_init
;
2264 /* Clear the extraneous bits in the last byte. */
2265 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2266 p
->data
[length_in_chars
- 1]
2267 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2273 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2274 of characters from the contents. This string may be unibyte or
2275 multibyte, depending on the contents. */
2278 make_string (const char *contents
, EMACS_INT nbytes
)
2280 register Lisp_Object val
;
2281 EMACS_INT nchars
, multibyte_nbytes
;
2283 parse_str_as_multibyte ((const unsigned char *) contents
, nbytes
,
2284 &nchars
, &multibyte_nbytes
);
2285 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2286 /* CONTENTS contains no multibyte sequences or contains an invalid
2287 multibyte sequence. We must make unibyte string. */
2288 val
= make_unibyte_string (contents
, nbytes
);
2290 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2295 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2298 make_unibyte_string (const char *contents
, EMACS_INT length
)
2300 register Lisp_Object val
;
2301 val
= make_uninit_string (length
);
2302 memcpy (SDATA (val
), contents
, length
);
2307 /* Make a multibyte string from NCHARS characters occupying NBYTES
2308 bytes at CONTENTS. */
2311 make_multibyte_string (const char *contents
,
2312 EMACS_INT nchars
, EMACS_INT nbytes
)
2314 register Lisp_Object val
;
2315 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2316 memcpy (SDATA (val
), contents
, nbytes
);
2321 /* Make a string from NCHARS characters occupying NBYTES bytes at
2322 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2325 make_string_from_bytes (const char *contents
,
2326 EMACS_INT nchars
, EMACS_INT nbytes
)
2328 register Lisp_Object val
;
2329 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2330 memcpy (SDATA (val
), contents
, nbytes
);
2331 if (SBYTES (val
) == SCHARS (val
))
2332 STRING_SET_UNIBYTE (val
);
2337 /* Make a string from NCHARS characters occupying NBYTES bytes at
2338 CONTENTS. The argument MULTIBYTE controls whether to label the
2339 string as multibyte. If NCHARS is negative, it counts the number of
2340 characters by itself. */
2343 make_specified_string (const char *contents
,
2344 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
2346 register Lisp_Object val
;
2351 nchars
= multibyte_chars_in_text ((const unsigned char *) contents
,
2356 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2357 memcpy (SDATA (val
), contents
, nbytes
);
2359 STRING_SET_UNIBYTE (val
);
2364 /* Make a string from the data at STR, treating it as multibyte if the
2368 build_string (const char *str
)
2370 return make_string (str
, strlen (str
));
2374 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2375 occupying LENGTH bytes. */
2378 make_uninit_string (EMACS_INT length
)
2383 return empty_unibyte_string
;
2384 val
= make_uninit_multibyte_string (length
, length
);
2385 STRING_SET_UNIBYTE (val
);
2390 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2391 which occupy NBYTES bytes. */
2394 make_uninit_multibyte_string (EMACS_INT nchars
, EMACS_INT nbytes
)
2397 struct Lisp_String
*s
;
2402 return empty_multibyte_string
;
2404 s
= allocate_string ();
2405 allocate_string_data (s
, nchars
, nbytes
);
2406 XSETSTRING (string
, s
);
2407 string_chars_consed
+= nbytes
;
2413 /***********************************************************************
2415 ***********************************************************************/
2417 /* We store float cells inside of float_blocks, allocating a new
2418 float_block with malloc whenever necessary. Float cells reclaimed
2419 by GC are put on a free list to be reallocated before allocating
2420 any new float cells from the latest float_block. */
2422 #define FLOAT_BLOCK_SIZE \
2423 (((BLOCK_BYTES - sizeof (struct float_block *) \
2424 /* The compiler might add padding at the end. */ \
2425 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2426 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2428 #define GETMARKBIT(block,n) \
2429 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2430 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2433 #define SETMARKBIT(block,n) \
2434 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2435 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2437 #define UNSETMARKBIT(block,n) \
2438 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2439 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2441 #define FLOAT_BLOCK(fptr) \
2442 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2444 #define FLOAT_INDEX(fptr) \
2445 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2449 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2450 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2451 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2452 struct float_block
*next
;
2455 #define FLOAT_MARKED_P(fptr) \
2456 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2458 #define FLOAT_MARK(fptr) \
2459 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2461 #define FLOAT_UNMARK(fptr) \
2462 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2464 /* Current float_block. */
2466 struct float_block
*float_block
;
2468 /* Index of first unused Lisp_Float in the current float_block. */
2470 int float_block_index
;
2472 /* Total number of float blocks now in use. */
2476 /* Free-list of Lisp_Floats. */
2478 struct Lisp_Float
*float_free_list
;
2481 /* Initialize float allocation. */
2487 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2488 float_free_list
= 0;
2493 /* Return a new float object with value FLOAT_VALUE. */
2496 make_float (double float_value
)
2498 register Lisp_Object val
;
2500 /* eassert (!handling_signal); */
2504 if (float_free_list
)
2506 /* We use the data field for chaining the free list
2507 so that we won't use the same field that has the mark bit. */
2508 XSETFLOAT (val
, float_free_list
);
2509 float_free_list
= float_free_list
->u
.chain
;
2513 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2515 register struct float_block
*new;
2517 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2519 new->next
= float_block
;
2520 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2522 float_block_index
= 0;
2525 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2526 float_block_index
++;
2529 MALLOC_UNBLOCK_INPUT
;
2531 XFLOAT_INIT (val
, float_value
);
2532 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2533 consing_since_gc
+= sizeof (struct Lisp_Float
);
2540 /***********************************************************************
2542 ***********************************************************************/
2544 /* We store cons cells inside of cons_blocks, allocating a new
2545 cons_block with malloc whenever necessary. Cons cells reclaimed by
2546 GC are put on a free list to be reallocated before allocating
2547 any new cons cells from the latest cons_block. */
2549 #define CONS_BLOCK_SIZE \
2550 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2551 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2553 #define CONS_BLOCK(fptr) \
2554 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2556 #define CONS_INDEX(fptr) \
2557 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2561 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2562 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2563 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2564 struct cons_block
*next
;
2567 #define CONS_MARKED_P(fptr) \
2568 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2570 #define CONS_MARK(fptr) \
2571 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2573 #define CONS_UNMARK(fptr) \
2574 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2576 /* Current cons_block. */
2578 struct cons_block
*cons_block
;
2580 /* Index of first unused Lisp_Cons in the current block. */
2582 int cons_block_index
;
2584 /* Free-list of Lisp_Cons structures. */
2586 struct Lisp_Cons
*cons_free_list
;
2588 /* Total number of cons blocks now in use. */
2590 static int n_cons_blocks
;
2593 /* Initialize cons allocation. */
2599 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2605 /* Explicitly free a cons cell by putting it on the free-list. */
2608 free_cons (struct Lisp_Cons
*ptr
)
2610 ptr
->u
.chain
= cons_free_list
;
2614 cons_free_list
= ptr
;
2617 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2618 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2619 (Lisp_Object car
, Lisp_Object cdr
)
2621 register Lisp_Object val
;
2623 /* eassert (!handling_signal); */
2629 /* We use the cdr for chaining the free list
2630 so that we won't use the same field that has the mark bit. */
2631 XSETCONS (val
, cons_free_list
);
2632 cons_free_list
= cons_free_list
->u
.chain
;
2636 if (cons_block_index
== CONS_BLOCK_SIZE
)
2638 register struct cons_block
*new;
2639 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2641 memset (new->gcmarkbits
, 0, sizeof new->gcmarkbits
);
2642 new->next
= cons_block
;
2644 cons_block_index
= 0;
2647 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2651 MALLOC_UNBLOCK_INPUT
;
2655 eassert (!CONS_MARKED_P (XCONS (val
)));
2656 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2657 cons_cells_consed
++;
2661 /* Get an error now if there's any junk in the cons free list. */
2663 check_cons_list (void)
2665 #ifdef GC_CHECK_CONS_LIST
2666 struct Lisp_Cons
*tail
= cons_free_list
;
2669 tail
= tail
->u
.chain
;
2673 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2676 list1 (Lisp_Object arg1
)
2678 return Fcons (arg1
, Qnil
);
2682 list2 (Lisp_Object arg1
, Lisp_Object arg2
)
2684 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2689 list3 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
)
2691 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2696 list4 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
)
2698 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2703 list5 (Lisp_Object arg1
, Lisp_Object arg2
, Lisp_Object arg3
, Lisp_Object arg4
, Lisp_Object arg5
)
2705 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2706 Fcons (arg5
, Qnil
)))));
2710 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2711 doc
: /* Return a newly created list with specified arguments as elements.
2712 Any number of arguments, even zero arguments, are allowed.
2713 usage: (list &rest OBJECTS) */)
2714 (int nargs
, register Lisp_Object
*args
)
2716 register Lisp_Object val
;
2722 val
= Fcons (args
[nargs
], val
);
2728 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2729 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2730 (register Lisp_Object length
, Lisp_Object init
)
2732 register Lisp_Object val
;
2733 register EMACS_INT size
;
2735 CHECK_NATNUM (length
);
2736 size
= XFASTINT (length
);
2741 val
= Fcons (init
, val
);
2746 val
= Fcons (init
, val
);
2751 val
= Fcons (init
, val
);
2756 val
= Fcons (init
, val
);
2761 val
= Fcons (init
, val
);
2776 /***********************************************************************
2778 ***********************************************************************/
2780 /* Singly-linked list of all vectors. */
2782 static struct Lisp_Vector
*all_vectors
;
2784 /* Total number of vector-like objects now in use. */
2786 static int n_vectors
;
2789 /* Value is a pointer to a newly allocated Lisp_Vector structure
2790 with room for LEN Lisp_Objects. */
2792 static struct Lisp_Vector
*
2793 allocate_vectorlike (EMACS_INT len
)
2795 struct Lisp_Vector
*p
;
2800 #ifdef DOUG_LEA_MALLOC
2801 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2802 because mapped region contents are not preserved in
2804 mallopt (M_MMAP_MAX
, 0);
2807 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2808 /* eassert (!handling_signal); */
2810 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2811 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, MEM_TYPE_VECTORLIKE
);
2813 #ifdef DOUG_LEA_MALLOC
2814 /* Back to a reasonable maximum of mmap'ed areas. */
2815 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2818 consing_since_gc
+= nbytes
;
2819 vector_cells_consed
+= len
;
2821 p
->next
= all_vectors
;
2824 MALLOC_UNBLOCK_INPUT
;
2831 /* Allocate a vector with NSLOTS slots. */
2833 struct Lisp_Vector
*
2834 allocate_vector (EMACS_INT nslots
)
2836 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
);
2842 /* Allocate other vector-like structures. */
2844 struct Lisp_Vector
*
2845 allocate_pseudovector (int memlen
, int lisplen
, EMACS_INT tag
)
2847 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
);
2850 /* Only the first lisplen slots will be traced normally by the GC. */
2852 for (i
= 0; i
< lisplen
; ++i
)
2853 v
->contents
[i
] = Qnil
;
2855 XSETPVECTYPE (v
, tag
); /* Add the appropriate tag. */
2859 struct Lisp_Hash_Table
*
2860 allocate_hash_table (void)
2862 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table
, count
, PVEC_HASH_TABLE
);
2867 allocate_window (void)
2869 return ALLOCATE_PSEUDOVECTOR(struct window
, current_matrix
, PVEC_WINDOW
);
2874 allocate_terminal (void)
2876 struct terminal
*t
= ALLOCATE_PSEUDOVECTOR (struct terminal
,
2877 next_terminal
, PVEC_TERMINAL
);
2878 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
2879 memset (&t
->next_terminal
, 0,
2880 (char*) (t
+ 1) - (char*) &t
->next_terminal
);
2886 allocate_frame (void)
2888 struct frame
*f
= ALLOCATE_PSEUDOVECTOR (struct frame
,
2889 face_cache
, PVEC_FRAME
);
2890 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
2891 memset (&f
->face_cache
, 0,
2892 (char *) (f
+ 1) - (char *) &f
->face_cache
);
2897 struct Lisp_Process
*
2898 allocate_process (void)
2900 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process
, pid
, PVEC_PROCESS
);
2904 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
2905 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
2906 See also the function `vector'. */)
2907 (register Lisp_Object length
, Lisp_Object init
)
2910 register EMACS_INT sizei
;
2911 register EMACS_INT index
;
2912 register struct Lisp_Vector
*p
;
2914 CHECK_NATNUM (length
);
2915 sizei
= XFASTINT (length
);
2917 p
= allocate_vector (sizei
);
2918 for (index
= 0; index
< sizei
; index
++)
2919 p
->contents
[index
] = init
;
2921 XSETVECTOR (vector
, p
);
2926 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
2927 doc
: /* Return a newly created vector with specified arguments as elements.
2928 Any number of arguments, even zero arguments, are allowed.
2929 usage: (vector &rest OBJECTS) */)
2930 (register int nargs
, Lisp_Object
*args
)
2932 register Lisp_Object len
, val
;
2934 register struct Lisp_Vector
*p
;
2936 XSETFASTINT (len
, nargs
);
2937 val
= Fmake_vector (len
, Qnil
);
2939 for (index
= 0; index
< nargs
; index
++)
2940 p
->contents
[index
] = args
[index
];
2945 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
2946 doc
: /* Create a byte-code object with specified arguments as elements.
2947 The arguments should be the arglist, bytecode-string, constant vector,
2948 stack size, (optional) doc string, and (optional) interactive spec.
2949 The first four arguments are required; at most six have any
2951 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
2952 (register int nargs
, Lisp_Object
*args
)
2954 register Lisp_Object len
, val
;
2956 register struct Lisp_Vector
*p
;
2958 XSETFASTINT (len
, nargs
);
2959 if (!NILP (Vpurify_flag
))
2960 val
= make_pure_vector ((EMACS_INT
) nargs
);
2962 val
= Fmake_vector (len
, Qnil
);
2964 if (nargs
> 1 && STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
2965 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
2966 earlier because they produced a raw 8-bit string for byte-code
2967 and now such a byte-code string is loaded as multibyte while
2968 raw 8-bit characters converted to multibyte form. Thus, now we
2969 must convert them back to the original unibyte form. */
2970 args
[1] = Fstring_as_unibyte (args
[1]);
2973 for (index
= 0; index
< nargs
; index
++)
2975 if (!NILP (Vpurify_flag
))
2976 args
[index
] = Fpurecopy (args
[index
]);
2977 p
->contents
[index
] = args
[index
];
2979 XSETPVECTYPE (p
, PVEC_COMPILED
);
2980 XSETCOMPILED (val
, p
);
2986 /***********************************************************************
2988 ***********************************************************************/
2990 /* Each symbol_block is just under 1020 bytes long, since malloc
2991 really allocates in units of powers of two and uses 4 bytes for its
2994 #define SYMBOL_BLOCK_SIZE \
2995 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
2999 /* Place `symbols' first, to preserve alignment. */
3000 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3001 struct symbol_block
*next
;
3004 /* Current symbol block and index of first unused Lisp_Symbol
3007 static struct symbol_block
*symbol_block
;
3008 static int symbol_block_index
;
3010 /* List of free symbols. */
3012 static struct Lisp_Symbol
*symbol_free_list
;
3014 /* Total number of symbol blocks now in use. */
3016 static int n_symbol_blocks
;
3019 /* Initialize symbol allocation. */
3024 symbol_block
= NULL
;
3025 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3026 symbol_free_list
= 0;
3027 n_symbol_blocks
= 0;
3031 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3032 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3033 Its value and function definition are void, and its property list is nil. */)
3036 register Lisp_Object val
;
3037 register struct Lisp_Symbol
*p
;
3039 CHECK_STRING (name
);
3041 /* eassert (!handling_signal); */
3045 if (symbol_free_list
)
3047 XSETSYMBOL (val
, symbol_free_list
);
3048 symbol_free_list
= symbol_free_list
->next
;
3052 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3054 struct symbol_block
*new;
3055 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3057 new->next
= symbol_block
;
3059 symbol_block_index
= 0;
3062 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3063 symbol_block_index
++;
3066 MALLOC_UNBLOCK_INPUT
;
3071 p
->redirect
= SYMBOL_PLAINVAL
;
3072 SET_SYMBOL_VAL (p
, Qunbound
);
3073 p
->function
= Qunbound
;
3076 p
->interned
= SYMBOL_UNINTERNED
;
3078 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3085 /***********************************************************************
3086 Marker (Misc) Allocation
3087 ***********************************************************************/
3089 /* Allocation of markers and other objects that share that structure.
3090 Works like allocation of conses. */
3092 #define MARKER_BLOCK_SIZE \
3093 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3097 /* Place `markers' first, to preserve alignment. */
3098 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3099 struct marker_block
*next
;
3102 static struct marker_block
*marker_block
;
3103 static int marker_block_index
;
3105 static union Lisp_Misc
*marker_free_list
;
3107 /* Total number of marker blocks now in use. */
3109 static int n_marker_blocks
;
3114 marker_block
= NULL
;
3115 marker_block_index
= MARKER_BLOCK_SIZE
;
3116 marker_free_list
= 0;
3117 n_marker_blocks
= 0;
3120 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3123 allocate_misc (void)
3127 /* eassert (!handling_signal); */
3131 if (marker_free_list
)
3133 XSETMISC (val
, marker_free_list
);
3134 marker_free_list
= marker_free_list
->u_free
.chain
;
3138 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3140 struct marker_block
*new;
3141 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3143 new->next
= marker_block
;
3145 marker_block_index
= 0;
3147 total_free_markers
+= MARKER_BLOCK_SIZE
;
3149 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3150 marker_block_index
++;
3153 MALLOC_UNBLOCK_INPUT
;
3155 --total_free_markers
;
3156 consing_since_gc
+= sizeof (union Lisp_Misc
);
3157 misc_objects_consed
++;
3158 XMISCANY (val
)->gcmarkbit
= 0;
3162 /* Free a Lisp_Misc object */
3165 free_misc (Lisp_Object misc
)
3167 XMISCTYPE (misc
) = Lisp_Misc_Free
;
3168 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3169 marker_free_list
= XMISC (misc
);
3171 total_free_markers
++;
3174 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3175 INTEGER. This is used to package C values to call record_unwind_protect.
3176 The unwind function can get the C values back using XSAVE_VALUE. */
3179 make_save_value (void *pointer
, int integer
)
3181 register Lisp_Object val
;
3182 register struct Lisp_Save_Value
*p
;
3184 val
= allocate_misc ();
3185 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3186 p
= XSAVE_VALUE (val
);
3187 p
->pointer
= pointer
;
3188 p
->integer
= integer
;
3193 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3194 doc
: /* Return a newly allocated marker which does not point at any place. */)
3197 register Lisp_Object val
;
3198 register struct Lisp_Marker
*p
;
3200 val
= allocate_misc ();
3201 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3207 p
->insertion_type
= 0;
3211 /* Put MARKER back on the free list after using it temporarily. */
3214 free_marker (Lisp_Object marker
)
3216 unchain_marker (XMARKER (marker
));
3221 /* Return a newly created vector or string with specified arguments as
3222 elements. If all the arguments are characters that can fit
3223 in a string of events, make a string; otherwise, make a vector.
3225 Any number of arguments, even zero arguments, are allowed. */
3228 make_event_array (register int nargs
, Lisp_Object
*args
)
3232 for (i
= 0; i
< nargs
; i
++)
3233 /* The things that fit in a string
3234 are characters that are in 0...127,
3235 after discarding the meta bit and all the bits above it. */
3236 if (!INTEGERP (args
[i
])
3237 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3238 return Fvector (nargs
, args
);
3240 /* Since the loop exited, we know that all the things in it are
3241 characters, so we can make a string. */
3245 result
= Fmake_string (make_number (nargs
), make_number (0));
3246 for (i
= 0; i
< nargs
; i
++)
3248 SSET (result
, i
, XINT (args
[i
]));
3249 /* Move the meta bit to the right place for a string char. */
3250 if (XINT (args
[i
]) & CHAR_META
)
3251 SSET (result
, i
, SREF (result
, i
) | 0x80);
3260 /************************************************************************
3261 Memory Full Handling
3262 ************************************************************************/
3265 /* Called if malloc returns zero. */
3274 memory_full_cons_threshold
= sizeof (struct cons_block
);
3276 /* The first time we get here, free the spare memory. */
3277 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3278 if (spare_memory
[i
])
3281 free (spare_memory
[i
]);
3282 else if (i
>= 1 && i
<= 4)
3283 lisp_align_free (spare_memory
[i
]);
3285 lisp_free (spare_memory
[i
]);
3286 spare_memory
[i
] = 0;
3289 /* Record the space now used. When it decreases substantially,
3290 we can refill the memory reserve. */
3291 #ifndef SYSTEM_MALLOC
3292 bytes_used_when_full
= BYTES_USED
;
3295 /* This used to call error, but if we've run out of memory, we could
3296 get infinite recursion trying to build the string. */
3297 xsignal (Qnil
, Vmemory_signal_data
);
3300 /* If we released our reserve (due to running out of memory),
3301 and we have a fair amount free once again,
3302 try to set aside another reserve in case we run out once more.
3304 This is called when a relocatable block is freed in ralloc.c,
3305 and also directly from this file, in case we're not using ralloc.c. */
3308 refill_memory_reserve (void)
3310 #ifndef SYSTEM_MALLOC
3311 if (spare_memory
[0] == 0)
3312 spare_memory
[0] = (char *) malloc ((size_t) SPARE_MEMORY
);
3313 if (spare_memory
[1] == 0)
3314 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3316 if (spare_memory
[2] == 0)
3317 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3319 if (spare_memory
[3] == 0)
3320 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3322 if (spare_memory
[4] == 0)
3323 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3325 if (spare_memory
[5] == 0)
3326 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3328 if (spare_memory
[6] == 0)
3329 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3331 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3332 Vmemory_full
= Qnil
;
3336 /************************************************************************
3338 ************************************************************************/
3340 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3342 /* Conservative C stack marking requires a method to identify possibly
3343 live Lisp objects given a pointer value. We do this by keeping
3344 track of blocks of Lisp data that are allocated in a red-black tree
3345 (see also the comment of mem_node which is the type of nodes in
3346 that tree). Function lisp_malloc adds information for an allocated
3347 block to the red-black tree with calls to mem_insert, and function
3348 lisp_free removes it with mem_delete. Functions live_string_p etc
3349 call mem_find to lookup information about a given pointer in the
3350 tree, and use that to determine if the pointer points to a Lisp
3353 /* Initialize this part of alloc.c. */
3358 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3359 mem_z
.parent
= NULL
;
3360 mem_z
.color
= MEM_BLACK
;
3361 mem_z
.start
= mem_z
.end
= NULL
;
3366 /* Value is a pointer to the mem_node containing START. Value is
3367 MEM_NIL if there is no node in the tree containing START. */
3369 static INLINE
struct mem_node
*
3370 mem_find (void *start
)
3374 if (start
< min_heap_address
|| start
> max_heap_address
)
3377 /* Make the search always successful to speed up the loop below. */
3378 mem_z
.start
= start
;
3379 mem_z
.end
= (char *) start
+ 1;
3382 while (start
< p
->start
|| start
>= p
->end
)
3383 p
= start
< p
->start
? p
->left
: p
->right
;
3388 /* Insert a new node into the tree for a block of memory with start
3389 address START, end address END, and type TYPE. Value is a
3390 pointer to the node that was inserted. */
3392 static struct mem_node
*
3393 mem_insert (void *start
, void *end
, enum mem_type type
)
3395 struct mem_node
*c
, *parent
, *x
;
3397 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3398 min_heap_address
= start
;
3399 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3400 max_heap_address
= end
;
3402 /* See where in the tree a node for START belongs. In this
3403 particular application, it shouldn't happen that a node is already
3404 present. For debugging purposes, let's check that. */
3408 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3410 while (c
!= MEM_NIL
)
3412 if (start
>= c
->start
&& start
< c
->end
)
3415 c
= start
< c
->start
? c
->left
: c
->right
;
3418 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3420 while (c
!= MEM_NIL
)
3423 c
= start
< c
->start
? c
->left
: c
->right
;
3426 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3428 /* Create a new node. */
3429 #ifdef GC_MALLOC_CHECK
3430 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3434 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3440 x
->left
= x
->right
= MEM_NIL
;
3443 /* Insert it as child of PARENT or install it as root. */
3446 if (start
< parent
->start
)
3454 /* Re-establish red-black tree properties. */
3455 mem_insert_fixup (x
);
3461 /* Re-establish the red-black properties of the tree, and thereby
3462 balance the tree, after node X has been inserted; X is always red. */
3465 mem_insert_fixup (struct mem_node
*x
)
3467 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3469 /* X is red and its parent is red. This is a violation of
3470 red-black tree property #3. */
3472 if (x
->parent
== x
->parent
->parent
->left
)
3474 /* We're on the left side of our grandparent, and Y is our
3476 struct mem_node
*y
= x
->parent
->parent
->right
;
3478 if (y
->color
== MEM_RED
)
3480 /* Uncle and parent are red but should be black because
3481 X is red. Change the colors accordingly and proceed
3482 with the grandparent. */
3483 x
->parent
->color
= MEM_BLACK
;
3484 y
->color
= MEM_BLACK
;
3485 x
->parent
->parent
->color
= MEM_RED
;
3486 x
= x
->parent
->parent
;
3490 /* Parent and uncle have different colors; parent is
3491 red, uncle is black. */
3492 if (x
== x
->parent
->right
)
3495 mem_rotate_left (x
);
3498 x
->parent
->color
= MEM_BLACK
;
3499 x
->parent
->parent
->color
= MEM_RED
;
3500 mem_rotate_right (x
->parent
->parent
);
3505 /* This is the symmetrical case of above. */
3506 struct mem_node
*y
= x
->parent
->parent
->left
;
3508 if (y
->color
== MEM_RED
)
3510 x
->parent
->color
= MEM_BLACK
;
3511 y
->color
= MEM_BLACK
;
3512 x
->parent
->parent
->color
= MEM_RED
;
3513 x
= x
->parent
->parent
;
3517 if (x
== x
->parent
->left
)
3520 mem_rotate_right (x
);
3523 x
->parent
->color
= MEM_BLACK
;
3524 x
->parent
->parent
->color
= MEM_RED
;
3525 mem_rotate_left (x
->parent
->parent
);
3530 /* The root may have been changed to red due to the algorithm. Set
3531 it to black so that property #5 is satisfied. */
3532 mem_root
->color
= MEM_BLACK
;
3543 mem_rotate_left (struct mem_node
*x
)
3547 /* Turn y's left sub-tree into x's right sub-tree. */
3550 if (y
->left
!= MEM_NIL
)
3551 y
->left
->parent
= x
;
3553 /* Y's parent was x's parent. */
3555 y
->parent
= x
->parent
;
3557 /* Get the parent to point to y instead of x. */
3560 if (x
== x
->parent
->left
)
3561 x
->parent
->left
= y
;
3563 x
->parent
->right
= y
;
3568 /* Put x on y's left. */
3582 mem_rotate_right (struct mem_node
*x
)
3584 struct mem_node
*y
= x
->left
;
3587 if (y
->right
!= MEM_NIL
)
3588 y
->right
->parent
= x
;
3591 y
->parent
= x
->parent
;
3594 if (x
== x
->parent
->right
)
3595 x
->parent
->right
= y
;
3597 x
->parent
->left
= y
;
3608 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3611 mem_delete (struct mem_node
*z
)
3613 struct mem_node
*x
, *y
;
3615 if (!z
|| z
== MEM_NIL
)
3618 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3623 while (y
->left
!= MEM_NIL
)
3627 if (y
->left
!= MEM_NIL
)
3632 x
->parent
= y
->parent
;
3635 if (y
== y
->parent
->left
)
3636 y
->parent
->left
= x
;
3638 y
->parent
->right
= x
;
3645 z
->start
= y
->start
;
3650 if (y
->color
== MEM_BLACK
)
3651 mem_delete_fixup (x
);
3653 #ifdef GC_MALLOC_CHECK
3661 /* Re-establish the red-black properties of the tree, after a
3665 mem_delete_fixup (struct mem_node
*x
)
3667 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3669 if (x
== x
->parent
->left
)
3671 struct mem_node
*w
= x
->parent
->right
;
3673 if (w
->color
== MEM_RED
)
3675 w
->color
= MEM_BLACK
;
3676 x
->parent
->color
= MEM_RED
;
3677 mem_rotate_left (x
->parent
);
3678 w
= x
->parent
->right
;
3681 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3688 if (w
->right
->color
== MEM_BLACK
)
3690 w
->left
->color
= MEM_BLACK
;
3692 mem_rotate_right (w
);
3693 w
= x
->parent
->right
;
3695 w
->color
= x
->parent
->color
;
3696 x
->parent
->color
= MEM_BLACK
;
3697 w
->right
->color
= MEM_BLACK
;
3698 mem_rotate_left (x
->parent
);
3704 struct mem_node
*w
= x
->parent
->left
;
3706 if (w
->color
== MEM_RED
)
3708 w
->color
= MEM_BLACK
;
3709 x
->parent
->color
= MEM_RED
;
3710 mem_rotate_right (x
->parent
);
3711 w
= x
->parent
->left
;
3714 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3721 if (w
->left
->color
== MEM_BLACK
)
3723 w
->right
->color
= MEM_BLACK
;
3725 mem_rotate_left (w
);
3726 w
= x
->parent
->left
;
3729 w
->color
= x
->parent
->color
;
3730 x
->parent
->color
= MEM_BLACK
;
3731 w
->left
->color
= MEM_BLACK
;
3732 mem_rotate_right (x
->parent
);
3738 x
->color
= MEM_BLACK
;
3742 /* Value is non-zero if P is a pointer to a live Lisp string on
3743 the heap. M is a pointer to the mem_block for P. */
3746 live_string_p (struct mem_node
*m
, void *p
)
3748 if (m
->type
== MEM_TYPE_STRING
)
3750 struct string_block
*b
= (struct string_block
*) m
->start
;
3751 ptrdiff_t offset
= (char *) p
- (char *) &b
->strings
[0];
3753 /* P must point to the start of a Lisp_String structure, and it
3754 must not be on the free-list. */
3756 && offset
% sizeof b
->strings
[0] == 0
3757 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3758 && ((struct Lisp_String
*) p
)->data
!= NULL
);
3765 /* Value is non-zero if P is a pointer to a live Lisp cons on
3766 the heap. M is a pointer to the mem_block for P. */
3769 live_cons_p (struct mem_node
*m
, void *p
)
3771 if (m
->type
== MEM_TYPE_CONS
)
3773 struct cons_block
*b
= (struct cons_block
*) m
->start
;
3774 ptrdiff_t offset
= (char *) p
- (char *) &b
->conses
[0];
3776 /* P must point to the start of a Lisp_Cons, not be
3777 one of the unused cells in the current cons block,
3778 and not be on the free-list. */
3780 && offset
% sizeof b
->conses
[0] == 0
3781 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
3783 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
3784 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
3791 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3792 the heap. M is a pointer to the mem_block for P. */
3795 live_symbol_p (struct mem_node
*m
, void *p
)
3797 if (m
->type
== MEM_TYPE_SYMBOL
)
3799 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
3800 ptrdiff_t offset
= (char *) p
- (char *) &b
->symbols
[0];
3802 /* P must point to the start of a Lisp_Symbol, not be
3803 one of the unused cells in the current symbol block,
3804 and not be on the free-list. */
3806 && offset
% sizeof b
->symbols
[0] == 0
3807 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
3808 && (b
!= symbol_block
3809 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
3810 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
3817 /* Value is non-zero if P is a pointer to a live Lisp float on
3818 the heap. M is a pointer to the mem_block for P. */
3821 live_float_p (struct mem_node
*m
, void *p
)
3823 if (m
->type
== MEM_TYPE_FLOAT
)
3825 struct float_block
*b
= (struct float_block
*) m
->start
;
3826 ptrdiff_t offset
= (char *) p
- (char *) &b
->floats
[0];
3828 /* P must point to the start of a Lisp_Float and not be
3829 one of the unused cells in the current float block. */
3831 && offset
% sizeof b
->floats
[0] == 0
3832 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
3833 && (b
!= float_block
3834 || offset
/ sizeof b
->floats
[0] < float_block_index
));
3841 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3842 the heap. M is a pointer to the mem_block for P. */
3845 live_misc_p (struct mem_node
*m
, void *p
)
3847 if (m
->type
== MEM_TYPE_MISC
)
3849 struct marker_block
*b
= (struct marker_block
*) m
->start
;
3850 ptrdiff_t offset
= (char *) p
- (char *) &b
->markers
[0];
3852 /* P must point to the start of a Lisp_Misc, not be
3853 one of the unused cells in the current misc block,
3854 and not be on the free-list. */
3856 && offset
% sizeof b
->markers
[0] == 0
3857 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
3858 && (b
!= marker_block
3859 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
3860 && ((union Lisp_Misc
*) p
)->u_any
.type
!= Lisp_Misc_Free
);
3867 /* Value is non-zero if P is a pointer to a live vector-like object.
3868 M is a pointer to the mem_block for P. */
3871 live_vector_p (struct mem_node
*m
, void *p
)
3873 return (p
== m
->start
&& m
->type
== MEM_TYPE_VECTORLIKE
);
3877 /* Value is non-zero if P is a pointer to a live buffer. M is a
3878 pointer to the mem_block for P. */
3881 live_buffer_p (struct mem_node
*m
, void *p
)
3883 /* P must point to the start of the block, and the buffer
3884 must not have been killed. */
3885 return (m
->type
== MEM_TYPE_BUFFER
3887 && !NILP (((struct buffer
*) p
)->BUFFER_INTERNAL_FIELD (name
)));
3890 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
3894 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
3896 /* Array of objects that are kept alive because the C stack contains
3897 a pattern that looks like a reference to them . */
3899 #define MAX_ZOMBIES 10
3900 static Lisp_Object zombies
[MAX_ZOMBIES
];
3902 /* Number of zombie objects. */
3904 static int nzombies
;
3906 /* Number of garbage collections. */
3910 /* Average percentage of zombies per collection. */
3912 static double avg_zombies
;
3914 /* Max. number of live and zombie objects. */
3916 static int max_live
, max_zombies
;
3918 /* Average number of live objects per GC. */
3920 static double avg_live
;
3922 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
3923 doc
: /* Show information about live and zombie objects. */)
3926 Lisp_Object args
[8], zombie_list
= Qnil
;
3928 for (i
= 0; i
< nzombies
; i
++)
3929 zombie_list
= Fcons (zombies
[i
], zombie_list
);
3930 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
3931 args
[1] = make_number (ngcs
);
3932 args
[2] = make_float (avg_live
);
3933 args
[3] = make_float (avg_zombies
);
3934 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
3935 args
[5] = make_number (max_live
);
3936 args
[6] = make_number (max_zombies
);
3937 args
[7] = zombie_list
;
3938 return Fmessage (8, args
);
3941 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
3944 /* Mark OBJ if we can prove it's a Lisp_Object. */
3947 mark_maybe_object (Lisp_Object obj
)
3955 po
= (void *) XPNTR (obj
);
3962 switch (XTYPE (obj
))
3965 mark_p
= (live_string_p (m
, po
)
3966 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
3970 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
3974 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
3978 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
3981 case Lisp_Vectorlike
:
3982 /* Note: can't check BUFFERP before we know it's a
3983 buffer because checking that dereferences the pointer
3984 PO which might point anywhere. */
3985 if (live_vector_p (m
, po
))
3986 mark_p
= !SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
3987 else if (live_buffer_p (m
, po
))
3988 mark_p
= BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
3992 mark_p
= (live_misc_p (m
, po
) && !XMISCANY (obj
)->gcmarkbit
);
4001 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4002 if (nzombies
< MAX_ZOMBIES
)
4003 zombies
[nzombies
] = obj
;
4012 /* If P points to Lisp data, mark that as live if it isn't already
4016 mark_maybe_pointer (void *p
)
4020 /* Quickly rule out some values which can't point to Lisp data. */
4023 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4025 2 /* We assume that Lisp data is aligned on even addresses. */
4033 Lisp_Object obj
= Qnil
;
4037 case MEM_TYPE_NON_LISP
:
4038 /* Nothing to do; not a pointer to Lisp memory. */
4041 case MEM_TYPE_BUFFER
:
4042 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4043 XSETVECTOR (obj
, p
);
4047 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4051 case MEM_TYPE_STRING
:
4052 if (live_string_p (m
, p
)
4053 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4054 XSETSTRING (obj
, p
);
4058 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4062 case MEM_TYPE_SYMBOL
:
4063 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4064 XSETSYMBOL (obj
, p
);
4067 case MEM_TYPE_FLOAT
:
4068 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4072 case MEM_TYPE_VECTORLIKE
:
4073 if (live_vector_p (m
, p
))
4076 XSETVECTOR (tem
, p
);
4077 if (!SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4092 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4093 or END+OFFSET..START. */
4096 mark_memory (void *start
, void *end
, int offset
)
4101 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4105 /* Make START the pointer to the start of the memory region,
4106 if it isn't already. */
4114 /* Mark Lisp_Objects. */
4115 for (p
= (Lisp_Object
*) ((char *) start
+ offset
); (void *) p
< end
; ++p
)
4116 mark_maybe_object (*p
);
4118 /* Mark Lisp data pointed to. This is necessary because, in some
4119 situations, the C compiler optimizes Lisp objects away, so that
4120 only a pointer to them remains. Example:
4122 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4125 Lisp_Object obj = build_string ("test");
4126 struct Lisp_String *s = XSTRING (obj);
4127 Fgarbage_collect ();
4128 fprintf (stderr, "test `%s'\n", s->data);
4132 Here, `obj' isn't really used, and the compiler optimizes it
4133 away. The only reference to the life string is through the
4136 for (pp
= (void **) ((char *) start
+ offset
); (void *) pp
< end
; ++pp
)
4137 mark_maybe_pointer (*pp
);
4140 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4141 the GCC system configuration. In gcc 3.2, the only systems for
4142 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4143 by others?) and ns32k-pc532-min. */
4145 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4147 static int setjmp_tested_p
, longjmps_done
;
4149 #define SETJMP_WILL_LIKELY_WORK "\
4151 Emacs garbage collector has been changed to use conservative stack\n\
4152 marking. Emacs has determined that the method it uses to do the\n\
4153 marking will likely work on your system, but this isn't sure.\n\
4155 If you are a system-programmer, or can get the help of a local wizard\n\
4156 who is, please take a look at the function mark_stack in alloc.c, and\n\
4157 verify that the methods used are appropriate for your system.\n\
4159 Please mail the result to <emacs-devel@gnu.org>.\n\
4162 #define SETJMP_WILL_NOT_WORK "\
4164 Emacs garbage collector has been changed to use conservative stack\n\
4165 marking. Emacs has determined that the default method it uses to do the\n\
4166 marking will not work on your system. We will need a system-dependent\n\
4167 solution for your system.\n\
4169 Please take a look at the function mark_stack in alloc.c, and\n\
4170 try to find a way to make it work on your system.\n\
4172 Note that you may get false negatives, depending on the compiler.\n\
4173 In particular, you need to use -O with GCC for this test.\n\
4175 Please mail the result to <emacs-devel@gnu.org>.\n\
4179 /* Perform a quick check if it looks like setjmp saves registers in a
4180 jmp_buf. Print a message to stderr saying so. When this test
4181 succeeds, this is _not_ a proof that setjmp is sufficient for
4182 conservative stack marking. Only the sources or a disassembly
4193 /* Arrange for X to be put in a register. */
4199 if (longjmps_done
== 1)
4201 /* Came here after the longjmp at the end of the function.
4203 If x == 1, the longjmp has restored the register to its
4204 value before the setjmp, and we can hope that setjmp
4205 saves all such registers in the jmp_buf, although that
4208 For other values of X, either something really strange is
4209 taking place, or the setjmp just didn't save the register. */
4212 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4215 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4222 if (longjmps_done
== 1)
4226 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4229 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4231 /* Abort if anything GCPRO'd doesn't survive the GC. */
4239 for (p
= gcprolist
; p
; p
= p
->next
)
4240 for (i
= 0; i
< p
->nvars
; ++i
)
4241 if (!survives_gc_p (p
->var
[i
]))
4242 /* FIXME: It's not necessarily a bug. It might just be that the
4243 GCPRO is unnecessary or should release the object sooner. */
4247 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4254 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4255 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4257 fprintf (stderr
, " %d = ", i
);
4258 debug_print (zombies
[i
]);
4262 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4265 /* Mark live Lisp objects on the C stack.
4267 There are several system-dependent problems to consider when
4268 porting this to new architectures:
4272 We have to mark Lisp objects in CPU registers that can hold local
4273 variables or are used to pass parameters.
4275 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4276 something that either saves relevant registers on the stack, or
4277 calls mark_maybe_object passing it each register's contents.
4279 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4280 implementation assumes that calling setjmp saves registers we need
4281 to see in a jmp_buf which itself lies on the stack. This doesn't
4282 have to be true! It must be verified for each system, possibly
4283 by taking a look at the source code of setjmp.
4285 If __builtin_unwind_init is available (defined by GCC >= 2.8) we
4286 can use it as a machine independent method to store all registers
4287 to the stack. In this case the macros described in the previous
4288 two paragraphs are not used.
4292 Architectures differ in the way their processor stack is organized.
4293 For example, the stack might look like this
4296 | Lisp_Object | size = 4
4298 | something else | size = 2
4300 | Lisp_Object | size = 4
4304 In such a case, not every Lisp_Object will be aligned equally. To
4305 find all Lisp_Object on the stack it won't be sufficient to walk
4306 the stack in steps of 4 bytes. Instead, two passes will be
4307 necessary, one starting at the start of the stack, and a second
4308 pass starting at the start of the stack + 2. Likewise, if the
4309 minimal alignment of Lisp_Objects on the stack is 1, four passes
4310 would be necessary, each one starting with one byte more offset
4311 from the stack start.
4313 The current code assumes by default that Lisp_Objects are aligned
4314 equally on the stack. */
4320 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4321 union aligned_jmpbuf
{
4325 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4328 #ifdef HAVE___BUILTIN_UNWIND_INIT
4329 /* Force callee-saved registers and register windows onto the stack.
4330 This is the preferred method if available, obviating the need for
4331 machine dependent methods. */
4332 __builtin_unwind_init ();
4334 #else /* not HAVE___BUILTIN_UNWIND_INIT */
4335 /* This trick flushes the register windows so that all the state of
4336 the process is contained in the stack. */
4337 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4338 needed on ia64 too. See mach_dep.c, where it also says inline
4339 assembler doesn't work with relevant proprietary compilers. */
4341 #if defined (__sparc64__) && defined (__FreeBSD__)
4342 /* FreeBSD does not have a ta 3 handler. */
4349 /* Save registers that we need to see on the stack. We need to see
4350 registers used to hold register variables and registers used to
4352 #ifdef GC_SAVE_REGISTERS_ON_STACK
4353 GC_SAVE_REGISTERS_ON_STACK (end
);
4354 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4356 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4357 setjmp will definitely work, test it
4358 and print a message with the result
4360 if (!setjmp_tested_p
)
4362 setjmp_tested_p
= 1;
4365 #endif /* GC_SETJMP_WORKS */
4368 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4369 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4370 #endif /* not HAVE___BUILTIN_UNWIND_INIT */
4372 /* This assumes that the stack is a contiguous region in memory. If
4373 that's not the case, something has to be done here to iterate
4374 over the stack segments. */
4375 #ifndef GC_LISP_OBJECT_ALIGNMENT
4377 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4379 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4382 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4383 mark_memory (stack_base
, end
, i
);
4384 /* Allow for marking a secondary stack, like the register stack on the
4386 #ifdef GC_MARK_SECONDARY_STACK
4387 GC_MARK_SECONDARY_STACK ();
4390 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4395 #endif /* GC_MARK_STACK != 0 */
4398 /* Determine whether it is safe to access memory at address P. */
4400 valid_pointer_p (void *p
)
4403 return w32_valid_pointer_p (p
, 16);
4407 /* Obviously, we cannot just access it (we would SEGV trying), so we
4408 trick the o/s to tell us whether p is a valid pointer.
4409 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4410 not validate p in that case. */
4412 if ((fd
= emacs_open ("__Valid__Lisp__Object__", O_CREAT
| O_WRONLY
| O_TRUNC
, 0666)) >= 0)
4414 int valid
= (emacs_write (fd
, (char *)p
, 16) == 16);
4416 unlink ("__Valid__Lisp__Object__");
4424 /* Return 1 if OBJ is a valid lisp object.
4425 Return 0 if OBJ is NOT a valid lisp object.
4426 Return -1 if we cannot validate OBJ.
4427 This function can be quite slow,
4428 so it should only be used in code for manual debugging. */
4431 valid_lisp_object_p (Lisp_Object obj
)
4441 p
= (void *) XPNTR (obj
);
4442 if (PURE_POINTER_P (p
))
4446 return valid_pointer_p (p
);
4453 int valid
= valid_pointer_p (p
);
4465 case MEM_TYPE_NON_LISP
:
4468 case MEM_TYPE_BUFFER
:
4469 return live_buffer_p (m
, p
);
4472 return live_cons_p (m
, p
);
4474 case MEM_TYPE_STRING
:
4475 return live_string_p (m
, p
);
4478 return live_misc_p (m
, p
);
4480 case MEM_TYPE_SYMBOL
:
4481 return live_symbol_p (m
, p
);
4483 case MEM_TYPE_FLOAT
:
4484 return live_float_p (m
, p
);
4486 case MEM_TYPE_VECTORLIKE
:
4487 return live_vector_p (m
, p
);
4500 /***********************************************************************
4501 Pure Storage Management
4502 ***********************************************************************/
4504 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4505 pointer to it. TYPE is the Lisp type for which the memory is
4506 allocated. TYPE < 0 means it's not used for a Lisp object. */
4508 static POINTER_TYPE
*
4509 pure_alloc (size_t size
, int type
)
4511 POINTER_TYPE
*result
;
4513 size_t alignment
= (1 << GCTYPEBITS
);
4515 size_t alignment
= sizeof (EMACS_INT
);
4517 /* Give Lisp_Floats an extra alignment. */
4518 if (type
== Lisp_Float
)
4520 #if defined __GNUC__ && __GNUC__ >= 2
4521 alignment
= __alignof (struct Lisp_Float
);
4523 alignment
= sizeof (struct Lisp_Float
);
4531 /* Allocate space for a Lisp object from the beginning of the free
4532 space with taking account of alignment. */
4533 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4534 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4538 /* Allocate space for a non-Lisp object from the end of the free
4540 pure_bytes_used_non_lisp
+= size
;
4541 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4543 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4545 if (pure_bytes_used
<= pure_size
)
4548 /* Don't allocate a large amount here,
4549 because it might get mmap'd and then its address
4550 might not be usable. */
4551 purebeg
= (char *) xmalloc (10000);
4553 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4554 pure_bytes_used
= 0;
4555 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4560 /* Print a warning if PURESIZE is too small. */
4563 check_pure_size (void)
4565 if (pure_bytes_used_before_overflow
)
4566 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4567 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4571 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4572 the non-Lisp data pool of the pure storage, and return its start
4573 address. Return NULL if not found. */
4576 find_string_data_in_pure (const char *data
, EMACS_INT nbytes
)
4579 EMACS_INT skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4580 const unsigned char *p
;
4583 if (pure_bytes_used_non_lisp
< nbytes
+ 1)
4586 /* Set up the Boyer-Moore table. */
4588 for (i
= 0; i
< 256; i
++)
4591 p
= (const unsigned char *) data
;
4593 bm_skip
[*p
++] = skip
;
4595 last_char_skip
= bm_skip
['\0'];
4597 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4598 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4600 /* See the comments in the function `boyer_moore' (search.c) for the
4601 use of `infinity'. */
4602 infinity
= pure_bytes_used_non_lisp
+ 1;
4603 bm_skip
['\0'] = infinity
;
4605 p
= (const unsigned char *) non_lisp_beg
+ nbytes
;
4609 /* Check the last character (== '\0'). */
4612 start
+= bm_skip
[*(p
+ start
)];
4614 while (start
<= start_max
);
4616 if (start
< infinity
)
4617 /* Couldn't find the last character. */
4620 /* No less than `infinity' means we could find the last
4621 character at `p[start - infinity]'. */
4624 /* Check the remaining characters. */
4625 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4627 return non_lisp_beg
+ start
;
4629 start
+= last_char_skip
;
4631 while (start
<= start_max
);
4637 /* Return a string allocated in pure space. DATA is a buffer holding
4638 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4639 non-zero means make the result string multibyte.
4641 Must get an error if pure storage is full, since if it cannot hold
4642 a large string it may be able to hold conses that point to that
4643 string; then the string is not protected from gc. */
4646 make_pure_string (const char *data
,
4647 EMACS_INT nchars
, EMACS_INT nbytes
, int multibyte
)
4650 struct Lisp_String
*s
;
4652 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4653 s
->data
= (unsigned char *) find_string_data_in_pure (data
, nbytes
);
4654 if (s
->data
== NULL
)
4656 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4657 memcpy (s
->data
, data
, nbytes
);
4658 s
->data
[nbytes
] = '\0';
4661 s
->size_byte
= multibyte
? nbytes
: -1;
4662 s
->intervals
= NULL_INTERVAL
;
4663 XSETSTRING (string
, s
);
4667 /* Return a string a string allocated in pure space. Do not allocate
4668 the string data, just point to DATA. */
4671 make_pure_c_string (const char *data
)
4674 struct Lisp_String
*s
;
4675 EMACS_INT nchars
= strlen (data
);
4677 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4680 s
->data
= (unsigned char *) data
;
4681 s
->intervals
= NULL_INTERVAL
;
4682 XSETSTRING (string
, s
);
4686 /* Return a cons allocated from pure space. Give it pure copies
4687 of CAR as car and CDR as cdr. */
4690 pure_cons (Lisp_Object car
, Lisp_Object cdr
)
4692 register Lisp_Object
new;
4693 struct Lisp_Cons
*p
;
4695 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4697 XSETCAR (new, Fpurecopy (car
));
4698 XSETCDR (new, Fpurecopy (cdr
));
4703 /* Value is a float object with value NUM allocated from pure space. */
4706 make_pure_float (double num
)
4708 register Lisp_Object
new;
4709 struct Lisp_Float
*p
;
4711 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4713 XFLOAT_INIT (new, num
);
4718 /* Return a vector with room for LEN Lisp_Objects allocated from
4722 make_pure_vector (EMACS_INT len
)
4725 struct Lisp_Vector
*p
;
4726 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4728 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4729 XSETVECTOR (new, p
);
4730 XVECTOR (new)->size
= len
;
4735 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4736 doc
: /* Make a copy of object OBJ in pure storage.
4737 Recursively copies contents of vectors and cons cells.
4738 Does not copy symbols. Copies strings without text properties. */)
4739 (register Lisp_Object obj
)
4741 if (NILP (Vpurify_flag
))
4744 if (PURE_POINTER_P (XPNTR (obj
)))
4747 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4749 Lisp_Object tmp
= Fgethash (obj
, Vpurify_flag
, Qnil
);
4755 obj
= pure_cons (XCAR (obj
), XCDR (obj
));
4756 else if (FLOATP (obj
))
4757 obj
= make_pure_float (XFLOAT_DATA (obj
));
4758 else if (STRINGP (obj
))
4759 obj
= make_pure_string (SSDATA (obj
), SCHARS (obj
),
4761 STRING_MULTIBYTE (obj
));
4762 else if (COMPILEDP (obj
) || VECTORP (obj
))
4764 register struct Lisp_Vector
*vec
;
4765 register EMACS_INT i
;
4768 size
= XVECTOR (obj
)->size
;
4769 if (size
& PSEUDOVECTOR_FLAG
)
4770 size
&= PSEUDOVECTOR_SIZE_MASK
;
4771 vec
= XVECTOR (make_pure_vector (size
));
4772 for (i
= 0; i
< size
; i
++)
4773 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4774 if (COMPILEDP (obj
))
4776 XSETPVECTYPE (vec
, PVEC_COMPILED
);
4777 XSETCOMPILED (obj
, vec
);
4780 XSETVECTOR (obj
, vec
);
4782 else if (MARKERP (obj
))
4783 error ("Attempt to copy a marker to pure storage");
4785 /* Not purified, don't hash-cons. */
4788 if (HASH_TABLE_P (Vpurify_flag
)) /* Hash consing. */
4789 Fputhash (obj
, obj
, Vpurify_flag
);
4796 /***********************************************************************
4798 ***********************************************************************/
4800 /* Put an entry in staticvec, pointing at the variable with address
4804 staticpro (Lisp_Object
*varaddress
)
4806 staticvec
[staticidx
++] = varaddress
;
4807 if (staticidx
>= NSTATICS
)
4812 /***********************************************************************
4814 ***********************************************************************/
4816 /* Temporarily prevent garbage collection. */
4819 inhibit_garbage_collection (void)
4821 int count
= SPECPDL_INDEX ();
4822 int nbits
= min (VALBITS
, BITS_PER_INT
);
4824 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
4829 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
4830 doc
: /* Reclaim storage for Lisp objects no longer needed.
4831 Garbage collection happens automatically if you cons more than
4832 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4833 `garbage-collect' normally returns a list with info on amount of space in use:
4834 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4835 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4836 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4837 (USED-STRINGS . FREE-STRINGS))
4838 However, if there was overflow in pure space, `garbage-collect'
4839 returns nil, because real GC can't be done. */)
4842 register struct specbinding
*bind
;
4843 char stack_top_variable
;
4846 Lisp_Object total
[8];
4847 int count
= SPECPDL_INDEX ();
4848 EMACS_TIME t1
, t2
, t3
;
4853 /* Can't GC if pure storage overflowed because we can't determine
4854 if something is a pure object or not. */
4855 if (pure_bytes_used_before_overflow
)
4860 /* Don't keep undo information around forever.
4861 Do this early on, so it is no problem if the user quits. */
4863 register struct buffer
*nextb
= all_buffers
;
4867 /* If a buffer's undo list is Qt, that means that undo is
4868 turned off in that buffer. Calling truncate_undo_list on
4869 Qt tends to return NULL, which effectively turns undo back on.
4870 So don't call truncate_undo_list if undo_list is Qt. */
4871 if (! NILP (nextb
->BUFFER_INTERNAL_FIELD (name
)) && ! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
4872 truncate_undo_list (nextb
);
4874 /* Shrink buffer gaps, but skip indirect and dead buffers. */
4875 if (nextb
->base_buffer
== 0 && !NILP (nextb
->BUFFER_INTERNAL_FIELD (name
))
4876 && ! nextb
->text
->inhibit_shrinking
)
4878 /* If a buffer's gap size is more than 10% of the buffer
4879 size, or larger than 2000 bytes, then shrink it
4880 accordingly. Keep a minimum size of 20 bytes. */
4881 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
4883 if (nextb
->text
->gap_size
> size
)
4885 struct buffer
*save_current
= current_buffer
;
4886 current_buffer
= nextb
;
4887 make_gap (-(nextb
->text
->gap_size
- size
));
4888 current_buffer
= save_current
;
4892 nextb
= nextb
->next
;
4896 EMACS_GET_TIME (t1
);
4898 /* In case user calls debug_print during GC,
4899 don't let that cause a recursive GC. */
4900 consing_since_gc
= 0;
4902 /* Save what's currently displayed in the echo area. */
4903 message_p
= push_message ();
4904 record_unwind_protect (pop_message_unwind
, Qnil
);
4906 /* Save a copy of the contents of the stack, for debugging. */
4907 #if MAX_SAVE_STACK > 0
4908 if (NILP (Vpurify_flag
))
4910 i
= &stack_top_variable
- stack_bottom
;
4912 if (i
< MAX_SAVE_STACK
)
4914 if (stack_copy
== 0)
4915 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
4916 else if (stack_copy_size
< i
)
4917 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
4920 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
4921 memcpy (stack_copy
, stack_bottom
, i
);
4923 memcpy (stack_copy
, &stack_top_variable
, i
);
4927 #endif /* MAX_SAVE_STACK > 0 */
4929 if (garbage_collection_messages
)
4930 message1_nolog ("Garbage collecting...");
4934 shrink_regexp_cache ();
4938 /* clear_marks (); */
4940 /* Mark all the special slots that serve as the roots of accessibility. */
4942 for (i
= 0; i
< staticidx
; i
++)
4943 mark_object (*staticvec
[i
]);
4945 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
4947 mark_object (bind
->symbol
);
4948 mark_object (bind
->old_value
);
4956 extern void xg_mark_data (void);
4961 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
4962 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
4966 register struct gcpro
*tail
;
4967 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
4968 for (i
= 0; i
< tail
->nvars
; i
++)
4969 mark_object (tail
->var
[i
]);
4973 struct catchtag
*catch;
4974 struct handler
*handler
;
4976 for (catch = catchlist
; catch; catch = catch->next
)
4978 mark_object (catch->tag
);
4979 mark_object (catch->val
);
4981 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
4983 mark_object (handler
->handler
);
4984 mark_object (handler
->var
);
4990 #ifdef HAVE_WINDOW_SYSTEM
4991 mark_fringe_data ();
4994 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4998 /* Everything is now marked, except for the things that require special
4999 finalization, i.e. the undo_list.
5000 Look thru every buffer's undo list
5001 for elements that update markers that were not marked,
5004 register struct buffer
*nextb
= all_buffers
;
5008 /* If a buffer's undo list is Qt, that means that undo is
5009 turned off in that buffer. Calling truncate_undo_list on
5010 Qt tends to return NULL, which effectively turns undo back on.
5011 So don't call truncate_undo_list if undo_list is Qt. */
5012 if (! EQ (nextb
->BUFFER_INTERNAL_FIELD (undo_list
), Qt
))
5014 Lisp_Object tail
, prev
;
5015 tail
= nextb
->BUFFER_INTERNAL_FIELD (undo_list
);
5017 while (CONSP (tail
))
5019 if (CONSP (XCAR (tail
))
5020 && MARKERP (XCAR (XCAR (tail
)))
5021 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5024 nextb
->BUFFER_INTERNAL_FIELD (undo_list
) = tail
= XCDR (tail
);
5028 XSETCDR (prev
, tail
);
5038 /* Now that we have stripped the elements that need not be in the
5039 undo_list any more, we can finally mark the list. */
5040 mark_object (nextb
->BUFFER_INTERNAL_FIELD (undo_list
));
5042 nextb
= nextb
->next
;
5048 /* Clear the mark bits that we set in certain root slots. */
5050 unmark_byte_stack ();
5051 VECTOR_UNMARK (&buffer_defaults
);
5052 VECTOR_UNMARK (&buffer_local_symbols
);
5054 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5062 /* clear_marks (); */
5065 consing_since_gc
= 0;
5066 if (gc_cons_threshold
< 10000)
5067 gc_cons_threshold
= 10000;
5069 if (FLOATP (Vgc_cons_percentage
))
5070 { /* Set gc_cons_combined_threshold. */
5071 EMACS_INT total
= 0;
5073 total
+= total_conses
* sizeof (struct Lisp_Cons
);
5074 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5075 total
+= total_markers
* sizeof (union Lisp_Misc
);
5076 total
+= total_string_size
;
5077 total
+= total_vector_size
* sizeof (Lisp_Object
);
5078 total
+= total_floats
* sizeof (struct Lisp_Float
);
5079 total
+= total_intervals
* sizeof (struct interval
);
5080 total
+= total_strings
* sizeof (struct Lisp_String
);
5082 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
5085 gc_relative_threshold
= 0;
5087 if (garbage_collection_messages
)
5089 if (message_p
|| minibuf_level
> 0)
5092 message1_nolog ("Garbage collecting...done");
5095 unbind_to (count
, Qnil
);
5097 total
[0] = Fcons (make_number (total_conses
),
5098 make_number (total_free_conses
));
5099 total
[1] = Fcons (make_number (total_symbols
),
5100 make_number (total_free_symbols
));
5101 total
[2] = Fcons (make_number (total_markers
),
5102 make_number (total_free_markers
));
5103 total
[3] = make_number (total_string_size
);
5104 total
[4] = make_number (total_vector_size
);
5105 total
[5] = Fcons (make_number (total_floats
),
5106 make_number (total_free_floats
));
5107 total
[6] = Fcons (make_number (total_intervals
),
5108 make_number (total_free_intervals
));
5109 total
[7] = Fcons (make_number (total_strings
),
5110 make_number (total_free_strings
));
5112 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5114 /* Compute average percentage of zombies. */
5117 for (i
= 0; i
< 7; ++i
)
5118 if (CONSP (total
[i
]))
5119 nlive
+= XFASTINT (XCAR (total
[i
]));
5121 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5122 max_live
= max (nlive
, max_live
);
5123 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5124 max_zombies
= max (nzombies
, max_zombies
);
5129 if (!NILP (Vpost_gc_hook
))
5131 int count
= inhibit_garbage_collection ();
5132 safe_run_hooks (Qpost_gc_hook
);
5133 unbind_to (count
, Qnil
);
5136 /* Accumulate statistics. */
5137 EMACS_GET_TIME (t2
);
5138 EMACS_SUB_TIME (t3
, t2
, t1
);
5139 if (FLOATP (Vgc_elapsed
))
5140 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5142 EMACS_USECS (t3
) * 1.0e-6);
5145 return Flist (sizeof total
/ sizeof *total
, total
);
5149 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5150 only interesting objects referenced from glyphs are strings. */
5153 mark_glyph_matrix (struct glyph_matrix
*matrix
)
5155 struct glyph_row
*row
= matrix
->rows
;
5156 struct glyph_row
*end
= row
+ matrix
->nrows
;
5158 for (; row
< end
; ++row
)
5162 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5164 struct glyph
*glyph
= row
->glyphs
[area
];
5165 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5167 for (; glyph
< end_glyph
; ++glyph
)
5168 if (STRINGP (glyph
->object
)
5169 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5170 mark_object (glyph
->object
);
5176 /* Mark Lisp faces in the face cache C. */
5179 mark_face_cache (struct face_cache
*c
)
5184 for (i
= 0; i
< c
->used
; ++i
)
5186 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5190 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5191 mark_object (face
->lface
[j
]);
5199 /* Mark reference to a Lisp_Object.
5200 If the object referred to has not been seen yet, recursively mark
5201 all the references contained in it. */
5203 #define LAST_MARKED_SIZE 500
5204 static Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5205 int last_marked_index
;
5207 /* For debugging--call abort when we cdr down this many
5208 links of a list, in mark_object. In debugging,
5209 the call to abort will hit a breakpoint.
5210 Normally this is zero and the check never goes off. */
5211 static int mark_object_loop_halt
;
5214 mark_vectorlike (struct Lisp_Vector
*ptr
)
5216 register EMACS_UINT size
= ptr
->size
;
5217 register EMACS_UINT i
;
5219 eassert (!VECTOR_MARKED_P (ptr
));
5220 VECTOR_MARK (ptr
); /* Else mark it */
5221 if (size
& PSEUDOVECTOR_FLAG
)
5222 size
&= PSEUDOVECTOR_SIZE_MASK
;
5224 /* Note that this size is not the memory-footprint size, but only
5225 the number of Lisp_Object fields that we should trace.
5226 The distinction is used e.g. by Lisp_Process which places extra
5227 non-Lisp_Object fields at the end of the structure. */
5228 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5229 mark_object (ptr
->contents
[i
]);
5232 /* Like mark_vectorlike but optimized for char-tables (and
5233 sub-char-tables) assuming that the contents are mostly integers or
5237 mark_char_table (struct Lisp_Vector
*ptr
)
5239 register EMACS_UINT size
= ptr
->size
& PSEUDOVECTOR_SIZE_MASK
;
5240 register EMACS_UINT i
;
5242 eassert (!VECTOR_MARKED_P (ptr
));
5244 for (i
= 0; i
< size
; i
++)
5246 Lisp_Object val
= ptr
->contents
[i
];
5248 if (INTEGERP (val
) || (SYMBOLP (val
) && XSYMBOL (val
)->gcmarkbit
))
5250 if (SUB_CHAR_TABLE_P (val
))
5252 if (! VECTOR_MARKED_P (XVECTOR (val
)))
5253 mark_char_table (XVECTOR (val
));
5261 mark_object (Lisp_Object arg
)
5263 register Lisp_Object obj
= arg
;
5264 #ifdef GC_CHECK_MARKED_OBJECTS
5272 if (PURE_POINTER_P (XPNTR (obj
)))
5275 last_marked
[last_marked_index
++] = obj
;
5276 if (last_marked_index
== LAST_MARKED_SIZE
)
5277 last_marked_index
= 0;
5279 /* Perform some sanity checks on the objects marked here. Abort if
5280 we encounter an object we know is bogus. This increases GC time
5281 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5282 #ifdef GC_CHECK_MARKED_OBJECTS
5284 po
= (void *) XPNTR (obj
);
5286 /* Check that the object pointed to by PO is known to be a Lisp
5287 structure allocated from the heap. */
5288 #define CHECK_ALLOCATED() \
5290 m = mem_find (po); \
5295 /* Check that the object pointed to by PO is live, using predicate
5297 #define CHECK_LIVE(LIVEP) \
5299 if (!LIVEP (m, po)) \
5303 /* Check both of the above conditions. */
5304 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5306 CHECK_ALLOCATED (); \
5307 CHECK_LIVE (LIVEP); \
5310 #else /* not GC_CHECK_MARKED_OBJECTS */
5312 #define CHECK_ALLOCATED() (void) 0
5313 #define CHECK_LIVE(LIVEP) (void) 0
5314 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5316 #endif /* not GC_CHECK_MARKED_OBJECTS */
5318 switch (SWITCH_ENUM_CAST (XTYPE (obj
)))
5322 register struct Lisp_String
*ptr
= XSTRING (obj
);
5323 if (STRING_MARKED_P (ptr
))
5325 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5326 MARK_INTERVAL_TREE (ptr
->intervals
);
5328 #ifdef GC_CHECK_STRING_BYTES
5329 /* Check that the string size recorded in the string is the
5330 same as the one recorded in the sdata structure. */
5331 CHECK_STRING_BYTES (ptr
);
5332 #endif /* GC_CHECK_STRING_BYTES */
5336 case Lisp_Vectorlike
:
5337 if (VECTOR_MARKED_P (XVECTOR (obj
)))
5339 #ifdef GC_CHECK_MARKED_OBJECTS
5341 if (m
== MEM_NIL
&& !SUBRP (obj
)
5342 && po
!= &buffer_defaults
5343 && po
!= &buffer_local_symbols
)
5345 #endif /* GC_CHECK_MARKED_OBJECTS */
5349 #ifdef GC_CHECK_MARKED_OBJECTS
5350 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5353 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5358 #endif /* GC_CHECK_MARKED_OBJECTS */
5361 else if (SUBRP (obj
))
5363 else if (COMPILEDP (obj
))
5364 /* We could treat this just like a vector, but it is better to
5365 save the COMPILED_CONSTANTS element for last and avoid
5368 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5369 register EMACS_UINT size
= ptr
->size
;
5370 register EMACS_UINT i
;
5372 CHECK_LIVE (live_vector_p
);
5373 VECTOR_MARK (ptr
); /* Else mark it */
5374 size
&= PSEUDOVECTOR_SIZE_MASK
;
5375 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5377 if (i
!= COMPILED_CONSTANTS
)
5378 mark_object (ptr
->contents
[i
]);
5380 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5383 else if (FRAMEP (obj
))
5385 register struct frame
*ptr
= XFRAME (obj
);
5386 mark_vectorlike (XVECTOR (obj
));
5387 mark_face_cache (ptr
->face_cache
);
5389 else if (WINDOWP (obj
))
5391 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5392 struct window
*w
= XWINDOW (obj
);
5393 mark_vectorlike (ptr
);
5394 /* Mark glyphs for leaf windows. Marking window matrices is
5395 sufficient because frame matrices use the same glyph
5397 if (NILP (w
->hchild
)
5399 && w
->current_matrix
)
5401 mark_glyph_matrix (w
->current_matrix
);
5402 mark_glyph_matrix (w
->desired_matrix
);
5405 else if (HASH_TABLE_P (obj
))
5407 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5408 mark_vectorlike ((struct Lisp_Vector
*)h
);
5409 /* If hash table is not weak, mark all keys and values.
5410 For weak tables, mark only the vector. */
5412 mark_object (h
->key_and_value
);
5414 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5416 else if (CHAR_TABLE_P (obj
))
5417 mark_char_table (XVECTOR (obj
));
5419 mark_vectorlike (XVECTOR (obj
));
5424 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5425 struct Lisp_Symbol
*ptrx
;
5429 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5431 mark_object (ptr
->function
);
5432 mark_object (ptr
->plist
);
5433 switch (ptr
->redirect
)
5435 case SYMBOL_PLAINVAL
: mark_object (SYMBOL_VAL (ptr
)); break;
5436 case SYMBOL_VARALIAS
:
5439 XSETSYMBOL (tem
, SYMBOL_ALIAS (ptr
));
5443 case SYMBOL_LOCALIZED
:
5445 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (ptr
);
5446 /* If the value is forwarded to a buffer or keyboard field,
5447 these are marked when we see the corresponding object.
5448 And if it's forwarded to a C variable, either it's not
5449 a Lisp_Object var, or it's staticpro'd already. */
5450 mark_object (blv
->where
);
5451 mark_object (blv
->valcell
);
5452 mark_object (blv
->defcell
);
5455 case SYMBOL_FORWARDED
:
5456 /* If the value is forwarded to a buffer or keyboard field,
5457 these are marked when we see the corresponding object.
5458 And if it's forwarded to a C variable, either it's not
5459 a Lisp_Object var, or it's staticpro'd already. */
5463 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5464 MARK_STRING (XSTRING (ptr
->xname
));
5465 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5470 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5471 XSETSYMBOL (obj
, ptrx
);
5478 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5479 if (XMISCANY (obj
)->gcmarkbit
)
5481 XMISCANY (obj
)->gcmarkbit
= 1;
5483 switch (XMISCTYPE (obj
))
5486 case Lisp_Misc_Marker
:
5487 /* DO NOT mark thru the marker's chain.
5488 The buffer's markers chain does not preserve markers from gc;
5489 instead, markers are removed from the chain when freed by gc. */
5492 case Lisp_Misc_Save_Value
:
5495 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5496 /* If DOGC is set, POINTER is the address of a memory
5497 area containing INTEGER potential Lisp_Objects. */
5500 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5502 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5503 mark_maybe_object (*p
);
5509 case Lisp_Misc_Overlay
:
5511 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5512 mark_object (ptr
->start
);
5513 mark_object (ptr
->end
);
5514 mark_object (ptr
->plist
);
5517 XSETMISC (obj
, ptr
->next
);
5530 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5531 if (CONS_MARKED_P (ptr
))
5533 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5535 /* If the cdr is nil, avoid recursion for the car. */
5536 if (EQ (ptr
->u
.cdr
, Qnil
))
5542 mark_object (ptr
->car
);
5545 if (cdr_count
== mark_object_loop_halt
)
5551 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5552 FLOAT_MARK (XFLOAT (obj
));
5563 #undef CHECK_ALLOCATED
5564 #undef CHECK_ALLOCATED_AND_LIVE
5567 /* Mark the pointers in a buffer structure. */
5570 mark_buffer (Lisp_Object buf
)
5572 register struct buffer
*buffer
= XBUFFER (buf
);
5573 register Lisp_Object
*ptr
, tmp
;
5574 Lisp_Object base_buffer
;
5576 eassert (!VECTOR_MARKED_P (buffer
));
5577 VECTOR_MARK (buffer
);
5579 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5581 /* For now, we just don't mark the undo_list. It's done later in
5582 a special way just before the sweep phase, and after stripping
5583 some of its elements that are not needed any more. */
5585 if (buffer
->overlays_before
)
5587 XSETMISC (tmp
, buffer
->overlays_before
);
5590 if (buffer
->overlays_after
)
5592 XSETMISC (tmp
, buffer
->overlays_after
);
5596 /* buffer-local Lisp variables start at `undo_list',
5597 tho only the ones from `name' on are GC'd normally. */
5598 for (ptr
= &buffer
->BUFFER_INTERNAL_FIELD (name
);
5599 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5603 /* If this is an indirect buffer, mark its base buffer. */
5604 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5606 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5607 mark_buffer (base_buffer
);
5611 /* Mark the Lisp pointers in the terminal objects.
5612 Called by the Fgarbage_collector. */
5615 mark_terminals (void)
5618 for (t
= terminal_list
; t
; t
= t
->next_terminal
)
5620 eassert (t
->name
!= NULL
);
5621 #ifdef HAVE_WINDOW_SYSTEM
5622 /* If a terminal object is reachable from a stacpro'ed object,
5623 it might have been marked already. Make sure the image cache
5625 mark_image_cache (t
->image_cache
);
5626 #endif /* HAVE_WINDOW_SYSTEM */
5627 if (!VECTOR_MARKED_P (t
))
5628 mark_vectorlike ((struct Lisp_Vector
*)t
);
5634 /* Value is non-zero if OBJ will survive the current GC because it's
5635 either marked or does not need to be marked to survive. */
5638 survives_gc_p (Lisp_Object obj
)
5642 switch (XTYPE (obj
))
5649 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5653 survives_p
= XMISCANY (obj
)->gcmarkbit
;
5657 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5660 case Lisp_Vectorlike
:
5661 survives_p
= SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5665 survives_p
= CONS_MARKED_P (XCONS (obj
));
5669 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5676 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5681 /* Sweep: find all structures not marked, and free them. */
5686 /* Remove or mark entries in weak hash tables.
5687 This must be done before any object is unmarked. */
5688 sweep_weak_hash_tables ();
5691 #ifdef GC_CHECK_STRING_BYTES
5692 if (!noninteractive
)
5693 check_string_bytes (1);
5696 /* Put all unmarked conses on free list */
5698 register struct cons_block
*cblk
;
5699 struct cons_block
**cprev
= &cons_block
;
5700 register int lim
= cons_block_index
;
5701 register int num_free
= 0, num_used
= 0;
5705 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5709 int ilim
= (lim
+ BITS_PER_INT
- 1) / BITS_PER_INT
;
5711 /* Scan the mark bits an int at a time. */
5712 for (i
= 0; i
<= ilim
; i
++)
5714 if (cblk
->gcmarkbits
[i
] == -1)
5716 /* Fast path - all cons cells for this int are marked. */
5717 cblk
->gcmarkbits
[i
] = 0;
5718 num_used
+= BITS_PER_INT
;
5722 /* Some cons cells for this int are not marked.
5723 Find which ones, and free them. */
5724 int start
, pos
, stop
;
5726 start
= i
* BITS_PER_INT
;
5728 if (stop
> BITS_PER_INT
)
5729 stop
= BITS_PER_INT
;
5732 for (pos
= start
; pos
< stop
; pos
++)
5734 if (!CONS_MARKED_P (&cblk
->conses
[pos
]))
5737 cblk
->conses
[pos
].u
.chain
= cons_free_list
;
5738 cons_free_list
= &cblk
->conses
[pos
];
5740 cons_free_list
->car
= Vdead
;
5746 CONS_UNMARK (&cblk
->conses
[pos
]);
5752 lim
= CONS_BLOCK_SIZE
;
5753 /* If this block contains only free conses and we have already
5754 seen more than two blocks worth of free conses then deallocate
5756 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5758 *cprev
= cblk
->next
;
5759 /* Unhook from the free list. */
5760 cons_free_list
= cblk
->conses
[0].u
.chain
;
5761 lisp_align_free (cblk
);
5766 num_free
+= this_free
;
5767 cprev
= &cblk
->next
;
5770 total_conses
= num_used
;
5771 total_free_conses
= num_free
;
5774 /* Put all unmarked floats on free list */
5776 register struct float_block
*fblk
;
5777 struct float_block
**fprev
= &float_block
;
5778 register int lim
= float_block_index
;
5779 register int num_free
= 0, num_used
= 0;
5781 float_free_list
= 0;
5783 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
5787 for (i
= 0; i
< lim
; i
++)
5788 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
5791 fblk
->floats
[i
].u
.chain
= float_free_list
;
5792 float_free_list
= &fblk
->floats
[i
];
5797 FLOAT_UNMARK (&fblk
->floats
[i
]);
5799 lim
= FLOAT_BLOCK_SIZE
;
5800 /* If this block contains only free floats and we have already
5801 seen more than two blocks worth of free floats then deallocate
5803 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
5805 *fprev
= fblk
->next
;
5806 /* Unhook from the free list. */
5807 float_free_list
= fblk
->floats
[0].u
.chain
;
5808 lisp_align_free (fblk
);
5813 num_free
+= this_free
;
5814 fprev
= &fblk
->next
;
5817 total_floats
= num_used
;
5818 total_free_floats
= num_free
;
5821 /* Put all unmarked intervals on free list */
5823 register struct interval_block
*iblk
;
5824 struct interval_block
**iprev
= &interval_block
;
5825 register int lim
= interval_block_index
;
5826 register int num_free
= 0, num_used
= 0;
5828 interval_free_list
= 0;
5830 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
5835 for (i
= 0; i
< lim
; i
++)
5837 if (!iblk
->intervals
[i
].gcmarkbit
)
5839 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
5840 interval_free_list
= &iblk
->intervals
[i
];
5846 iblk
->intervals
[i
].gcmarkbit
= 0;
5849 lim
= INTERVAL_BLOCK_SIZE
;
5850 /* If this block contains only free intervals and we have already
5851 seen more than two blocks worth of free intervals then
5852 deallocate this block. */
5853 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
5855 *iprev
= iblk
->next
;
5856 /* Unhook from the free list. */
5857 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
5859 n_interval_blocks
--;
5863 num_free
+= this_free
;
5864 iprev
= &iblk
->next
;
5867 total_intervals
= num_used
;
5868 total_free_intervals
= num_free
;
5871 /* Put all unmarked symbols on free list */
5873 register struct symbol_block
*sblk
;
5874 struct symbol_block
**sprev
= &symbol_block
;
5875 register int lim
= symbol_block_index
;
5876 register int num_free
= 0, num_used
= 0;
5878 symbol_free_list
= NULL
;
5880 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
5883 struct Lisp_Symbol
*sym
= sblk
->symbols
;
5884 struct Lisp_Symbol
*end
= sym
+ lim
;
5886 for (; sym
< end
; ++sym
)
5888 /* Check if the symbol was created during loadup. In such a case
5889 it might be pointed to by pure bytecode which we don't trace,
5890 so we conservatively assume that it is live. */
5891 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
5893 if (!sym
->gcmarkbit
&& !pure_p
)
5895 if (sym
->redirect
== SYMBOL_LOCALIZED
)
5896 xfree (SYMBOL_BLV (sym
));
5897 sym
->next
= symbol_free_list
;
5898 symbol_free_list
= sym
;
5900 symbol_free_list
->function
= Vdead
;
5908 UNMARK_STRING (XSTRING (sym
->xname
));
5913 lim
= SYMBOL_BLOCK_SIZE
;
5914 /* If this block contains only free symbols and we have already
5915 seen more than two blocks worth of free symbols then deallocate
5917 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
5919 *sprev
= sblk
->next
;
5920 /* Unhook from the free list. */
5921 symbol_free_list
= sblk
->symbols
[0].next
;
5927 num_free
+= this_free
;
5928 sprev
= &sblk
->next
;
5931 total_symbols
= num_used
;
5932 total_free_symbols
= num_free
;
5935 /* Put all unmarked misc's on free list.
5936 For a marker, first unchain it from the buffer it points into. */
5938 register struct marker_block
*mblk
;
5939 struct marker_block
**mprev
= &marker_block
;
5940 register int lim
= marker_block_index
;
5941 register int num_free
= 0, num_used
= 0;
5943 marker_free_list
= 0;
5945 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
5950 for (i
= 0; i
< lim
; i
++)
5952 if (!mblk
->markers
[i
].u_any
.gcmarkbit
)
5954 if (mblk
->markers
[i
].u_any
.type
== Lisp_Misc_Marker
)
5955 unchain_marker (&mblk
->markers
[i
].u_marker
);
5956 /* Set the type of the freed object to Lisp_Misc_Free.
5957 We could leave the type alone, since nobody checks it,
5958 but this might catch bugs faster. */
5959 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
5960 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
5961 marker_free_list
= &mblk
->markers
[i
];
5967 mblk
->markers
[i
].u_any
.gcmarkbit
= 0;
5970 lim
= MARKER_BLOCK_SIZE
;
5971 /* If this block contains only free markers and we have already
5972 seen more than two blocks worth of free markers then deallocate
5974 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
5976 *mprev
= mblk
->next
;
5977 /* Unhook from the free list. */
5978 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
5984 num_free
+= this_free
;
5985 mprev
= &mblk
->next
;
5989 total_markers
= num_used
;
5990 total_free_markers
= num_free
;
5993 /* Free all unmarked buffers */
5995 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
5998 if (!VECTOR_MARKED_P (buffer
))
6001 prev
->next
= buffer
->next
;
6003 all_buffers
= buffer
->next
;
6004 next
= buffer
->next
;
6010 VECTOR_UNMARK (buffer
);
6011 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6012 prev
= buffer
, buffer
= buffer
->next
;
6016 /* Free all unmarked vectors */
6018 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6019 total_vector_size
= 0;
6022 if (!VECTOR_MARKED_P (vector
))
6025 prev
->next
= vector
->next
;
6027 all_vectors
= vector
->next
;
6028 next
= vector
->next
;
6036 VECTOR_UNMARK (vector
);
6037 if (vector
->size
& PSEUDOVECTOR_FLAG
)
6038 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
6040 total_vector_size
+= vector
->size
;
6041 prev
= vector
, vector
= vector
->next
;
6045 #ifdef GC_CHECK_STRING_BYTES
6046 if (!noninteractive
)
6047 check_string_bytes (1);
6054 /* Debugging aids. */
6056 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6057 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6058 This may be helpful in debugging Emacs's memory usage.
6059 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6064 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
6069 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6070 doc
: /* Return a list of counters that measure how much consing there has been.
6071 Each of these counters increments for a certain kind of object.
6072 The counters wrap around from the largest positive integer to zero.
6073 Garbage collection does not decrease them.
6074 The elements of the value are as follows:
6075 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6076 All are in units of 1 = one object consed
6077 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6079 MISCS include overlays, markers, and some internal types.
6080 Frames, windows, buffers, and subprocesses count as vectors
6081 (but the contents of a buffer's text do not count here). */)
6084 Lisp_Object consed
[8];
6086 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6087 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6088 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6089 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6090 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6091 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6092 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6093 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6095 return Flist (8, consed
);
6098 int suppress_checking
;
6101 die (const char *msg
, const char *file
, int line
)
6103 fprintf (stderr
, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6108 /* Initialization */
6111 init_alloc_once (void)
6113 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6115 pure_size
= PURESIZE
;
6116 pure_bytes_used
= 0;
6117 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6118 pure_bytes_used_before_overflow
= 0;
6120 /* Initialize the list of free aligned blocks. */
6123 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6125 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6129 ignore_warnings
= 1;
6130 #ifdef DOUG_LEA_MALLOC
6131 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6132 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6133 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6141 init_weak_hash_tables ();
6144 malloc_hysteresis
= 32;
6146 malloc_hysteresis
= 0;
6149 refill_memory_reserve ();
6151 ignore_warnings
= 0;
6153 byte_stack_list
= 0;
6155 consing_since_gc
= 0;
6156 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6157 gc_relative_threshold
= 0;
6164 byte_stack_list
= 0;
6166 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6167 setjmp_tested_p
= longjmps_done
= 0;
6170 Vgc_elapsed
= make_float (0.0);
6175 syms_of_alloc (void)
6177 DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold
,
6178 doc
: /* *Number of bytes of consing between garbage collections.
6179 Garbage collection can happen automatically once this many bytes have been
6180 allocated since the last garbage collection. All data types count.
6182 Garbage collection happens automatically only when `eval' is called.
6184 By binding this temporarily to a large number, you can effectively
6185 prevent garbage collection during a part of the program.
6186 See also `gc-cons-percentage'. */);
6188 DEFVAR_LISP ("gc-cons-percentage", Vgc_cons_percentage
,
6189 doc
: /* *Portion of the heap used for allocation.
6190 Garbage collection can happen automatically once this portion of the heap
6191 has been allocated since the last garbage collection.
6192 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6193 Vgc_cons_percentage
= make_float (0.1);
6195 DEFVAR_INT ("pure-bytes-used", pure_bytes_used
,
6196 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6198 DEFVAR_INT ("cons-cells-consed", cons_cells_consed
,
6199 doc
: /* Number of cons cells that have been consed so far. */);
6201 DEFVAR_INT ("floats-consed", floats_consed
,
6202 doc
: /* Number of floats that have been consed so far. */);
6204 DEFVAR_INT ("vector-cells-consed", vector_cells_consed
,
6205 doc
: /* Number of vector cells that have been consed so far. */);
6207 DEFVAR_INT ("symbols-consed", symbols_consed
,
6208 doc
: /* Number of symbols that have been consed so far. */);
6210 DEFVAR_INT ("string-chars-consed", string_chars_consed
,
6211 doc
: /* Number of string characters that have been consed so far. */);
6213 DEFVAR_INT ("misc-objects-consed", misc_objects_consed
,
6214 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6216 DEFVAR_INT ("intervals-consed", intervals_consed
,
6217 doc
: /* Number of intervals that have been consed so far. */);
6219 DEFVAR_INT ("strings-consed", strings_consed
,
6220 doc
: /* Number of strings that have been consed so far. */);
6222 DEFVAR_LISP ("purify-flag", Vpurify_flag
,
6223 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6224 This means that certain objects should be allocated in shared (pure) space.
6225 It can also be set to a hash-table, in which case this table is used to
6226 do hash-consing of the objects allocated to pure space. */);
6228 DEFVAR_BOOL ("garbage-collection-messages", garbage_collection_messages
,
6229 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6230 garbage_collection_messages
= 0;
6232 DEFVAR_LISP ("post-gc-hook", Vpost_gc_hook
,
6233 doc
: /* Hook run after garbage collection has finished. */);
6234 Vpost_gc_hook
= Qnil
;
6235 Qpost_gc_hook
= intern_c_string ("post-gc-hook");
6236 staticpro (&Qpost_gc_hook
);
6238 DEFVAR_LISP ("memory-signal-data", Vmemory_signal_data
,
6239 doc
: /* Precomputed `signal' argument for memory-full error. */);
6240 /* We build this in advance because if we wait until we need it, we might
6241 not be able to allocate the memory to hold it. */
6243 = pure_cons (Qerror
,
6244 pure_cons (make_pure_c_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"), Qnil
));
6246 DEFVAR_LISP ("memory-full", Vmemory_full
,
6247 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6248 Vmemory_full
= Qnil
;
6250 staticpro (&Qgc_cons_threshold
);
6251 Qgc_cons_threshold
= intern_c_string ("gc-cons-threshold");
6253 staticpro (&Qchar_table_extra_slots
);
6254 Qchar_table_extra_slots
= intern_c_string ("char-table-extra-slots");
6256 DEFVAR_LISP ("gc-elapsed", Vgc_elapsed
,
6257 doc
: /* Accumulated time elapsed in garbage collections.
6258 The time is in seconds as a floating point value. */);
6259 DEFVAR_INT ("gcs-done", gcs_done
,
6260 doc
: /* Accumulated number of garbage collections done. */);
6265 defsubr (&Smake_byte_code
);
6266 defsubr (&Smake_list
);
6267 defsubr (&Smake_vector
);
6268 defsubr (&Smake_string
);
6269 defsubr (&Smake_bool_vector
);
6270 defsubr (&Smake_symbol
);
6271 defsubr (&Smake_marker
);
6272 defsubr (&Spurecopy
);
6273 defsubr (&Sgarbage_collect
);
6274 defsubr (&Smemory_limit
);
6275 defsubr (&Smemory_use_counts
);
6277 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6278 defsubr (&Sgc_status
);