1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
3 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20 Boston, MA 02110-1301, USA. */
24 #include <limits.h> /* For CHAR_BIT. */
27 #include <stddef.h> /* For offsetof, used by PSEUDOVECSIZE. */
34 /* Note that this declares bzero on OSF/1. How dumb. */
38 #ifdef HAVE_GTK_AND_PTHREAD
42 /* This file is part of the core Lisp implementation, and thus must
43 deal with the real data structures. If the Lisp implementation is
44 replaced, this file likely will not be used. */
46 #undef HIDE_LISP_IMPLEMENTATION
49 #include "intervals.h"
55 #include "blockinput.h"
57 #include "syssignal.h"
60 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
61 memory. Can do this only if using gmalloc.c. */
63 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
64 #undef GC_MALLOC_CHECK
70 extern POINTER_TYPE
*sbrk ();
74 #define INCLUDED_FCNTL
86 #ifdef DOUG_LEA_MALLOC
89 /* malloc.h #defines this as size_t, at least in glibc2. */
90 #ifndef __malloc_size_t
91 #define __malloc_size_t int
94 /* Specify maximum number of areas to mmap. It would be nice to use a
95 value that explicitly means "no limit". */
97 #define MMAP_MAX_AREAS 100000000
99 #else /* not DOUG_LEA_MALLOC */
101 /* The following come from gmalloc.c. */
103 #define __malloc_size_t size_t
104 extern __malloc_size_t _bytes_used
;
105 extern __malloc_size_t __malloc_extra_blocks
;
107 #endif /* not DOUG_LEA_MALLOC */
109 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
111 /* When GTK uses the file chooser dialog, different backends can be loaded
112 dynamically. One such a backend is the Gnome VFS backend that gets loaded
113 if you run Gnome. That backend creates several threads and also allocates
116 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
117 functions below are called from malloc, there is a chance that one
118 of these threads preempts the Emacs main thread and the hook variables
119 end up in an inconsistent state. So we have a mutex to prevent that (note
120 that the backend handles concurrent access to malloc within its own threads
121 but Emacs code running in the main thread is not included in that control).
123 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
124 happens in one of the backend threads we will have two threads that tries
125 to run Emacs code at once, and the code is not prepared for that.
126 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
128 static pthread_mutex_t alloc_mutex
;
130 #define BLOCK_INPUT_ALLOC \
133 if (pthread_equal (pthread_self (), main_thread)) \
135 pthread_mutex_lock (&alloc_mutex); \
138 #define UNBLOCK_INPUT_ALLOC \
141 pthread_mutex_unlock (&alloc_mutex); \
142 if (pthread_equal (pthread_self (), main_thread)) \
147 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
149 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
150 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
152 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
154 /* Value of _bytes_used, when spare_memory was freed. */
156 static __malloc_size_t bytes_used_when_full
;
158 static __malloc_size_t bytes_used_when_reconsidered
;
160 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
161 to a struct Lisp_String. */
163 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
164 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
165 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
167 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
168 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
169 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
171 /* Value is the number of bytes/chars of S, a pointer to a struct
172 Lisp_String. This must be used instead of STRING_BYTES (S) or
173 S->size during GC, because S->size contains the mark bit for
176 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
177 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
179 /* Number of bytes of consing done since the last gc. */
181 int consing_since_gc
;
183 /* Count the amount of consing of various sorts of space. */
185 EMACS_INT cons_cells_consed
;
186 EMACS_INT floats_consed
;
187 EMACS_INT vector_cells_consed
;
188 EMACS_INT symbols_consed
;
189 EMACS_INT string_chars_consed
;
190 EMACS_INT misc_objects_consed
;
191 EMACS_INT intervals_consed
;
192 EMACS_INT strings_consed
;
194 /* Minimum number of bytes of consing since GC before next GC. */
196 EMACS_INT gc_cons_threshold
;
198 /* Similar minimum, computed from Vgc_cons_percentage. */
200 EMACS_INT gc_relative_threshold
;
202 static Lisp_Object Vgc_cons_percentage
;
204 /* Minimum number of bytes of consing since GC before next GC,
205 when memory is full. */
207 EMACS_INT memory_full_cons_threshold
;
209 /* Nonzero during GC. */
213 /* Nonzero means abort if try to GC.
214 This is for code which is written on the assumption that
215 no GC will happen, so as to verify that assumption. */
219 /* Nonzero means display messages at beginning and end of GC. */
221 int garbage_collection_messages
;
223 #ifndef VIRT_ADDR_VARIES
225 #endif /* VIRT_ADDR_VARIES */
226 int malloc_sbrk_used
;
228 #ifndef VIRT_ADDR_VARIES
230 #endif /* VIRT_ADDR_VARIES */
231 int malloc_sbrk_unused
;
233 /* Number of live and free conses etc. */
235 static int total_conses
, total_markers
, total_symbols
, total_vector_size
;
236 static int total_free_conses
, total_free_markers
, total_free_symbols
;
237 static int total_free_floats
, total_floats
;
239 /* Points to memory space allocated as "spare", to be freed if we run
240 out of memory. We keep one large block, four cons-blocks, and
241 two string blocks. */
243 char *spare_memory
[7];
245 /* Amount of spare memory to keep in large reserve block. */
247 #define SPARE_MEMORY (1 << 14)
249 /* Number of extra blocks malloc should get when it needs more core. */
251 static int malloc_hysteresis
;
253 /* Non-nil means defun should do purecopy on the function definition. */
255 Lisp_Object Vpurify_flag
;
257 /* Non-nil means we are handling a memory-full error. */
259 Lisp_Object Vmemory_full
;
263 /* Initialize it to a nonzero value to force it into data space
264 (rather than bss space). That way unexec will remap it into text
265 space (pure), on some systems. We have not implemented the
266 remapping on more recent systems because this is less important
267 nowadays than in the days of small memories and timesharing. */
269 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {1,};
270 #define PUREBEG (char *) pure
274 #define pure PURE_SEG_BITS /* Use shared memory segment */
275 #define PUREBEG (char *)PURE_SEG_BITS
277 #endif /* HAVE_SHM */
279 /* Pointer to the pure area, and its size. */
281 static char *purebeg
;
282 static size_t pure_size
;
284 /* Number of bytes of pure storage used before pure storage overflowed.
285 If this is non-zero, this implies that an overflow occurred. */
287 static size_t pure_bytes_used_before_overflow
;
289 /* Value is non-zero if P points into pure space. */
291 #define PURE_POINTER_P(P) \
292 (((PNTR_COMPARISON_TYPE) (P) \
293 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
294 && ((PNTR_COMPARISON_TYPE) (P) \
295 >= (PNTR_COMPARISON_TYPE) purebeg))
297 /* Total number of bytes allocated in pure storage. */
299 EMACS_INT pure_bytes_used
;
301 /* Index in pure at which next pure Lisp object will be allocated.. */
303 static EMACS_INT pure_bytes_used_lisp
;
305 /* Number of bytes allocated for non-Lisp objects in pure storage. */
307 static EMACS_INT pure_bytes_used_non_lisp
;
309 /* If nonzero, this is a warning delivered by malloc and not yet
312 char *pending_malloc_warning
;
314 /* Pre-computed signal argument for use when memory is exhausted. */
316 Lisp_Object Vmemory_signal_data
;
318 /* Maximum amount of C stack to save when a GC happens. */
320 #ifndef MAX_SAVE_STACK
321 #define MAX_SAVE_STACK 16000
324 /* Buffer in which we save a copy of the C stack at each GC. */
329 /* Non-zero means ignore malloc warnings. Set during initialization.
330 Currently not used. */
334 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
336 /* Hook run after GC has finished. */
338 Lisp_Object Vpost_gc_hook
, Qpost_gc_hook
;
340 Lisp_Object Vgc_elapsed
; /* accumulated elapsed time in GC */
341 EMACS_INT gcs_done
; /* accumulated GCs */
343 static void mark_buffer
P_ ((Lisp_Object
));
344 extern void mark_kboards
P_ ((void));
345 extern void mark_backtrace
P_ ((void));
346 static void gc_sweep
P_ ((void));
347 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
348 static void mark_face_cache
P_ ((struct face_cache
*));
350 #ifdef HAVE_WINDOW_SYSTEM
351 extern void mark_fringe_data
P_ ((void));
352 static void mark_image
P_ ((struct image
*));
353 static void mark_image_cache
P_ ((struct frame
*));
354 #endif /* HAVE_WINDOW_SYSTEM */
356 static struct Lisp_String
*allocate_string
P_ ((void));
357 static void compact_small_strings
P_ ((void));
358 static void free_large_strings
P_ ((void));
359 static void sweep_strings
P_ ((void));
361 extern int message_enable_multibyte
;
363 /* When scanning the C stack for live Lisp objects, Emacs keeps track
364 of what memory allocated via lisp_malloc is intended for what
365 purpose. This enumeration specifies the type of memory. */
376 /* Keep the following vector-like types together, with
377 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
378 first. Or change the code of live_vector_p, for instance. */
386 static POINTER_TYPE
*lisp_align_malloc
P_ ((size_t, enum mem_type
));
387 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
388 void refill_memory_reserve ();
391 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
393 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
394 #include <stdio.h> /* For fprintf. */
397 /* A unique object in pure space used to make some Lisp objects
398 on free lists recognizable in O(1). */
402 #ifdef GC_MALLOC_CHECK
404 enum mem_type allocated_mem_type
;
405 int dont_register_blocks
;
407 #endif /* GC_MALLOC_CHECK */
409 /* A node in the red-black tree describing allocated memory containing
410 Lisp data. Each such block is recorded with its start and end
411 address when it is allocated, and removed from the tree when it
414 A red-black tree is a balanced binary tree with the following
417 1. Every node is either red or black.
418 2. Every leaf is black.
419 3. If a node is red, then both of its children are black.
420 4. Every simple path from a node to a descendant leaf contains
421 the same number of black nodes.
422 5. The root is always black.
424 When nodes are inserted into the tree, or deleted from the tree,
425 the tree is "fixed" so that these properties are always true.
427 A red-black tree with N internal nodes has height at most 2
428 log(N+1). Searches, insertions and deletions are done in O(log N).
429 Please see a text book about data structures for a detailed
430 description of red-black trees. Any book worth its salt should
435 /* Children of this node. These pointers are never NULL. When there
436 is no child, the value is MEM_NIL, which points to a dummy node. */
437 struct mem_node
*left
, *right
;
439 /* The parent of this node. In the root node, this is NULL. */
440 struct mem_node
*parent
;
442 /* Start and end of allocated region. */
446 enum {MEM_BLACK
, MEM_RED
} color
;
452 /* Base address of stack. Set in main. */
454 Lisp_Object
*stack_base
;
456 /* Root of the tree describing allocated Lisp memory. */
458 static struct mem_node
*mem_root
;
460 /* Lowest and highest known address in the heap. */
462 static void *min_heap_address
, *max_heap_address
;
464 /* Sentinel node of the tree. */
466 static struct mem_node mem_z
;
467 #define MEM_NIL &mem_z
469 static POINTER_TYPE
*lisp_malloc
P_ ((size_t, enum mem_type
));
470 static struct Lisp_Vector
*allocate_vectorlike
P_ ((EMACS_INT
, enum mem_type
));
471 static void lisp_free
P_ ((POINTER_TYPE
*));
472 static void mark_stack
P_ ((void));
473 static int live_vector_p
P_ ((struct mem_node
*, void *));
474 static int live_buffer_p
P_ ((struct mem_node
*, void *));
475 static int live_string_p
P_ ((struct mem_node
*, void *));
476 static int live_cons_p
P_ ((struct mem_node
*, void *));
477 static int live_symbol_p
P_ ((struct mem_node
*, void *));
478 static int live_float_p
P_ ((struct mem_node
*, void *));
479 static int live_misc_p
P_ ((struct mem_node
*, void *));
480 static void mark_maybe_object
P_ ((Lisp_Object
));
481 static void mark_memory
P_ ((void *, void *, int));
482 static void mem_init
P_ ((void));
483 static struct mem_node
*mem_insert
P_ ((void *, void *, enum mem_type
));
484 static void mem_insert_fixup
P_ ((struct mem_node
*));
485 static void mem_rotate_left
P_ ((struct mem_node
*));
486 static void mem_rotate_right
P_ ((struct mem_node
*));
487 static void mem_delete
P_ ((struct mem_node
*));
488 static void mem_delete_fixup
P_ ((struct mem_node
*));
489 static INLINE
struct mem_node
*mem_find
P_ ((void *));
492 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
493 static void check_gcpros
P_ ((void));
496 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
498 /* Recording what needs to be marked for gc. */
500 struct gcpro
*gcprolist
;
502 /* Addresses of staticpro'd variables. Initialize it to a nonzero
503 value; otherwise some compilers put it into BSS. */
505 #define NSTATICS 1280
506 Lisp_Object
*staticvec
[NSTATICS
] = {&Vpurify_flag
};
508 /* Index of next unused slot in staticvec. */
512 static POINTER_TYPE
*pure_alloc
P_ ((size_t, int));
515 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
516 ALIGNMENT must be a power of 2. */
518 #define ALIGN(ptr, ALIGNMENT) \
519 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
520 & ~((ALIGNMENT) - 1)))
524 /************************************************************************
526 ************************************************************************/
528 /* Function malloc calls this if it finds we are near exhausting storage. */
534 pending_malloc_warning
= str
;
538 /* Display an already-pending malloc warning. */
541 display_malloc_warning ()
543 call3 (intern ("display-warning"),
545 build_string (pending_malloc_warning
),
546 intern ("emergency"));
547 pending_malloc_warning
= 0;
551 #ifdef DOUG_LEA_MALLOC
552 # define BYTES_USED (mallinfo ().uordblks)
554 # define BYTES_USED _bytes_used
557 /* Called if we can't allocate relocatable space for a buffer. */
560 buffer_memory_full ()
562 /* If buffers use the relocating allocator, no need to free
563 spare_memory, because we may have plenty of malloc space left
564 that we could get, and if we don't, the malloc that fails will
565 itself cause spare_memory to be freed. If buffers don't use the
566 relocating allocator, treat this like any other failing
573 /* This used to call error, but if we've run out of memory, we could
574 get infinite recursion trying to build the string. */
575 xsignal (Qnil
, Vmemory_signal_data
);
579 #ifdef XMALLOC_OVERRUN_CHECK
581 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
582 and a 16 byte trailer around each block.
584 The header consists of 12 fixed bytes + a 4 byte integer contaning the
585 original block size, while the trailer consists of 16 fixed bytes.
587 The header is used to detect whether this block has been allocated
588 through these functions -- as it seems that some low-level libc
589 functions may bypass the malloc hooks.
593 #define XMALLOC_OVERRUN_CHECK_SIZE 16
595 static char xmalloc_overrun_check_header
[XMALLOC_OVERRUN_CHECK_SIZE
-4] =
596 { 0x9a, 0x9b, 0xae, 0xaf,
597 0xbf, 0xbe, 0xce, 0xcf,
598 0xea, 0xeb, 0xec, 0xed };
600 static char xmalloc_overrun_check_trailer
[XMALLOC_OVERRUN_CHECK_SIZE
] =
601 { 0xaa, 0xab, 0xac, 0xad,
602 0xba, 0xbb, 0xbc, 0xbd,
603 0xca, 0xcb, 0xcc, 0xcd,
604 0xda, 0xdb, 0xdc, 0xdd };
606 /* Macros to insert and extract the block size in the header. */
608 #define XMALLOC_PUT_SIZE(ptr, size) \
609 (ptr[-1] = (size & 0xff), \
610 ptr[-2] = ((size >> 8) & 0xff), \
611 ptr[-3] = ((size >> 16) & 0xff), \
612 ptr[-4] = ((size >> 24) & 0xff))
614 #define XMALLOC_GET_SIZE(ptr) \
615 (size_t)((unsigned)(ptr[-1]) | \
616 ((unsigned)(ptr[-2]) << 8) | \
617 ((unsigned)(ptr[-3]) << 16) | \
618 ((unsigned)(ptr[-4]) << 24))
621 /* The call depth in overrun_check functions. For example, this might happen:
623 overrun_check_malloc()
624 -> malloc -> (via hook)_-> emacs_blocked_malloc
625 -> overrun_check_malloc
626 call malloc (hooks are NULL, so real malloc is called).
627 malloc returns 10000.
628 add overhead, return 10016.
629 <- (back in overrun_check_malloc)
630 add overhead again, return 10032
631 xmalloc returns 10032.
636 overrun_check_free(10032)
638 free(10016) <- crash, because 10000 is the original pointer. */
640 static int check_depth
;
642 /* Like malloc, but wraps allocated block with header and trailer. */
645 overrun_check_malloc (size
)
648 register unsigned char *val
;
649 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
651 val
= (unsigned char *) malloc (size
+ overhead
);
652 if (val
&& check_depth
== 1)
654 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
655 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
656 XMALLOC_PUT_SIZE(val
, size
);
657 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
660 return (POINTER_TYPE
*)val
;
664 /* Like realloc, but checks old block for overrun, and wraps new block
665 with header and trailer. */
668 overrun_check_realloc (block
, size
)
672 register unsigned char *val
= (unsigned char *)block
;
673 size_t overhead
= ++check_depth
== 1 ? XMALLOC_OVERRUN_CHECK_SIZE
*2 : 0;
677 && bcmp (xmalloc_overrun_check_header
,
678 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
679 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
681 size_t osize
= XMALLOC_GET_SIZE (val
);
682 if (bcmp (xmalloc_overrun_check_trailer
,
684 XMALLOC_OVERRUN_CHECK_SIZE
))
686 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
687 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
688 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
691 val
= (unsigned char *) realloc ((POINTER_TYPE
*)val
, size
+ overhead
);
693 if (val
&& check_depth
== 1)
695 bcopy (xmalloc_overrun_check_header
, val
, XMALLOC_OVERRUN_CHECK_SIZE
- 4);
696 val
+= XMALLOC_OVERRUN_CHECK_SIZE
;
697 XMALLOC_PUT_SIZE(val
, size
);
698 bcopy (xmalloc_overrun_check_trailer
, val
+ size
, XMALLOC_OVERRUN_CHECK_SIZE
);
701 return (POINTER_TYPE
*)val
;
704 /* Like free, but checks block for overrun. */
707 overrun_check_free (block
)
710 unsigned char *val
= (unsigned char *)block
;
715 && bcmp (xmalloc_overrun_check_header
,
716 val
- XMALLOC_OVERRUN_CHECK_SIZE
,
717 XMALLOC_OVERRUN_CHECK_SIZE
- 4) == 0)
719 size_t osize
= XMALLOC_GET_SIZE (val
);
720 if (bcmp (xmalloc_overrun_check_trailer
,
722 XMALLOC_OVERRUN_CHECK_SIZE
))
724 #ifdef XMALLOC_CLEAR_FREE_MEMORY
725 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
726 memset (val
, 0xff, osize
+ XMALLOC_OVERRUN_CHECK_SIZE
*2);
728 bzero (val
+ osize
, XMALLOC_OVERRUN_CHECK_SIZE
);
729 val
-= XMALLOC_OVERRUN_CHECK_SIZE
;
730 bzero (val
, XMALLOC_OVERRUN_CHECK_SIZE
);
741 #define malloc overrun_check_malloc
742 #define realloc overrun_check_realloc
743 #define free overrun_check_free
747 /* Like malloc but check for no memory and block interrupt input.. */
753 register POINTER_TYPE
*val
;
756 val
= (POINTER_TYPE
*) malloc (size
);
765 /* Like realloc but check for no memory and block interrupt input.. */
768 xrealloc (block
, size
)
772 register POINTER_TYPE
*val
;
775 /* We must call malloc explicitly when BLOCK is 0, since some
776 reallocs don't do this. */
778 val
= (POINTER_TYPE
*) malloc (size
);
780 val
= (POINTER_TYPE
*) realloc (block
, size
);
783 if (!val
&& size
) memory_full ();
788 /* Like free but block interrupt input. */
797 /* We don't call refill_memory_reserve here
798 because that duplicates doing so in emacs_blocked_free
799 and the criterion should go there. */
803 /* Like strdup, but uses xmalloc. */
809 size_t len
= strlen (s
) + 1;
810 char *p
= (char *) xmalloc (len
);
816 /* Unwind for SAFE_ALLOCA */
819 safe_alloca_unwind (arg
)
822 register struct Lisp_Save_Value
*p
= XSAVE_VALUE (arg
);
832 /* Like malloc but used for allocating Lisp data. NBYTES is the
833 number of bytes to allocate, TYPE describes the intended use of the
834 allcated memory block (for strings, for conses, ...). */
837 static void *lisp_malloc_loser
;
840 static POINTER_TYPE
*
841 lisp_malloc (nbytes
, type
)
849 #ifdef GC_MALLOC_CHECK
850 allocated_mem_type
= type
;
853 val
= (void *) malloc (nbytes
);
856 /* If the memory just allocated cannot be addressed thru a Lisp
857 object's pointer, and it needs to be,
858 that's equivalent to running out of memory. */
859 if (val
&& type
!= MEM_TYPE_NON_LISP
)
862 XSETCONS (tem
, (char *) val
+ nbytes
- 1);
863 if ((char *) XCONS (tem
) != (char *) val
+ nbytes
- 1)
865 lisp_malloc_loser
= val
;
872 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
873 if (val
&& type
!= MEM_TYPE_NON_LISP
)
874 mem_insert (val
, (char *) val
+ nbytes
, type
);
883 /* Free BLOCK. This must be called to free memory allocated with a
884 call to lisp_malloc. */
892 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
893 mem_delete (mem_find (block
));
898 /* Allocation of aligned blocks of memory to store Lisp data. */
899 /* The entry point is lisp_align_malloc which returns blocks of at most */
900 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
902 /* Use posix_memalloc if the system has it and we're using the system's
903 malloc (because our gmalloc.c routines don't have posix_memalign although
904 its memalloc could be used). */
905 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
906 #define USE_POSIX_MEMALIGN 1
909 /* BLOCK_ALIGN has to be a power of 2. */
910 #define BLOCK_ALIGN (1 << 10)
912 /* Padding to leave at the end of a malloc'd block. This is to give
913 malloc a chance to minimize the amount of memory wasted to alignment.
914 It should be tuned to the particular malloc library used.
915 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
916 posix_memalign on the other hand would ideally prefer a value of 4
917 because otherwise, there's 1020 bytes wasted between each ablocks.
918 In Emacs, testing shows that those 1020 can most of the time be
919 efficiently used by malloc to place other objects, so a value of 0 can
920 still preferable unless you have a lot of aligned blocks and virtually
922 #define BLOCK_PADDING 0
923 #define BLOCK_BYTES \
924 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
926 /* Internal data structures and constants. */
928 #define ABLOCKS_SIZE 16
930 /* An aligned block of memory. */
935 char payload
[BLOCK_BYTES
];
936 struct ablock
*next_free
;
938 /* `abase' is the aligned base of the ablocks. */
939 /* It is overloaded to hold the virtual `busy' field that counts
940 the number of used ablock in the parent ablocks.
941 The first ablock has the `busy' field, the others have the `abase'
942 field. To tell the difference, we assume that pointers will have
943 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
944 is used to tell whether the real base of the parent ablocks is `abase'
945 (if not, the word before the first ablock holds a pointer to the
947 struct ablocks
*abase
;
948 /* The padding of all but the last ablock is unused. The padding of
949 the last ablock in an ablocks is not allocated. */
951 char padding
[BLOCK_PADDING
];
955 /* A bunch of consecutive aligned blocks. */
958 struct ablock blocks
[ABLOCKS_SIZE
];
961 /* Size of the block requested from malloc or memalign. */
962 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
964 #define ABLOCK_ABASE(block) \
965 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
966 ? (struct ablocks *)(block) \
969 /* Virtual `busy' field. */
970 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
972 /* Pointer to the (not necessarily aligned) malloc block. */
973 #ifdef USE_POSIX_MEMALIGN
974 #define ABLOCKS_BASE(abase) (abase)
976 #define ABLOCKS_BASE(abase) \
977 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
980 /* The list of free ablock. */
981 static struct ablock
*free_ablock
;
983 /* Allocate an aligned block of nbytes.
984 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
985 smaller or equal to BLOCK_BYTES. */
986 static POINTER_TYPE
*
987 lisp_align_malloc (nbytes
, type
)
992 struct ablocks
*abase
;
994 eassert (nbytes
<= BLOCK_BYTES
);
998 #ifdef GC_MALLOC_CHECK
999 allocated_mem_type
= type
;
1005 EMACS_INT aligned
; /* int gets warning casting to 64-bit pointer. */
1007 #ifdef DOUG_LEA_MALLOC
1008 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1009 because mapped region contents are not preserved in
1011 mallopt (M_MMAP_MAX
, 0);
1014 #ifdef USE_POSIX_MEMALIGN
1016 int err
= posix_memalign (&base
, BLOCK_ALIGN
, ABLOCKS_BYTES
);
1022 base
= malloc (ABLOCKS_BYTES
);
1023 abase
= ALIGN (base
, BLOCK_ALIGN
);
1032 aligned
= (base
== abase
);
1034 ((void**)abase
)[-1] = base
;
1036 #ifdef DOUG_LEA_MALLOC
1037 /* Back to a reasonable maximum of mmap'ed areas. */
1038 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1042 /* If the memory just allocated cannot be addressed thru a Lisp
1043 object's pointer, and it needs to be, that's equivalent to
1044 running out of memory. */
1045 if (type
!= MEM_TYPE_NON_LISP
)
1048 char *end
= (char *) base
+ ABLOCKS_BYTES
- 1;
1049 XSETCONS (tem
, end
);
1050 if ((char *) XCONS (tem
) != end
)
1052 lisp_malloc_loser
= base
;
1060 /* Initialize the blocks and put them on the free list.
1061 Is `base' was not properly aligned, we can't use the last block. */
1062 for (i
= 0; i
< (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1); i
++)
1064 abase
->blocks
[i
].abase
= abase
;
1065 abase
->blocks
[i
].x
.next_free
= free_ablock
;
1066 free_ablock
= &abase
->blocks
[i
];
1068 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (long) aligned
;
1070 eassert (0 == ((EMACS_UINT
)abase
) % BLOCK_ALIGN
);
1071 eassert (ABLOCK_ABASE (&abase
->blocks
[3]) == abase
); /* 3 is arbitrary */
1072 eassert (ABLOCK_ABASE (&abase
->blocks
[0]) == abase
);
1073 eassert (ABLOCKS_BASE (abase
) == base
);
1074 eassert (aligned
== (long) ABLOCKS_BUSY (abase
));
1077 abase
= ABLOCK_ABASE (free_ablock
);
1078 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (2 + (long) ABLOCKS_BUSY (abase
));
1080 free_ablock
= free_ablock
->x
.next_free
;
1082 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1083 if (val
&& type
!= MEM_TYPE_NON_LISP
)
1084 mem_insert (val
, (char *) val
+ nbytes
, type
);
1091 eassert (0 == ((EMACS_UINT
)val
) % BLOCK_ALIGN
);
1096 lisp_align_free (block
)
1097 POINTER_TYPE
*block
;
1099 struct ablock
*ablock
= block
;
1100 struct ablocks
*abase
= ABLOCK_ABASE (ablock
);
1103 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1104 mem_delete (mem_find (block
));
1106 /* Put on free list. */
1107 ablock
->x
.next_free
= free_ablock
;
1108 free_ablock
= ablock
;
1109 /* Update busy count. */
1110 ABLOCKS_BUSY (abase
) = (struct ablocks
*) (-2 + (long) ABLOCKS_BUSY (abase
));
1112 if (2 > (long) ABLOCKS_BUSY (abase
))
1113 { /* All the blocks are free. */
1114 int i
= 0, aligned
= (long) ABLOCKS_BUSY (abase
);
1115 struct ablock
**tem
= &free_ablock
;
1116 struct ablock
*atop
= &abase
->blocks
[aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1];
1120 if (*tem
>= (struct ablock
*) abase
&& *tem
< atop
)
1123 *tem
= (*tem
)->x
.next_free
;
1126 tem
= &(*tem
)->x
.next_free
;
1128 eassert ((aligned
& 1) == aligned
);
1129 eassert (i
== (aligned
? ABLOCKS_SIZE
: ABLOCKS_SIZE
- 1));
1130 #ifdef USE_POSIX_MEMALIGN
1131 eassert ((unsigned long)ABLOCKS_BASE (abase
) % BLOCK_ALIGN
== 0);
1133 free (ABLOCKS_BASE (abase
));
1138 /* Return a new buffer structure allocated from the heap with
1139 a call to lisp_malloc. */
1145 = (struct buffer
*) lisp_malloc (sizeof (struct buffer
),
1151 #ifndef SYSTEM_MALLOC
1153 /* Arranging to disable input signals while we're in malloc.
1155 This only works with GNU malloc. To help out systems which can't
1156 use GNU malloc, all the calls to malloc, realloc, and free
1157 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1158 pair; unfortunately, we have no idea what C library functions
1159 might call malloc, so we can't really protect them unless you're
1160 using GNU malloc. Fortunately, most of the major operating systems
1161 can use GNU malloc. */
1165 #ifndef DOUG_LEA_MALLOC
1166 extern void * (*__malloc_hook
) P_ ((size_t, const void *));
1167 extern void * (*__realloc_hook
) P_ ((void *, size_t, const void *));
1168 extern void (*__free_hook
) P_ ((void *, const void *));
1169 /* Else declared in malloc.h, perhaps with an extra arg. */
1170 #endif /* DOUG_LEA_MALLOC */
1171 static void * (*old_malloc_hook
) P_ ((size_t, const void *));
1172 static void * (*old_realloc_hook
) P_ ((void *, size_t, const void*));
1173 static void (*old_free_hook
) P_ ((void*, const void*));
1175 /* This function is used as the hook for free to call. */
1178 emacs_blocked_free (ptr
, ptr2
)
1182 EMACS_INT bytes_used_now
;
1186 #ifdef GC_MALLOC_CHECK
1192 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1195 "Freeing `%p' which wasn't allocated with malloc\n", ptr
);
1200 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1204 #endif /* GC_MALLOC_CHECK */
1206 __free_hook
= old_free_hook
;
1209 /* If we released our reserve (due to running out of memory),
1210 and we have a fair amount free once again,
1211 try to set aside another reserve in case we run out once more. */
1212 if (! NILP (Vmemory_full
)
1213 /* Verify there is enough space that even with the malloc
1214 hysteresis this call won't run out again.
1215 The code here is correct as long as SPARE_MEMORY
1216 is substantially larger than the block size malloc uses. */
1217 && (bytes_used_when_full
1218 > ((bytes_used_when_reconsidered
= BYTES_USED
)
1219 + max (malloc_hysteresis
, 4) * SPARE_MEMORY
)))
1220 refill_memory_reserve ();
1222 __free_hook
= emacs_blocked_free
;
1223 UNBLOCK_INPUT_ALLOC
;
1227 /* This function is the malloc hook that Emacs uses. */
1230 emacs_blocked_malloc (size
, ptr
)
1237 __malloc_hook
= old_malloc_hook
;
1238 #ifdef DOUG_LEA_MALLOC
1239 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
1241 __malloc_extra_blocks
= malloc_hysteresis
;
1244 value
= (void *) malloc (size
);
1246 #ifdef GC_MALLOC_CHECK
1248 struct mem_node
*m
= mem_find (value
);
1251 fprintf (stderr
, "Malloc returned %p which is already in use\n",
1253 fprintf (stderr
, "Region in use is %p...%p, %u bytes, type %d\n",
1254 m
->start
, m
->end
, (char *) m
->end
- (char *) m
->start
,
1259 if (!dont_register_blocks
)
1261 mem_insert (value
, (char *) value
+ max (1, size
), allocated_mem_type
);
1262 allocated_mem_type
= MEM_TYPE_NON_LISP
;
1265 #endif /* GC_MALLOC_CHECK */
1267 __malloc_hook
= emacs_blocked_malloc
;
1268 UNBLOCK_INPUT_ALLOC
;
1270 /* fprintf (stderr, "%p malloc\n", value); */
1275 /* This function is the realloc hook that Emacs uses. */
1278 emacs_blocked_realloc (ptr
, size
, ptr2
)
1286 __realloc_hook
= old_realloc_hook
;
1288 #ifdef GC_MALLOC_CHECK
1291 struct mem_node
*m
= mem_find (ptr
);
1292 if (m
== MEM_NIL
|| m
->start
!= ptr
)
1295 "Realloc of %p which wasn't allocated with malloc\n",
1303 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1305 /* Prevent malloc from registering blocks. */
1306 dont_register_blocks
= 1;
1307 #endif /* GC_MALLOC_CHECK */
1309 value
= (void *) realloc (ptr
, size
);
1311 #ifdef GC_MALLOC_CHECK
1312 dont_register_blocks
= 0;
1315 struct mem_node
*m
= mem_find (value
);
1318 fprintf (stderr
, "Realloc returns memory that is already in use\n");
1322 /* Can't handle zero size regions in the red-black tree. */
1323 mem_insert (value
, (char *) value
+ max (size
, 1), MEM_TYPE_NON_LISP
);
1326 /* fprintf (stderr, "%p <- realloc\n", value); */
1327 #endif /* GC_MALLOC_CHECK */
1329 __realloc_hook
= emacs_blocked_realloc
;
1330 UNBLOCK_INPUT_ALLOC
;
1336 #ifdef HAVE_GTK_AND_PTHREAD
1337 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1338 normal malloc. Some thread implementations need this as they call
1339 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1340 calls malloc because it is the first call, and we have an endless loop. */
1343 reset_malloc_hooks ()
1349 #endif /* HAVE_GTK_AND_PTHREAD */
1352 /* Called from main to set up malloc to use our hooks. */
1355 uninterrupt_malloc ()
1357 #ifdef HAVE_GTK_AND_PTHREAD
1358 pthread_mutexattr_t attr
;
1360 /* GLIBC has a faster way to do this, but lets keep it portable.
1361 This is according to the Single UNIX Specification. */
1362 pthread_mutexattr_init (&attr
);
1363 pthread_mutexattr_settype (&attr
, PTHREAD_MUTEX_RECURSIVE
);
1364 pthread_mutex_init (&alloc_mutex
, &attr
);
1365 #endif /* HAVE_GTK_AND_PTHREAD */
1367 if (__free_hook
!= emacs_blocked_free
)
1368 old_free_hook
= __free_hook
;
1369 __free_hook
= emacs_blocked_free
;
1371 if (__malloc_hook
!= emacs_blocked_malloc
)
1372 old_malloc_hook
= __malloc_hook
;
1373 __malloc_hook
= emacs_blocked_malloc
;
1375 if (__realloc_hook
!= emacs_blocked_realloc
)
1376 old_realloc_hook
= __realloc_hook
;
1377 __realloc_hook
= emacs_blocked_realloc
;
1380 #endif /* not SYNC_INPUT */
1381 #endif /* not SYSTEM_MALLOC */
1385 /***********************************************************************
1387 ***********************************************************************/
1389 /* Number of intervals allocated in an interval_block structure.
1390 The 1020 is 1024 minus malloc overhead. */
1392 #define INTERVAL_BLOCK_SIZE \
1393 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1395 /* Intervals are allocated in chunks in form of an interval_block
1398 struct interval_block
1400 /* Place `intervals' first, to preserve alignment. */
1401 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
1402 struct interval_block
*next
;
1405 /* Current interval block. Its `next' pointer points to older
1408 struct interval_block
*interval_block
;
1410 /* Index in interval_block above of the next unused interval
1413 static int interval_block_index
;
1415 /* Number of free and live intervals. */
1417 static int total_free_intervals
, total_intervals
;
1419 /* List of free intervals. */
1421 INTERVAL interval_free_list
;
1423 /* Total number of interval blocks now in use. */
1425 int n_interval_blocks
;
1428 /* Initialize interval allocation. */
1433 interval_block
= NULL
;
1434 interval_block_index
= INTERVAL_BLOCK_SIZE
;
1435 interval_free_list
= 0;
1436 n_interval_blocks
= 0;
1440 /* Return a new interval. */
1447 /* eassert (!handling_signal); */
1453 if (interval_free_list
)
1455 val
= interval_free_list
;
1456 interval_free_list
= INTERVAL_PARENT (interval_free_list
);
1460 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
1462 register struct interval_block
*newi
;
1464 newi
= (struct interval_block
*) lisp_malloc (sizeof *newi
,
1467 newi
->next
= interval_block
;
1468 interval_block
= newi
;
1469 interval_block_index
= 0;
1470 n_interval_blocks
++;
1472 val
= &interval_block
->intervals
[interval_block_index
++];
1479 consing_since_gc
+= sizeof (struct interval
);
1481 RESET_INTERVAL (val
);
1487 /* Mark Lisp objects in interval I. */
1490 mark_interval (i
, dummy
)
1491 register INTERVAL i
;
1494 eassert (!i
->gcmarkbit
); /* Intervals are never shared. */
1496 mark_object (i
->plist
);
1500 /* Mark the interval tree rooted in TREE. Don't call this directly;
1501 use the macro MARK_INTERVAL_TREE instead. */
1504 mark_interval_tree (tree
)
1505 register INTERVAL tree
;
1507 /* No need to test if this tree has been marked already; this
1508 function is always called through the MARK_INTERVAL_TREE macro,
1509 which takes care of that. */
1511 traverse_intervals_noorder (tree
, mark_interval
, Qnil
);
1515 /* Mark the interval tree rooted in I. */
1517 #define MARK_INTERVAL_TREE(i) \
1519 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1520 mark_interval_tree (i); \
1524 #define UNMARK_BALANCE_INTERVALS(i) \
1526 if (! NULL_INTERVAL_P (i)) \
1527 (i) = balance_intervals (i); \
1531 /* Number support. If NO_UNION_TYPE isn't in effect, we
1532 can't create number objects in macros. */
1540 obj
.s
.type
= Lisp_Int
;
1545 /***********************************************************************
1547 ***********************************************************************/
1549 /* Lisp_Strings are allocated in string_block structures. When a new
1550 string_block is allocated, all the Lisp_Strings it contains are
1551 added to a free-list string_free_list. When a new Lisp_String is
1552 needed, it is taken from that list. During the sweep phase of GC,
1553 string_blocks that are entirely free are freed, except two which
1556 String data is allocated from sblock structures. Strings larger
1557 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1558 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1560 Sblocks consist internally of sdata structures, one for each
1561 Lisp_String. The sdata structure points to the Lisp_String it
1562 belongs to. The Lisp_String points back to the `u.data' member of
1563 its sdata structure.
1565 When a Lisp_String is freed during GC, it is put back on
1566 string_free_list, and its `data' member and its sdata's `string'
1567 pointer is set to null. The size of the string is recorded in the
1568 `u.nbytes' member of the sdata. So, sdata structures that are no
1569 longer used, can be easily recognized, and it's easy to compact the
1570 sblocks of small strings which we do in compact_small_strings. */
1572 /* Size in bytes of an sblock structure used for small strings. This
1573 is 8192 minus malloc overhead. */
1575 #define SBLOCK_SIZE 8188
1577 /* Strings larger than this are considered large strings. String data
1578 for large strings is allocated from individual sblocks. */
1580 #define LARGE_STRING_BYTES 1024
1582 /* Structure describing string memory sub-allocated from an sblock.
1583 This is where the contents of Lisp strings are stored. */
1587 /* Back-pointer to the string this sdata belongs to. If null, this
1588 structure is free, and the NBYTES member of the union below
1589 contains the string's byte size (the same value that STRING_BYTES
1590 would return if STRING were non-null). If non-null, STRING_BYTES
1591 (STRING) is the size of the data, and DATA contains the string's
1593 struct Lisp_String
*string
;
1595 #ifdef GC_CHECK_STRING_BYTES
1598 unsigned char data
[1];
1600 #define SDATA_NBYTES(S) (S)->nbytes
1601 #define SDATA_DATA(S) (S)->data
1603 #else /* not GC_CHECK_STRING_BYTES */
1607 /* When STRING in non-null. */
1608 unsigned char data
[1];
1610 /* When STRING is null. */
1615 #define SDATA_NBYTES(S) (S)->u.nbytes
1616 #define SDATA_DATA(S) (S)->u.data
1618 #endif /* not GC_CHECK_STRING_BYTES */
1622 /* Structure describing a block of memory which is sub-allocated to
1623 obtain string data memory for strings. Blocks for small strings
1624 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1625 as large as needed. */
1630 struct sblock
*next
;
1632 /* Pointer to the next free sdata block. This points past the end
1633 of the sblock if there isn't any space left in this block. */
1634 struct sdata
*next_free
;
1636 /* Start of data. */
1637 struct sdata first_data
;
1640 /* Number of Lisp strings in a string_block structure. The 1020 is
1641 1024 minus malloc overhead. */
1643 #define STRING_BLOCK_SIZE \
1644 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1646 /* Structure describing a block from which Lisp_String structures
1651 /* Place `strings' first, to preserve alignment. */
1652 struct Lisp_String strings
[STRING_BLOCK_SIZE
];
1653 struct string_block
*next
;
1656 /* Head and tail of the list of sblock structures holding Lisp string
1657 data. We always allocate from current_sblock. The NEXT pointers
1658 in the sblock structures go from oldest_sblock to current_sblock. */
1660 static struct sblock
*oldest_sblock
, *current_sblock
;
1662 /* List of sblocks for large strings. */
1664 static struct sblock
*large_sblocks
;
1666 /* List of string_block structures, and how many there are. */
1668 static struct string_block
*string_blocks
;
1669 static int n_string_blocks
;
1671 /* Free-list of Lisp_Strings. */
1673 static struct Lisp_String
*string_free_list
;
1675 /* Number of live and free Lisp_Strings. */
1677 static int total_strings
, total_free_strings
;
1679 /* Number of bytes used by live strings. */
1681 static int total_string_size
;
1683 /* Given a pointer to a Lisp_String S which is on the free-list
1684 string_free_list, return a pointer to its successor in the
1687 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1689 /* Return a pointer to the sdata structure belonging to Lisp string S.
1690 S must be live, i.e. S->data must not be null. S->data is actually
1691 a pointer to the `u.data' member of its sdata structure; the
1692 structure starts at a constant offset in front of that. */
1694 #ifdef GC_CHECK_STRING_BYTES
1696 #define SDATA_OF_STRING(S) \
1697 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1698 - sizeof (EMACS_INT)))
1700 #else /* not GC_CHECK_STRING_BYTES */
1702 #define SDATA_OF_STRING(S) \
1703 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1705 #endif /* not GC_CHECK_STRING_BYTES */
1708 #ifdef GC_CHECK_STRING_OVERRUN
1710 /* We check for overrun in string data blocks by appending a small
1711 "cookie" after each allocated string data block, and check for the
1712 presence of this cookie during GC. */
1714 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1715 static char string_overrun_cookie
[GC_STRING_OVERRUN_COOKIE_SIZE
] =
1716 { 0xde, 0xad, 0xbe, 0xef };
1719 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1722 /* Value is the size of an sdata structure large enough to hold NBYTES
1723 bytes of string data. The value returned includes a terminating
1724 NUL byte, the size of the sdata structure, and padding. */
1726 #ifdef GC_CHECK_STRING_BYTES
1728 #define SDATA_SIZE(NBYTES) \
1729 ((sizeof (struct Lisp_String *) \
1731 + sizeof (EMACS_INT) \
1732 + sizeof (EMACS_INT) - 1) \
1733 & ~(sizeof (EMACS_INT) - 1))
1735 #else /* not GC_CHECK_STRING_BYTES */
1737 #define SDATA_SIZE(NBYTES) \
1738 ((sizeof (struct Lisp_String *) \
1740 + sizeof (EMACS_INT) - 1) \
1741 & ~(sizeof (EMACS_INT) - 1))
1743 #endif /* not GC_CHECK_STRING_BYTES */
1745 /* Extra bytes to allocate for each string. */
1747 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1749 /* Initialize string allocation. Called from init_alloc_once. */
1754 total_strings
= total_free_strings
= total_string_size
= 0;
1755 oldest_sblock
= current_sblock
= large_sblocks
= NULL
;
1756 string_blocks
= NULL
;
1757 n_string_blocks
= 0;
1758 string_free_list
= NULL
;
1759 empty_unibyte_string
= make_pure_string ("", 0, 0, 0);
1760 empty_multibyte_string
= make_pure_string ("", 0, 0, 1);
1764 #ifdef GC_CHECK_STRING_BYTES
1766 static int check_string_bytes_count
;
1768 void check_string_bytes
P_ ((int));
1769 void check_sblock
P_ ((struct sblock
*));
1771 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1774 /* Like GC_STRING_BYTES, but with debugging check. */
1778 struct Lisp_String
*s
;
1780 int nbytes
= (s
->size_byte
< 0 ? s
->size
& ~ARRAY_MARK_FLAG
: s
->size_byte
);
1781 if (!PURE_POINTER_P (s
)
1783 && nbytes
!= SDATA_NBYTES (SDATA_OF_STRING (s
)))
1788 /* Check validity of Lisp strings' string_bytes member in B. */
1794 struct sdata
*from
, *end
, *from_end
;
1798 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
1800 /* Compute the next FROM here because copying below may
1801 overwrite data we need to compute it. */
1804 /* Check that the string size recorded in the string is the
1805 same as the one recorded in the sdata structure. */
1807 CHECK_STRING_BYTES (from
->string
);
1810 nbytes
= GC_STRING_BYTES (from
->string
);
1812 nbytes
= SDATA_NBYTES (from
);
1814 nbytes
= SDATA_SIZE (nbytes
);
1815 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
1820 /* Check validity of Lisp strings' string_bytes member. ALL_P
1821 non-zero means check all strings, otherwise check only most
1822 recently allocated strings. Used for hunting a bug. */
1825 check_string_bytes (all_p
)
1832 for (b
= large_sblocks
; b
; b
= b
->next
)
1834 struct Lisp_String
*s
= b
->first_data
.string
;
1836 CHECK_STRING_BYTES (s
);
1839 for (b
= oldest_sblock
; b
; b
= b
->next
)
1843 check_sblock (current_sblock
);
1846 #endif /* GC_CHECK_STRING_BYTES */
1848 #ifdef GC_CHECK_STRING_FREE_LIST
1850 /* Walk through the string free list looking for bogus next pointers.
1851 This may catch buffer overrun from a previous string. */
1854 check_string_free_list ()
1856 struct Lisp_String
*s
;
1858 /* Pop a Lisp_String off the free-list. */
1859 s
= string_free_list
;
1862 if ((unsigned)s
< 1024)
1864 s
= NEXT_FREE_LISP_STRING (s
);
1868 #define check_string_free_list()
1871 /* Return a new Lisp_String. */
1873 static struct Lisp_String
*
1876 struct Lisp_String
*s
;
1878 /* eassert (!handling_signal); */
1884 /* If the free-list is empty, allocate a new string_block, and
1885 add all the Lisp_Strings in it to the free-list. */
1886 if (string_free_list
== NULL
)
1888 struct string_block
*b
;
1891 b
= (struct string_block
*) lisp_malloc (sizeof *b
, MEM_TYPE_STRING
);
1892 bzero (b
, sizeof *b
);
1893 b
->next
= string_blocks
;
1897 for (i
= STRING_BLOCK_SIZE
- 1; i
>= 0; --i
)
1900 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
1901 string_free_list
= s
;
1904 total_free_strings
+= STRING_BLOCK_SIZE
;
1907 check_string_free_list ();
1909 /* Pop a Lisp_String off the free-list. */
1910 s
= string_free_list
;
1911 string_free_list
= NEXT_FREE_LISP_STRING (s
);
1917 /* Probably not strictly necessary, but play it safe. */
1918 bzero (s
, sizeof *s
);
1920 --total_free_strings
;
1923 consing_since_gc
+= sizeof *s
;
1925 #ifdef GC_CHECK_STRING_BYTES
1932 if (++check_string_bytes_count
== 200)
1934 check_string_bytes_count
= 0;
1935 check_string_bytes (1);
1938 check_string_bytes (0);
1940 #endif /* GC_CHECK_STRING_BYTES */
1946 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1947 plus a NUL byte at the end. Allocate an sdata structure for S, and
1948 set S->data to its `u.data' member. Store a NUL byte at the end of
1949 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1950 S->data if it was initially non-null. */
1953 allocate_string_data (s
, nchars
, nbytes
)
1954 struct Lisp_String
*s
;
1957 struct sdata
*data
, *old_data
;
1959 int needed
, old_nbytes
;
1961 /* Determine the number of bytes needed to store NBYTES bytes
1963 needed
= SDATA_SIZE (nbytes
);
1964 old_data
= s
->data
? SDATA_OF_STRING (s
) : NULL
;
1965 old_nbytes
= GC_STRING_BYTES (s
);
1971 if (nbytes
> LARGE_STRING_BYTES
)
1973 size_t size
= sizeof *b
- sizeof (struct sdata
) + needed
;
1975 #ifdef DOUG_LEA_MALLOC
1976 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1977 because mapped region contents are not preserved in
1980 In case you think of allowing it in a dumped Emacs at the
1981 cost of not being able to re-dump, there's another reason:
1982 mmap'ed data typically have an address towards the top of the
1983 address space, which won't fit into an EMACS_INT (at least on
1984 32-bit systems with the current tagging scheme). --fx */
1986 mallopt (M_MMAP_MAX
, 0);
1990 b
= (struct sblock
*) lisp_malloc (size
+ GC_STRING_EXTRA
, MEM_TYPE_NON_LISP
);
1992 #ifdef DOUG_LEA_MALLOC
1993 /* Back to a reasonable maximum of mmap'ed areas. */
1995 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1999 b
->next_free
= &b
->first_data
;
2000 b
->first_data
.string
= NULL
;
2001 b
->next
= large_sblocks
;
2004 else if (current_sblock
== NULL
2005 || (((char *) current_sblock
+ SBLOCK_SIZE
2006 - (char *) current_sblock
->next_free
)
2007 < (needed
+ GC_STRING_EXTRA
)))
2009 /* Not enough room in the current sblock. */
2010 b
= (struct sblock
*) lisp_malloc (SBLOCK_SIZE
, MEM_TYPE_NON_LISP
);
2011 b
->next_free
= &b
->first_data
;
2012 b
->first_data
.string
= NULL
;
2016 current_sblock
->next
= b
;
2024 data
= b
->next_free
;
2025 b
->next_free
= (struct sdata
*) ((char *) data
+ needed
+ GC_STRING_EXTRA
);
2032 s
->data
= SDATA_DATA (data
);
2033 #ifdef GC_CHECK_STRING_BYTES
2034 SDATA_NBYTES (data
) = nbytes
;
2037 s
->size_byte
= nbytes
;
2038 s
->data
[nbytes
] = '\0';
2039 #ifdef GC_CHECK_STRING_OVERRUN
2040 bcopy (string_overrun_cookie
, (char *) data
+ needed
,
2041 GC_STRING_OVERRUN_COOKIE_SIZE
);
2044 /* If S had already data assigned, mark that as free by setting its
2045 string back-pointer to null, and recording the size of the data
2049 SDATA_NBYTES (old_data
) = old_nbytes
;
2050 old_data
->string
= NULL
;
2053 consing_since_gc
+= needed
;
2057 /* Sweep and compact strings. */
2062 struct string_block
*b
, *next
;
2063 struct string_block
*live_blocks
= NULL
;
2065 string_free_list
= NULL
;
2066 total_strings
= total_free_strings
= 0;
2067 total_string_size
= 0;
2069 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2070 for (b
= string_blocks
; b
; b
= next
)
2073 struct Lisp_String
*free_list_before
= string_free_list
;
2077 for (i
= 0; i
< STRING_BLOCK_SIZE
; ++i
)
2079 struct Lisp_String
*s
= b
->strings
+ i
;
2083 /* String was not on free-list before. */
2084 if (STRING_MARKED_P (s
))
2086 /* String is live; unmark it and its intervals. */
2089 if (!NULL_INTERVAL_P (s
->intervals
))
2090 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2093 total_string_size
+= STRING_BYTES (s
);
2097 /* String is dead. Put it on the free-list. */
2098 struct sdata
*data
= SDATA_OF_STRING (s
);
2100 /* Save the size of S in its sdata so that we know
2101 how large that is. Reset the sdata's string
2102 back-pointer so that we know it's free. */
2103 #ifdef GC_CHECK_STRING_BYTES
2104 if (GC_STRING_BYTES (s
) != SDATA_NBYTES (data
))
2107 data
->u
.nbytes
= GC_STRING_BYTES (s
);
2109 data
->string
= NULL
;
2111 /* Reset the strings's `data' member so that we
2115 /* Put the string on the free-list. */
2116 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2117 string_free_list
= s
;
2123 /* S was on the free-list before. Put it there again. */
2124 NEXT_FREE_LISP_STRING (s
) = string_free_list
;
2125 string_free_list
= s
;
2130 /* Free blocks that contain free Lisp_Strings only, except
2131 the first two of them. */
2132 if (nfree
== STRING_BLOCK_SIZE
2133 && total_free_strings
> STRING_BLOCK_SIZE
)
2137 string_free_list
= free_list_before
;
2141 total_free_strings
+= nfree
;
2142 b
->next
= live_blocks
;
2147 check_string_free_list ();
2149 string_blocks
= live_blocks
;
2150 free_large_strings ();
2151 compact_small_strings ();
2153 check_string_free_list ();
2157 /* Free dead large strings. */
2160 free_large_strings ()
2162 struct sblock
*b
, *next
;
2163 struct sblock
*live_blocks
= NULL
;
2165 for (b
= large_sblocks
; b
; b
= next
)
2169 if (b
->first_data
.string
== NULL
)
2173 b
->next
= live_blocks
;
2178 large_sblocks
= live_blocks
;
2182 /* Compact data of small strings. Free sblocks that don't contain
2183 data of live strings after compaction. */
2186 compact_small_strings ()
2188 struct sblock
*b
, *tb
, *next
;
2189 struct sdata
*from
, *to
, *end
, *tb_end
;
2190 struct sdata
*to_end
, *from_end
;
2192 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2193 to, and TB_END is the end of TB. */
2195 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2196 to
= &tb
->first_data
;
2198 /* Step through the blocks from the oldest to the youngest. We
2199 expect that old blocks will stabilize over time, so that less
2200 copying will happen this way. */
2201 for (b
= oldest_sblock
; b
; b
= b
->next
)
2204 xassert ((char *) end
<= (char *) b
+ SBLOCK_SIZE
);
2206 for (from
= &b
->first_data
; from
< end
; from
= from_end
)
2208 /* Compute the next FROM here because copying below may
2209 overwrite data we need to compute it. */
2212 #ifdef GC_CHECK_STRING_BYTES
2213 /* Check that the string size recorded in the string is the
2214 same as the one recorded in the sdata structure. */
2216 && GC_STRING_BYTES (from
->string
) != SDATA_NBYTES (from
))
2218 #endif /* GC_CHECK_STRING_BYTES */
2221 nbytes
= GC_STRING_BYTES (from
->string
);
2223 nbytes
= SDATA_NBYTES (from
);
2225 if (nbytes
> LARGE_STRING_BYTES
)
2228 nbytes
= SDATA_SIZE (nbytes
);
2229 from_end
= (struct sdata
*) ((char *) from
+ nbytes
+ GC_STRING_EXTRA
);
2231 #ifdef GC_CHECK_STRING_OVERRUN
2232 if (bcmp (string_overrun_cookie
,
2233 ((char *) from_end
) - GC_STRING_OVERRUN_COOKIE_SIZE
,
2234 GC_STRING_OVERRUN_COOKIE_SIZE
))
2238 /* FROM->string non-null means it's alive. Copy its data. */
2241 /* If TB is full, proceed with the next sblock. */
2242 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2243 if (to_end
> tb_end
)
2247 tb_end
= (struct sdata
*) ((char *) tb
+ SBLOCK_SIZE
);
2248 to
= &tb
->first_data
;
2249 to_end
= (struct sdata
*) ((char *) to
+ nbytes
+ GC_STRING_EXTRA
);
2252 /* Copy, and update the string's `data' pointer. */
2255 xassert (tb
!= b
|| to
<= from
);
2256 safe_bcopy ((char *) from
, (char *) to
, nbytes
+ GC_STRING_EXTRA
);
2257 to
->string
->data
= SDATA_DATA (to
);
2260 /* Advance past the sdata we copied to. */
2266 /* The rest of the sblocks following TB don't contain live data, so
2267 we can free them. */
2268 for (b
= tb
->next
; b
; b
= next
)
2276 current_sblock
= tb
;
2280 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
2281 doc
: /* Return a newly created string of length LENGTH, with INIT in each element.
2282 LENGTH must be an integer.
2283 INIT must be an integer that represents a character. */)
2285 Lisp_Object length
, init
;
2287 register Lisp_Object val
;
2288 register unsigned char *p
, *end
;
2291 CHECK_NATNUM (length
);
2292 CHECK_NUMBER (init
);
2295 if (SINGLE_BYTE_CHAR_P (c
))
2297 nbytes
= XINT (length
);
2298 val
= make_uninit_string (nbytes
);
2300 end
= p
+ SCHARS (val
);
2306 unsigned char str
[MAX_MULTIBYTE_LENGTH
];
2307 int len
= CHAR_STRING (c
, str
);
2309 nbytes
= len
* XINT (length
);
2310 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
2315 bcopy (str
, p
, len
);
2325 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
2326 doc
: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2327 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2329 Lisp_Object length
, init
;
2331 register Lisp_Object val
;
2332 struct Lisp_Bool_Vector
*p
;
2334 int length_in_chars
, length_in_elts
, bits_per_value
;
2336 CHECK_NATNUM (length
);
2338 bits_per_value
= sizeof (EMACS_INT
) * BOOL_VECTOR_BITS_PER_CHAR
;
2340 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
2341 length_in_chars
= ((XFASTINT (length
) + BOOL_VECTOR_BITS_PER_CHAR
- 1)
2342 / BOOL_VECTOR_BITS_PER_CHAR
);
2344 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2345 slot `size' of the struct Lisp_Bool_Vector. */
2346 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
2347 p
= XBOOL_VECTOR (val
);
2349 /* Get rid of any bits that would cause confusion. */
2351 XSETBOOL_VECTOR (val
, p
);
2352 p
->size
= XFASTINT (length
);
2354 real_init
= (NILP (init
) ? 0 : -1);
2355 for (i
= 0; i
< length_in_chars
; i
++)
2356 p
->data
[i
] = real_init
;
2358 /* Clear the extraneous bits in the last byte. */
2359 if (XINT (length
) != length_in_chars
* BOOL_VECTOR_BITS_PER_CHAR
)
2360 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
2361 &= (1 << (XINT (length
) % BOOL_VECTOR_BITS_PER_CHAR
)) - 1;
2367 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2368 of characters from the contents. This string may be unibyte or
2369 multibyte, depending on the contents. */
2372 make_string (contents
, nbytes
)
2373 const char *contents
;
2376 register Lisp_Object val
;
2377 int nchars
, multibyte_nbytes
;
2379 parse_str_as_multibyte (contents
, nbytes
, &nchars
, &multibyte_nbytes
);
2380 if (nbytes
== nchars
|| nbytes
!= multibyte_nbytes
)
2381 /* CONTENTS contains no multibyte sequences or contains an invalid
2382 multibyte sequence. We must make unibyte string. */
2383 val
= make_unibyte_string (contents
, nbytes
);
2385 val
= make_multibyte_string (contents
, nchars
, nbytes
);
2390 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2393 make_unibyte_string (contents
, length
)
2394 const char *contents
;
2397 register Lisp_Object val
;
2398 val
= make_uninit_string (length
);
2399 bcopy (contents
, SDATA (val
), length
);
2400 STRING_SET_UNIBYTE (val
);
2405 /* Make a multibyte string from NCHARS characters occupying NBYTES
2406 bytes at CONTENTS. */
2409 make_multibyte_string (contents
, nchars
, nbytes
)
2410 const char *contents
;
2413 register Lisp_Object val
;
2414 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2415 bcopy (contents
, SDATA (val
), nbytes
);
2420 /* Make a string from NCHARS characters occupying NBYTES bytes at
2421 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2424 make_string_from_bytes (contents
, nchars
, nbytes
)
2425 const char *contents
;
2428 register Lisp_Object val
;
2429 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2430 bcopy (contents
, SDATA (val
), nbytes
);
2431 if (SBYTES (val
) == SCHARS (val
))
2432 STRING_SET_UNIBYTE (val
);
2437 /* Make a string from NCHARS characters occupying NBYTES bytes at
2438 CONTENTS. The argument MULTIBYTE controls whether to label the
2439 string as multibyte. If NCHARS is negative, it counts the number of
2440 characters by itself. */
2443 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
2444 const char *contents
;
2448 register Lisp_Object val
;
2453 nchars
= multibyte_chars_in_text (contents
, nbytes
);
2457 val
= make_uninit_multibyte_string (nchars
, nbytes
);
2458 bcopy (contents
, SDATA (val
), nbytes
);
2460 STRING_SET_UNIBYTE (val
);
2465 /* Make a string from the data at STR, treating it as multibyte if the
2472 return make_string (str
, strlen (str
));
2476 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2477 occupying LENGTH bytes. */
2480 make_uninit_string (length
)
2486 return empty_unibyte_string
;
2487 val
= make_uninit_multibyte_string (length
, length
);
2488 STRING_SET_UNIBYTE (val
);
2493 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2494 which occupy NBYTES bytes. */
2497 make_uninit_multibyte_string (nchars
, nbytes
)
2501 struct Lisp_String
*s
;
2506 return empty_multibyte_string
;
2508 s
= allocate_string ();
2509 allocate_string_data (s
, nchars
, nbytes
);
2510 XSETSTRING (string
, s
);
2511 string_chars_consed
+= nbytes
;
2517 /***********************************************************************
2519 ***********************************************************************/
2521 /* We store float cells inside of float_blocks, allocating a new
2522 float_block with malloc whenever necessary. Float cells reclaimed
2523 by GC are put on a free list to be reallocated before allocating
2524 any new float cells from the latest float_block. */
2526 #define FLOAT_BLOCK_SIZE \
2527 (((BLOCK_BYTES - sizeof (struct float_block *) \
2528 /* The compiler might add padding at the end. */ \
2529 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2530 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2532 #define GETMARKBIT(block,n) \
2533 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2534 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2537 #define SETMARKBIT(block,n) \
2538 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2539 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2541 #define UNSETMARKBIT(block,n) \
2542 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2543 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2545 #define FLOAT_BLOCK(fptr) \
2546 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2548 #define FLOAT_INDEX(fptr) \
2549 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2553 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2554 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
2555 int gcmarkbits
[1 + FLOAT_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2556 struct float_block
*next
;
2559 #define FLOAT_MARKED_P(fptr) \
2560 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2562 #define FLOAT_MARK(fptr) \
2563 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2565 #define FLOAT_UNMARK(fptr) \
2566 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2568 /* Current float_block. */
2570 struct float_block
*float_block
;
2572 /* Index of first unused Lisp_Float in the current float_block. */
2574 int float_block_index
;
2576 /* Total number of float blocks now in use. */
2580 /* Free-list of Lisp_Floats. */
2582 struct Lisp_Float
*float_free_list
;
2585 /* Initialize float allocation. */
2591 float_block_index
= FLOAT_BLOCK_SIZE
; /* Force alloc of new float_block. */
2592 float_free_list
= 0;
2597 /* Explicitly free a float cell by putting it on the free-list. */
2601 struct Lisp_Float
*ptr
;
2603 ptr
->u
.chain
= float_free_list
;
2604 float_free_list
= ptr
;
2608 /* Return a new float object with value FLOAT_VALUE. */
2611 make_float (float_value
)
2614 register Lisp_Object val
;
2616 /* eassert (!handling_signal); */
2622 if (float_free_list
)
2624 /* We use the data field for chaining the free list
2625 so that we won't use the same field that has the mark bit. */
2626 XSETFLOAT (val
, float_free_list
);
2627 float_free_list
= float_free_list
->u
.chain
;
2631 if (float_block_index
== FLOAT_BLOCK_SIZE
)
2633 register struct float_block
*new;
2635 new = (struct float_block
*) lisp_align_malloc (sizeof *new,
2637 new->next
= float_block
;
2638 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2640 float_block_index
= 0;
2643 XSETFLOAT (val
, &float_block
->floats
[float_block_index
]);
2644 float_block_index
++;
2651 XFLOAT_DATA (val
) = float_value
;
2652 eassert (!FLOAT_MARKED_P (XFLOAT (val
)));
2653 consing_since_gc
+= sizeof (struct Lisp_Float
);
2660 /***********************************************************************
2662 ***********************************************************************/
2664 /* We store cons cells inside of cons_blocks, allocating a new
2665 cons_block with malloc whenever necessary. Cons cells reclaimed by
2666 GC are put on a free list to be reallocated before allocating
2667 any new cons cells from the latest cons_block. */
2669 #define CONS_BLOCK_SIZE \
2670 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2671 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2673 #define CONS_BLOCK(fptr) \
2674 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2676 #define CONS_INDEX(fptr) \
2677 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2681 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2682 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
2683 int gcmarkbits
[1 + CONS_BLOCK_SIZE
/ (sizeof(int) * CHAR_BIT
)];
2684 struct cons_block
*next
;
2687 #define CONS_MARKED_P(fptr) \
2688 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2690 #define CONS_MARK(fptr) \
2691 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2693 #define CONS_UNMARK(fptr) \
2694 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2696 /* Current cons_block. */
2698 struct cons_block
*cons_block
;
2700 /* Index of first unused Lisp_Cons in the current block. */
2702 int cons_block_index
;
2704 /* Free-list of Lisp_Cons structures. */
2706 struct Lisp_Cons
*cons_free_list
;
2708 /* Total number of cons blocks now in use. */
2713 /* Initialize cons allocation. */
2719 cons_block_index
= CONS_BLOCK_SIZE
; /* Force alloc of new cons_block. */
2725 /* Explicitly free a cons cell by putting it on the free-list. */
2729 struct Lisp_Cons
*ptr
;
2731 ptr
->u
.chain
= cons_free_list
;
2735 cons_free_list
= ptr
;
2738 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
2739 doc
: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2741 Lisp_Object car
, cdr
;
2743 register Lisp_Object val
;
2745 /* eassert (!handling_signal); */
2753 /* We use the cdr for chaining the free list
2754 so that we won't use the same field that has the mark bit. */
2755 XSETCONS (val
, cons_free_list
);
2756 cons_free_list
= cons_free_list
->u
.chain
;
2760 if (cons_block_index
== CONS_BLOCK_SIZE
)
2762 register struct cons_block
*new;
2763 new = (struct cons_block
*) lisp_align_malloc (sizeof *new,
2765 bzero ((char *) new->gcmarkbits
, sizeof new->gcmarkbits
);
2766 new->next
= cons_block
;
2768 cons_block_index
= 0;
2771 XSETCONS (val
, &cons_block
->conses
[cons_block_index
]);
2781 eassert (!CONS_MARKED_P (XCONS (val
)));
2782 consing_since_gc
+= sizeof (struct Lisp_Cons
);
2783 cons_cells_consed
++;
2787 /* Get an error now if there's any junk in the cons free list. */
2791 #ifdef GC_CHECK_CONS_LIST
2792 struct Lisp_Cons
*tail
= cons_free_list
;
2795 tail
= tail
->u
.chain
;
2799 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2805 return Fcons (arg1
, Qnil
);
2810 Lisp_Object arg1
, arg2
;
2812 return Fcons (arg1
, Fcons (arg2
, Qnil
));
2817 list3 (arg1
, arg2
, arg3
)
2818 Lisp_Object arg1
, arg2
, arg3
;
2820 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
2825 list4 (arg1
, arg2
, arg3
, arg4
)
2826 Lisp_Object arg1
, arg2
, arg3
, arg4
;
2828 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
2833 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
2834 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
2836 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
2837 Fcons (arg5
, Qnil
)))));
2841 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
2842 doc
: /* Return a newly created list with specified arguments as elements.
2843 Any number of arguments, even zero arguments, are allowed.
2844 usage: (list &rest OBJECTS) */)
2847 register Lisp_Object
*args
;
2849 register Lisp_Object val
;
2855 val
= Fcons (args
[nargs
], val
);
2861 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
2862 doc
: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2864 register Lisp_Object length
, init
;
2866 register Lisp_Object val
;
2869 CHECK_NATNUM (length
);
2870 size
= XFASTINT (length
);
2875 val
= Fcons (init
, val
);
2880 val
= Fcons (init
, val
);
2885 val
= Fcons (init
, val
);
2890 val
= Fcons (init
, val
);
2895 val
= Fcons (init
, val
);
2910 /***********************************************************************
2912 ***********************************************************************/
2914 /* Singly-linked list of all vectors. */
2916 struct Lisp_Vector
*all_vectors
;
2918 /* Total number of vector-like objects now in use. */
2923 /* Value is a pointer to a newly allocated Lisp_Vector structure
2924 with room for LEN Lisp_Objects. */
2926 static struct Lisp_Vector
*
2927 allocate_vectorlike (len
, type
)
2931 struct Lisp_Vector
*p
;
2934 #ifdef DOUG_LEA_MALLOC
2935 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2936 because mapped region contents are not preserved in
2939 mallopt (M_MMAP_MAX
, 0);
2943 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2944 /* eassert (!handling_signal); */
2946 nbytes
= sizeof *p
+ (len
- 1) * sizeof p
->contents
[0];
2947 p
= (struct Lisp_Vector
*) lisp_malloc (nbytes
, type
);
2949 #ifdef DOUG_LEA_MALLOC
2950 /* Back to a reasonable maximum of mmap'ed areas. */
2952 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
2956 consing_since_gc
+= nbytes
;
2957 vector_cells_consed
+= len
;
2963 p
->next
= all_vectors
;
2975 /* Allocate a vector with NSLOTS slots. */
2977 struct Lisp_Vector
*
2978 allocate_vector (nslots
)
2981 struct Lisp_Vector
*v
= allocate_vectorlike (nslots
, MEM_TYPE_VECTOR
);
2987 /* Allocate other vector-like structures. */
2989 struct Lisp_Hash_Table
*
2990 allocate_hash_table ()
2992 EMACS_INT len
= VECSIZE (struct Lisp_Hash_Table
);
2993 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_HASH_TABLE
);
2997 for (i
= 0; i
< len
; ++i
)
2998 v
->contents
[i
] = Qnil
;
3000 return (struct Lisp_Hash_Table
*) v
;
3007 EMACS_INT len
= VECSIZE (struct window
);
3008 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_WINDOW
);
3011 for (i
= 0; i
< len
; ++i
)
3012 v
->contents
[i
] = Qnil
;
3015 return (struct window
*) v
;
3022 EMACS_INT len
= VECSIZE (struct frame
);
3023 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_FRAME
);
3026 for (i
= 0; i
< len
; ++i
)
3027 v
->contents
[i
] = make_number (0);
3029 return (struct frame
*) v
;
3033 struct Lisp_Process
*
3036 /* Memory-footprint of the object in nb of Lisp_Object fields. */
3037 EMACS_INT memlen
= VECSIZE (struct Lisp_Process
);
3038 /* Size if we only count the actual Lisp_Object fields (which need to be
3039 traced by the GC). */
3040 EMACS_INT lisplen
= PSEUDOVECSIZE (struct Lisp_Process
, pid
);
3041 struct Lisp_Vector
*v
= allocate_vectorlike (memlen
, MEM_TYPE_PROCESS
);
3044 for (i
= 0; i
< lisplen
; ++i
)
3045 v
->contents
[i
] = Qnil
;
3048 return (struct Lisp_Process
*) v
;
3052 struct Lisp_Vector
*
3053 allocate_other_vector (len
)
3056 struct Lisp_Vector
*v
= allocate_vectorlike (len
, MEM_TYPE_VECTOR
);
3059 for (i
= 0; i
< len
; ++i
)
3060 v
->contents
[i
] = Qnil
;
3067 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
3068 doc
: /* Return a newly created vector of length LENGTH, with each element being INIT.
3069 See also the function `vector'. */)
3071 register Lisp_Object length
, init
;
3074 register EMACS_INT sizei
;
3076 register struct Lisp_Vector
*p
;
3078 CHECK_NATNUM (length
);
3079 sizei
= XFASTINT (length
);
3081 p
= allocate_vector (sizei
);
3082 for (index
= 0; index
< sizei
; index
++)
3083 p
->contents
[index
] = init
;
3085 XSETVECTOR (vector
, p
);
3090 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
3091 doc
: /* Return a newly created char-table, with purpose PURPOSE.
3092 Each element is initialized to INIT, which defaults to nil.
3093 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
3094 The property's value should be an integer between 0 and 10. */)
3096 register Lisp_Object purpose
, init
;
3100 CHECK_SYMBOL (purpose
);
3101 n
= Fget (purpose
, Qchar_table_extra_slots
);
3103 if (XINT (n
) < 0 || XINT (n
) > 10)
3104 args_out_of_range (n
, Qnil
);
3105 /* Add 2 to the size for the defalt and parent slots. */
3106 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
3108 XCHAR_TABLE (vector
)->top
= Qt
;
3109 XCHAR_TABLE (vector
)->parent
= Qnil
;
3110 XCHAR_TABLE (vector
)->purpose
= purpose
;
3111 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3116 /* Return a newly created sub char table with slots initialized by INIT.
3117 Since a sub char table does not appear as a top level Emacs Lisp
3118 object, we don't need a Lisp interface to make it. */
3121 make_sub_char_table (init
)
3125 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), init
);
3126 XCHAR_TABLE (vector
)->top
= Qnil
;
3127 XCHAR_TABLE (vector
)->defalt
= Qnil
;
3128 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
3133 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
3134 doc
: /* Return a newly created vector with specified arguments as elements.
3135 Any number of arguments, even zero arguments, are allowed.
3136 usage: (vector &rest OBJECTS) */)
3141 register Lisp_Object len
, val
;
3143 register struct Lisp_Vector
*p
;
3145 XSETFASTINT (len
, nargs
);
3146 val
= Fmake_vector (len
, Qnil
);
3148 for (index
= 0; index
< nargs
; index
++)
3149 p
->contents
[index
] = args
[index
];
3154 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
3155 doc
: /* Create a byte-code object with specified arguments as elements.
3156 The arguments should be the arglist, bytecode-string, constant vector,
3157 stack size, (optional) doc string, and (optional) interactive spec.
3158 The first four arguments are required; at most six have any
3160 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3165 register Lisp_Object len
, val
;
3167 register struct Lisp_Vector
*p
;
3169 XSETFASTINT (len
, nargs
);
3170 if (!NILP (Vpurify_flag
))
3171 val
= make_pure_vector ((EMACS_INT
) nargs
);
3173 val
= Fmake_vector (len
, Qnil
);
3175 if (STRINGP (args
[1]) && STRING_MULTIBYTE (args
[1]))
3176 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3177 earlier because they produced a raw 8-bit string for byte-code
3178 and now such a byte-code string is loaded as multibyte while
3179 raw 8-bit characters converted to multibyte form. Thus, now we
3180 must convert them back to the original unibyte form. */
3181 args
[1] = Fstring_as_unibyte (args
[1]);
3184 for (index
= 0; index
< nargs
; index
++)
3186 if (!NILP (Vpurify_flag
))
3187 args
[index
] = Fpurecopy (args
[index
]);
3188 p
->contents
[index
] = args
[index
];
3190 XSETCOMPILED (val
, p
);
3196 /***********************************************************************
3198 ***********************************************************************/
3200 /* Each symbol_block is just under 1020 bytes long, since malloc
3201 really allocates in units of powers of two and uses 4 bytes for its
3204 #define SYMBOL_BLOCK_SIZE \
3205 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3209 /* Place `symbols' first, to preserve alignment. */
3210 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
3211 struct symbol_block
*next
;
3214 /* Current symbol block and index of first unused Lisp_Symbol
3217 struct symbol_block
*symbol_block
;
3218 int symbol_block_index
;
3220 /* List of free symbols. */
3222 struct Lisp_Symbol
*symbol_free_list
;
3224 /* Total number of symbol blocks now in use. */
3226 int n_symbol_blocks
;
3229 /* Initialize symbol allocation. */
3234 symbol_block
= NULL
;
3235 symbol_block_index
= SYMBOL_BLOCK_SIZE
;
3236 symbol_free_list
= 0;
3237 n_symbol_blocks
= 0;
3241 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
3242 doc
: /* Return a newly allocated uninterned symbol whose name is NAME.
3243 Its value and function definition are void, and its property list is nil. */)
3247 register Lisp_Object val
;
3248 register struct Lisp_Symbol
*p
;
3250 CHECK_STRING (name
);
3252 /* eassert (!handling_signal); */
3258 if (symbol_free_list
)
3260 XSETSYMBOL (val
, symbol_free_list
);
3261 symbol_free_list
= symbol_free_list
->next
;
3265 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
3267 struct symbol_block
*new;
3268 new = (struct symbol_block
*) lisp_malloc (sizeof *new,
3270 new->next
= symbol_block
;
3272 symbol_block_index
= 0;
3275 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
]);
3276 symbol_block_index
++;
3286 p
->value
= Qunbound
;
3287 p
->function
= Qunbound
;
3290 p
->interned
= SYMBOL_UNINTERNED
;
3292 p
->indirect_variable
= 0;
3293 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
3300 /***********************************************************************
3301 Marker (Misc) Allocation
3302 ***********************************************************************/
3304 /* Allocation of markers and other objects that share that structure.
3305 Works like allocation of conses. */
3307 #define MARKER_BLOCK_SIZE \
3308 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3312 /* Place `markers' first, to preserve alignment. */
3313 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
3314 struct marker_block
*next
;
3317 struct marker_block
*marker_block
;
3318 int marker_block_index
;
3320 union Lisp_Misc
*marker_free_list
;
3322 /* Total number of marker blocks now in use. */
3324 int n_marker_blocks
;
3329 marker_block
= NULL
;
3330 marker_block_index
= MARKER_BLOCK_SIZE
;
3331 marker_free_list
= 0;
3332 n_marker_blocks
= 0;
3335 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3342 /* eassert (!handling_signal); */
3348 if (marker_free_list
)
3350 XSETMISC (val
, marker_free_list
);
3351 marker_free_list
= marker_free_list
->u_free
.chain
;
3355 if (marker_block_index
== MARKER_BLOCK_SIZE
)
3357 struct marker_block
*new;
3358 new = (struct marker_block
*) lisp_malloc (sizeof *new,
3360 new->next
= marker_block
;
3362 marker_block_index
= 0;
3364 total_free_markers
+= MARKER_BLOCK_SIZE
;
3366 XSETMISC (val
, &marker_block
->markers
[marker_block_index
]);
3367 marker_block_index
++;
3374 --total_free_markers
;
3375 consing_since_gc
+= sizeof (union Lisp_Misc
);
3376 misc_objects_consed
++;
3377 XMARKER (val
)->gcmarkbit
= 0;
3381 /* Free a Lisp_Misc object */
3387 XMISC (misc
)->u_marker
.type
= Lisp_Misc_Free
;
3388 XMISC (misc
)->u_free
.chain
= marker_free_list
;
3389 marker_free_list
= XMISC (misc
);
3391 total_free_markers
++;
3394 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3395 INTEGER. This is used to package C values to call record_unwind_protect.
3396 The unwind function can get the C values back using XSAVE_VALUE. */
3399 make_save_value (pointer
, integer
)
3403 register Lisp_Object val
;
3404 register struct Lisp_Save_Value
*p
;
3406 val
= allocate_misc ();
3407 XMISCTYPE (val
) = Lisp_Misc_Save_Value
;
3408 p
= XSAVE_VALUE (val
);
3409 p
->pointer
= pointer
;
3410 p
->integer
= integer
;
3415 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
3416 doc
: /* Return a newly allocated marker which does not point at any place. */)
3419 register Lisp_Object val
;
3420 register struct Lisp_Marker
*p
;
3422 val
= allocate_misc ();
3423 XMISCTYPE (val
) = Lisp_Misc_Marker
;
3429 p
->insertion_type
= 0;
3433 /* Put MARKER back on the free list after using it temporarily. */
3436 free_marker (marker
)
3439 unchain_marker (XMARKER (marker
));
3444 /* Return a newly created vector or string with specified arguments as
3445 elements. If all the arguments are characters that can fit
3446 in a string of events, make a string; otherwise, make a vector.
3448 Any number of arguments, even zero arguments, are allowed. */
3451 make_event_array (nargs
, args
)
3457 for (i
= 0; i
< nargs
; i
++)
3458 /* The things that fit in a string
3459 are characters that are in 0...127,
3460 after discarding the meta bit and all the bits above it. */
3461 if (!INTEGERP (args
[i
])
3462 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
3463 return Fvector (nargs
, args
);
3465 /* Since the loop exited, we know that all the things in it are
3466 characters, so we can make a string. */
3470 result
= Fmake_string (make_number (nargs
), make_number (0));
3471 for (i
= 0; i
< nargs
; i
++)
3473 SSET (result
, i
, XINT (args
[i
]));
3474 /* Move the meta bit to the right place for a string char. */
3475 if (XINT (args
[i
]) & CHAR_META
)
3476 SSET (result
, i
, SREF (result
, i
) | 0x80);
3485 /************************************************************************
3486 Memory Full Handling
3487 ************************************************************************/
3490 /* Called if malloc returns zero. */
3499 memory_full_cons_threshold
= sizeof (struct cons_block
);
3501 /* The first time we get here, free the spare memory. */
3502 for (i
= 0; i
< sizeof (spare_memory
) / sizeof (char *); i
++)
3503 if (spare_memory
[i
])
3506 free (spare_memory
[i
]);
3507 else if (i
>= 1 && i
<= 4)
3508 lisp_align_free (spare_memory
[i
]);
3510 lisp_free (spare_memory
[i
]);
3511 spare_memory
[i
] = 0;
3514 /* Record the space now used. When it decreases substantially,
3515 we can refill the memory reserve. */
3516 #ifndef SYSTEM_MALLOC
3517 bytes_used_when_full
= BYTES_USED
;
3520 /* This used to call error, but if we've run out of memory, we could
3521 get infinite recursion trying to build the string. */
3522 xsignal (Qnil
, Vmemory_signal_data
);
3525 /* If we released our reserve (due to running out of memory),
3526 and we have a fair amount free once again,
3527 try to set aside another reserve in case we run out once more.
3529 This is called when a relocatable block is freed in ralloc.c,
3530 and also directly from this file, in case we're not using ralloc.c. */
3533 refill_memory_reserve ()
3535 #ifndef SYSTEM_MALLOC
3536 if (spare_memory
[0] == 0)
3537 spare_memory
[0] = (char *) malloc ((size_t) SPARE_MEMORY
);
3538 if (spare_memory
[1] == 0)
3539 spare_memory
[1] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3541 if (spare_memory
[2] == 0)
3542 spare_memory
[2] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3544 if (spare_memory
[3] == 0)
3545 spare_memory
[3] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3547 if (spare_memory
[4] == 0)
3548 spare_memory
[4] = (char *) lisp_align_malloc (sizeof (struct cons_block
),
3550 if (spare_memory
[5] == 0)
3551 spare_memory
[5] = (char *) lisp_malloc (sizeof (struct string_block
),
3553 if (spare_memory
[6] == 0)
3554 spare_memory
[6] = (char *) lisp_malloc (sizeof (struct string_block
),
3556 if (spare_memory
[0] && spare_memory
[1] && spare_memory
[5])
3557 Vmemory_full
= Qnil
;
3561 /************************************************************************
3563 ************************************************************************/
3565 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3567 /* Conservative C stack marking requires a method to identify possibly
3568 live Lisp objects given a pointer value. We do this by keeping
3569 track of blocks of Lisp data that are allocated in a red-black tree
3570 (see also the comment of mem_node which is the type of nodes in
3571 that tree). Function lisp_malloc adds information for an allocated
3572 block to the red-black tree with calls to mem_insert, and function
3573 lisp_free removes it with mem_delete. Functions live_string_p etc
3574 call mem_find to lookup information about a given pointer in the
3575 tree, and use that to determine if the pointer points to a Lisp
3578 /* Initialize this part of alloc.c. */
3583 mem_z
.left
= mem_z
.right
= MEM_NIL
;
3584 mem_z
.parent
= NULL
;
3585 mem_z
.color
= MEM_BLACK
;
3586 mem_z
.start
= mem_z
.end
= NULL
;
3591 /* Value is a pointer to the mem_node containing START. Value is
3592 MEM_NIL if there is no node in the tree containing START. */
3594 static INLINE
struct mem_node
*
3600 if (start
< min_heap_address
|| start
> max_heap_address
)
3603 /* Make the search always successful to speed up the loop below. */
3604 mem_z
.start
= start
;
3605 mem_z
.end
= (char *) start
+ 1;
3608 while (start
< p
->start
|| start
>= p
->end
)
3609 p
= start
< p
->start
? p
->left
: p
->right
;
3614 /* Insert a new node into the tree for a block of memory with start
3615 address START, end address END, and type TYPE. Value is a
3616 pointer to the node that was inserted. */
3618 static struct mem_node
*
3619 mem_insert (start
, end
, type
)
3623 struct mem_node
*c
, *parent
, *x
;
3625 if (min_heap_address
== NULL
|| start
< min_heap_address
)
3626 min_heap_address
= start
;
3627 if (max_heap_address
== NULL
|| end
> max_heap_address
)
3628 max_heap_address
= end
;
3630 /* See where in the tree a node for START belongs. In this
3631 particular application, it shouldn't happen that a node is already
3632 present. For debugging purposes, let's check that. */
3636 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3638 while (c
!= MEM_NIL
)
3640 if (start
>= c
->start
&& start
< c
->end
)
3643 c
= start
< c
->start
? c
->left
: c
->right
;
3646 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3648 while (c
!= MEM_NIL
)
3651 c
= start
< c
->start
? c
->left
: c
->right
;
3654 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3656 /* Create a new node. */
3657 #ifdef GC_MALLOC_CHECK
3658 x
= (struct mem_node
*) _malloc_internal (sizeof *x
);
3662 x
= (struct mem_node
*) xmalloc (sizeof *x
);
3668 x
->left
= x
->right
= MEM_NIL
;
3671 /* Insert it as child of PARENT or install it as root. */
3674 if (start
< parent
->start
)
3682 /* Re-establish red-black tree properties. */
3683 mem_insert_fixup (x
);
3689 /* Re-establish the red-black properties of the tree, and thereby
3690 balance the tree, after node X has been inserted; X is always red. */
3693 mem_insert_fixup (x
)
3696 while (x
!= mem_root
&& x
->parent
->color
== MEM_RED
)
3698 /* X is red and its parent is red. This is a violation of
3699 red-black tree property #3. */
3701 if (x
->parent
== x
->parent
->parent
->left
)
3703 /* We're on the left side of our grandparent, and Y is our
3705 struct mem_node
*y
= x
->parent
->parent
->right
;
3707 if (y
->color
== MEM_RED
)
3709 /* Uncle and parent are red but should be black because
3710 X is red. Change the colors accordingly and proceed
3711 with the grandparent. */
3712 x
->parent
->color
= MEM_BLACK
;
3713 y
->color
= MEM_BLACK
;
3714 x
->parent
->parent
->color
= MEM_RED
;
3715 x
= x
->parent
->parent
;
3719 /* Parent and uncle have different colors; parent is
3720 red, uncle is black. */
3721 if (x
== x
->parent
->right
)
3724 mem_rotate_left (x
);
3727 x
->parent
->color
= MEM_BLACK
;
3728 x
->parent
->parent
->color
= MEM_RED
;
3729 mem_rotate_right (x
->parent
->parent
);
3734 /* This is the symmetrical case of above. */
3735 struct mem_node
*y
= x
->parent
->parent
->left
;
3737 if (y
->color
== MEM_RED
)
3739 x
->parent
->color
= MEM_BLACK
;
3740 y
->color
= MEM_BLACK
;
3741 x
->parent
->parent
->color
= MEM_RED
;
3742 x
= x
->parent
->parent
;
3746 if (x
== x
->parent
->left
)
3749 mem_rotate_right (x
);
3752 x
->parent
->color
= MEM_BLACK
;
3753 x
->parent
->parent
->color
= MEM_RED
;
3754 mem_rotate_left (x
->parent
->parent
);
3759 /* The root may have been changed to red due to the algorithm. Set
3760 it to black so that property #5 is satisfied. */
3761 mem_root
->color
= MEM_BLACK
;
3777 /* Turn y's left sub-tree into x's right sub-tree. */
3780 if (y
->left
!= MEM_NIL
)
3781 y
->left
->parent
= x
;
3783 /* Y's parent was x's parent. */
3785 y
->parent
= x
->parent
;
3787 /* Get the parent to point to y instead of x. */
3790 if (x
== x
->parent
->left
)
3791 x
->parent
->left
= y
;
3793 x
->parent
->right
= y
;
3798 /* Put x on y's left. */
3812 mem_rotate_right (x
)
3815 struct mem_node
*y
= x
->left
;
3818 if (y
->right
!= MEM_NIL
)
3819 y
->right
->parent
= x
;
3822 y
->parent
= x
->parent
;
3825 if (x
== x
->parent
->right
)
3826 x
->parent
->right
= y
;
3828 x
->parent
->left
= y
;
3839 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3845 struct mem_node
*x
, *y
;
3847 if (!z
|| z
== MEM_NIL
)
3850 if (z
->left
== MEM_NIL
|| z
->right
== MEM_NIL
)
3855 while (y
->left
!= MEM_NIL
)
3859 if (y
->left
!= MEM_NIL
)
3864 x
->parent
= y
->parent
;
3867 if (y
== y
->parent
->left
)
3868 y
->parent
->left
= x
;
3870 y
->parent
->right
= x
;
3877 z
->start
= y
->start
;
3882 if (y
->color
== MEM_BLACK
)
3883 mem_delete_fixup (x
);
3885 #ifdef GC_MALLOC_CHECK
3893 /* Re-establish the red-black properties of the tree, after a
3897 mem_delete_fixup (x
)
3900 while (x
!= mem_root
&& x
->color
== MEM_BLACK
)
3902 if (x
== x
->parent
->left
)
3904 struct mem_node
*w
= x
->parent
->right
;
3906 if (w
->color
== MEM_RED
)
3908 w
->color
= MEM_BLACK
;
3909 x
->parent
->color
= MEM_RED
;
3910 mem_rotate_left (x
->parent
);
3911 w
= x
->parent
->right
;
3914 if (w
->left
->color
== MEM_BLACK
&& w
->right
->color
== MEM_BLACK
)
3921 if (w
->right
->color
== MEM_BLACK
)
3923 w
->left
->color
= MEM_BLACK
;
3925 mem_rotate_right (w
);
3926 w
= x
->parent
->right
;
3928 w
->color
= x
->parent
->color
;
3929 x
->parent
->color
= MEM_BLACK
;
3930 w
->right
->color
= MEM_BLACK
;
3931 mem_rotate_left (x
->parent
);
3937 struct mem_node
*w
= x
->parent
->left
;
3939 if (w
->color
== MEM_RED
)
3941 w
->color
= MEM_BLACK
;
3942 x
->parent
->color
= MEM_RED
;
3943 mem_rotate_right (x
->parent
);
3944 w
= x
->parent
->left
;
3947 if (w
->right
->color
== MEM_BLACK
&& w
->left
->color
== MEM_BLACK
)
3954 if (w
->left
->color
== MEM_BLACK
)
3956 w
->right
->color
= MEM_BLACK
;
3958 mem_rotate_left (w
);
3959 w
= x
->parent
->left
;
3962 w
->color
= x
->parent
->color
;
3963 x
->parent
->color
= MEM_BLACK
;
3964 w
->left
->color
= MEM_BLACK
;
3965 mem_rotate_right (x
->parent
);
3971 x
->color
= MEM_BLACK
;
3975 /* Value is non-zero if P is a pointer to a live Lisp string on
3976 the heap. M is a pointer to the mem_block for P. */
3979 live_string_p (m
, p
)
3983 if (m
->type
== MEM_TYPE_STRING
)
3985 struct string_block
*b
= (struct string_block
*) m
->start
;
3986 int offset
= (char *) p
- (char *) &b
->strings
[0];
3988 /* P must point to the start of a Lisp_String structure, and it
3989 must not be on the free-list. */
3991 && offset
% sizeof b
->strings
[0] == 0
3992 && offset
< (STRING_BLOCK_SIZE
* sizeof b
->strings
[0])
3993 && ((struct Lisp_String
*) p
)->data
!= NULL
);
4000 /* Value is non-zero if P is a pointer to a live Lisp cons on
4001 the heap. M is a pointer to the mem_block for P. */
4008 if (m
->type
== MEM_TYPE_CONS
)
4010 struct cons_block
*b
= (struct cons_block
*) m
->start
;
4011 int offset
= (char *) p
- (char *) &b
->conses
[0];
4013 /* P must point to the start of a Lisp_Cons, not be
4014 one of the unused cells in the current cons block,
4015 and not be on the free-list. */
4017 && offset
% sizeof b
->conses
[0] == 0
4018 && offset
< (CONS_BLOCK_SIZE
* sizeof b
->conses
[0])
4020 || offset
/ sizeof b
->conses
[0] < cons_block_index
)
4021 && !EQ (((struct Lisp_Cons
*) p
)->car
, Vdead
));
4028 /* Value is non-zero if P is a pointer to a live Lisp symbol on
4029 the heap. M is a pointer to the mem_block for P. */
4032 live_symbol_p (m
, p
)
4036 if (m
->type
== MEM_TYPE_SYMBOL
)
4038 struct symbol_block
*b
= (struct symbol_block
*) m
->start
;
4039 int offset
= (char *) p
- (char *) &b
->symbols
[0];
4041 /* P must point to the start of a Lisp_Symbol, not be
4042 one of the unused cells in the current symbol block,
4043 and not be on the free-list. */
4045 && offset
% sizeof b
->symbols
[0] == 0
4046 && offset
< (SYMBOL_BLOCK_SIZE
* sizeof b
->symbols
[0])
4047 && (b
!= symbol_block
4048 || offset
/ sizeof b
->symbols
[0] < symbol_block_index
)
4049 && !EQ (((struct Lisp_Symbol
*) p
)->function
, Vdead
));
4056 /* Value is non-zero if P is a pointer to a live Lisp float on
4057 the heap. M is a pointer to the mem_block for P. */
4064 if (m
->type
== MEM_TYPE_FLOAT
)
4066 struct float_block
*b
= (struct float_block
*) m
->start
;
4067 int offset
= (char *) p
- (char *) &b
->floats
[0];
4069 /* P must point to the start of a Lisp_Float and not be
4070 one of the unused cells in the current float block. */
4072 && offset
% sizeof b
->floats
[0] == 0
4073 && offset
< (FLOAT_BLOCK_SIZE
* sizeof b
->floats
[0])
4074 && (b
!= float_block
4075 || offset
/ sizeof b
->floats
[0] < float_block_index
));
4082 /* Value is non-zero if P is a pointer to a live Lisp Misc on
4083 the heap. M is a pointer to the mem_block for P. */
4090 if (m
->type
== MEM_TYPE_MISC
)
4092 struct marker_block
*b
= (struct marker_block
*) m
->start
;
4093 int offset
= (char *) p
- (char *) &b
->markers
[0];
4095 /* P must point to the start of a Lisp_Misc, not be
4096 one of the unused cells in the current misc block,
4097 and not be on the free-list. */
4099 && offset
% sizeof b
->markers
[0] == 0
4100 && offset
< (MARKER_BLOCK_SIZE
* sizeof b
->markers
[0])
4101 && (b
!= marker_block
4102 || offset
/ sizeof b
->markers
[0] < marker_block_index
)
4103 && ((union Lisp_Misc
*) p
)->u_marker
.type
!= Lisp_Misc_Free
);
4110 /* Value is non-zero if P is a pointer to a live vector-like object.
4111 M is a pointer to the mem_block for P. */
4114 live_vector_p (m
, p
)
4118 return (p
== m
->start
4119 && m
->type
>= MEM_TYPE_VECTOR
4120 && m
->type
<= MEM_TYPE_WINDOW
);
4124 /* Value is non-zero if P is a pointer to a live buffer. M is a
4125 pointer to the mem_block for P. */
4128 live_buffer_p (m
, p
)
4132 /* P must point to the start of the block, and the buffer
4133 must not have been killed. */
4134 return (m
->type
== MEM_TYPE_BUFFER
4136 && !NILP (((struct buffer
*) p
)->name
));
4139 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4143 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4145 /* Array of objects that are kept alive because the C stack contains
4146 a pattern that looks like a reference to them . */
4148 #define MAX_ZOMBIES 10
4149 static Lisp_Object zombies
[MAX_ZOMBIES
];
4151 /* Number of zombie objects. */
4153 static int nzombies
;
4155 /* Number of garbage collections. */
4159 /* Average percentage of zombies per collection. */
4161 static double avg_zombies
;
4163 /* Max. number of live and zombie objects. */
4165 static int max_live
, max_zombies
;
4167 /* Average number of live objects per GC. */
4169 static double avg_live
;
4171 DEFUN ("gc-status", Fgc_status
, Sgc_status
, 0, 0, "",
4172 doc
: /* Show information about live and zombie objects. */)
4175 Lisp_Object args
[8], zombie_list
= Qnil
;
4177 for (i
= 0; i
< nzombies
; i
++)
4178 zombie_list
= Fcons (zombies
[i
], zombie_list
);
4179 args
[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4180 args
[1] = make_number (ngcs
);
4181 args
[2] = make_float (avg_live
);
4182 args
[3] = make_float (avg_zombies
);
4183 args
[4] = make_float (avg_zombies
/ avg_live
/ 100);
4184 args
[5] = make_number (max_live
);
4185 args
[6] = make_number (max_zombies
);
4186 args
[7] = zombie_list
;
4187 return Fmessage (8, args
);
4190 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4193 /* Mark OBJ if we can prove it's a Lisp_Object. */
4196 mark_maybe_object (obj
)
4199 void *po
= (void *) XPNTR (obj
);
4200 struct mem_node
*m
= mem_find (po
);
4206 switch (XGCTYPE (obj
))
4209 mark_p
= (live_string_p (m
, po
)
4210 && !STRING_MARKED_P ((struct Lisp_String
*) po
));
4214 mark_p
= (live_cons_p (m
, po
) && !CONS_MARKED_P (XCONS (obj
)));
4218 mark_p
= (live_symbol_p (m
, po
) && !XSYMBOL (obj
)->gcmarkbit
);
4222 mark_p
= (live_float_p (m
, po
) && !FLOAT_MARKED_P (XFLOAT (obj
)));
4225 case Lisp_Vectorlike
:
4226 /* Note: can't check GC_BUFFERP before we know it's a
4227 buffer because checking that dereferences the pointer
4228 PO which might point anywhere. */
4229 if (live_vector_p (m
, po
))
4230 mark_p
= !GC_SUBRP (obj
) && !VECTOR_MARKED_P (XVECTOR (obj
));
4231 else if (live_buffer_p (m
, po
))
4232 mark_p
= GC_BUFFERP (obj
) && !VECTOR_MARKED_P (XBUFFER (obj
));
4236 mark_p
= (live_misc_p (m
, po
) && !XMARKER (obj
)->gcmarkbit
);
4240 case Lisp_Type_Limit
:
4246 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4247 if (nzombies
< MAX_ZOMBIES
)
4248 zombies
[nzombies
] = obj
;
4257 /* If P points to Lisp data, mark that as live if it isn't already
4261 mark_maybe_pointer (p
)
4266 /* Quickly rule out some values which can't point to Lisp data. We
4267 assume that Lisp data is aligned on even addresses. */
4268 if ((EMACS_INT
) p
& 1)
4274 Lisp_Object obj
= Qnil
;
4278 case MEM_TYPE_NON_LISP
:
4279 /* Nothing to do; not a pointer to Lisp memory. */
4282 case MEM_TYPE_BUFFER
:
4283 if (live_buffer_p (m
, p
) && !VECTOR_MARKED_P((struct buffer
*)p
))
4284 XSETVECTOR (obj
, p
);
4288 if (live_cons_p (m
, p
) && !CONS_MARKED_P ((struct Lisp_Cons
*) p
))
4292 case MEM_TYPE_STRING
:
4293 if (live_string_p (m
, p
)
4294 && !STRING_MARKED_P ((struct Lisp_String
*) p
))
4295 XSETSTRING (obj
, p
);
4299 if (live_misc_p (m
, p
) && !((struct Lisp_Free
*) p
)->gcmarkbit
)
4303 case MEM_TYPE_SYMBOL
:
4304 if (live_symbol_p (m
, p
) && !((struct Lisp_Symbol
*) p
)->gcmarkbit
)
4305 XSETSYMBOL (obj
, p
);
4308 case MEM_TYPE_FLOAT
:
4309 if (live_float_p (m
, p
) && !FLOAT_MARKED_P (p
))
4313 case MEM_TYPE_VECTOR
:
4314 case MEM_TYPE_PROCESS
:
4315 case MEM_TYPE_HASH_TABLE
:
4316 case MEM_TYPE_FRAME
:
4317 case MEM_TYPE_WINDOW
:
4318 if (live_vector_p (m
, p
))
4321 XSETVECTOR (tem
, p
);
4322 if (!GC_SUBRP (tem
) && !VECTOR_MARKED_P (XVECTOR (tem
)))
4337 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4338 or END+OFFSET..START. */
4341 mark_memory (start
, end
, offset
)
4348 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4352 /* Make START the pointer to the start of the memory region,
4353 if it isn't already. */
4361 /* Mark Lisp_Objects. */
4362 for (p
= (Lisp_Object
*) ((char *) start
+ offset
); (void *) p
< end
; ++p
)
4363 mark_maybe_object (*p
);
4365 /* Mark Lisp data pointed to. This is necessary because, in some
4366 situations, the C compiler optimizes Lisp objects away, so that
4367 only a pointer to them remains. Example:
4369 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4372 Lisp_Object obj = build_string ("test");
4373 struct Lisp_String *s = XSTRING (obj);
4374 Fgarbage_collect ();
4375 fprintf (stderr, "test `%s'\n", s->data);
4379 Here, `obj' isn't really used, and the compiler optimizes it
4380 away. The only reference to the life string is through the
4383 for (pp
= (void **) ((char *) start
+ offset
); (void *) pp
< end
; ++pp
)
4384 mark_maybe_pointer (*pp
);
4387 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4388 the GCC system configuration. In gcc 3.2, the only systems for
4389 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4390 by others?) and ns32k-pc532-min. */
4392 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4394 static int setjmp_tested_p
, longjmps_done
;
4396 #define SETJMP_WILL_LIKELY_WORK "\
4398 Emacs garbage collector has been changed to use conservative stack\n\
4399 marking. Emacs has determined that the method it uses to do the\n\
4400 marking will likely work on your system, but this isn't sure.\n\
4402 If you are a system-programmer, or can get the help of a local wizard\n\
4403 who is, please take a look at the function mark_stack in alloc.c, and\n\
4404 verify that the methods used are appropriate for your system.\n\
4406 Please mail the result to <emacs-devel@gnu.org>.\n\
4409 #define SETJMP_WILL_NOT_WORK "\
4411 Emacs garbage collector has been changed to use conservative stack\n\
4412 marking. Emacs has determined that the default method it uses to do the\n\
4413 marking will not work on your system. We will need a system-dependent\n\
4414 solution for your system.\n\
4416 Please take a look at the function mark_stack in alloc.c, and\n\
4417 try to find a way to make it work on your system.\n\
4419 Note that you may get false negatives, depending on the compiler.\n\
4420 In particular, you need to use -O with GCC for this test.\n\
4422 Please mail the result to <emacs-devel@gnu.org>.\n\
4426 /* Perform a quick check if it looks like setjmp saves registers in a
4427 jmp_buf. Print a message to stderr saying so. When this test
4428 succeeds, this is _not_ a proof that setjmp is sufficient for
4429 conservative stack marking. Only the sources or a disassembly
4440 /* Arrange for X to be put in a register. */
4446 if (longjmps_done
== 1)
4448 /* Came here after the longjmp at the end of the function.
4450 If x == 1, the longjmp has restored the register to its
4451 value before the setjmp, and we can hope that setjmp
4452 saves all such registers in the jmp_buf, although that
4455 For other values of X, either something really strange is
4456 taking place, or the setjmp just didn't save the register. */
4459 fprintf (stderr
, SETJMP_WILL_LIKELY_WORK
);
4462 fprintf (stderr
, SETJMP_WILL_NOT_WORK
);
4469 if (longjmps_done
== 1)
4473 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4476 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4478 /* Abort if anything GCPRO'd doesn't survive the GC. */
4486 for (p
= gcprolist
; p
; p
= p
->next
)
4487 for (i
= 0; i
< p
->nvars
; ++i
)
4488 if (!survives_gc_p (p
->var
[i
]))
4489 /* FIXME: It's not necessarily a bug. It might just be that the
4490 GCPRO is unnecessary or should release the object sooner. */
4494 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4501 fprintf (stderr
, "\nZombies kept alive = %d:\n", nzombies
);
4502 for (i
= 0; i
< min (MAX_ZOMBIES
, nzombies
); ++i
)
4504 fprintf (stderr
, " %d = ", i
);
4505 debug_print (zombies
[i
]);
4509 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4512 /* Mark live Lisp objects on the C stack.
4514 There are several system-dependent problems to consider when
4515 porting this to new architectures:
4519 We have to mark Lisp objects in CPU registers that can hold local
4520 variables or are used to pass parameters.
4522 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4523 something that either saves relevant registers on the stack, or
4524 calls mark_maybe_object passing it each register's contents.
4526 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4527 implementation assumes that calling setjmp saves registers we need
4528 to see in a jmp_buf which itself lies on the stack. This doesn't
4529 have to be true! It must be verified for each system, possibly
4530 by taking a look at the source code of setjmp.
4534 Architectures differ in the way their processor stack is organized.
4535 For example, the stack might look like this
4538 | Lisp_Object | size = 4
4540 | something else | size = 2
4542 | Lisp_Object | size = 4
4546 In such a case, not every Lisp_Object will be aligned equally. To
4547 find all Lisp_Object on the stack it won't be sufficient to walk
4548 the stack in steps of 4 bytes. Instead, two passes will be
4549 necessary, one starting at the start of the stack, and a second
4550 pass starting at the start of the stack + 2. Likewise, if the
4551 minimal alignment of Lisp_Objects on the stack is 1, four passes
4552 would be necessary, each one starting with one byte more offset
4553 from the stack start.
4555 The current code assumes by default that Lisp_Objects are aligned
4556 equally on the stack. */
4562 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4563 union aligned_jmpbuf
{
4567 volatile int stack_grows_down_p
= (char *) &j
> (char *) stack_base
;
4570 /* This trick flushes the register windows so that all the state of
4571 the process is contained in the stack. */
4572 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4573 needed on ia64 too. See mach_dep.c, where it also says inline
4574 assembler doesn't work with relevant proprietary compilers. */
4579 /* Save registers that we need to see on the stack. We need to see
4580 registers used to hold register variables and registers used to
4582 #ifdef GC_SAVE_REGISTERS_ON_STACK
4583 GC_SAVE_REGISTERS_ON_STACK (end
);
4584 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4586 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4587 setjmp will definitely work, test it
4588 and print a message with the result
4590 if (!setjmp_tested_p
)
4592 setjmp_tested_p
= 1;
4595 #endif /* GC_SETJMP_WORKS */
4598 end
= stack_grows_down_p
? (char *) &j
+ sizeof j
: (char *) &j
;
4599 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4601 /* This assumes that the stack is a contiguous region in memory. If
4602 that's not the case, something has to be done here to iterate
4603 over the stack segments. */
4604 #ifndef GC_LISP_OBJECT_ALIGNMENT
4606 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4608 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4611 for (i
= 0; i
< sizeof (Lisp_Object
); i
+= GC_LISP_OBJECT_ALIGNMENT
)
4612 mark_memory (stack_base
, end
, i
);
4613 /* Allow for marking a secondary stack, like the register stack on the
4615 #ifdef GC_MARK_SECONDARY_STACK
4616 GC_MARK_SECONDARY_STACK ();
4619 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4624 #endif /* GC_MARK_STACK != 0 */
4627 /* Determine whether it is safe to access memory at address P. */
4633 return w32_valid_pointer_p (p
, 16);
4637 /* Obviously, we cannot just access it (we would SEGV trying), so we
4638 trick the o/s to tell us whether p is a valid pointer.
4639 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4640 not validate p in that case. */
4642 if ((fd
= emacs_open ("__Valid__Lisp__Object__", O_CREAT
| O_WRONLY
| O_TRUNC
, 0666)) >= 0)
4644 int valid
= (emacs_write (fd
, (char *)p
, 16) == 16);
4646 unlink ("__Valid__Lisp__Object__");
4654 /* Return 1 if OBJ is a valid lisp object.
4655 Return 0 if OBJ is NOT a valid lisp object.
4656 Return -1 if we cannot validate OBJ.
4657 This function can be quite slow,
4658 so it should only be used in code for manual debugging. */
4661 valid_lisp_object_p (obj
)
4672 p
= (void *) XPNTR (obj
);
4673 if (PURE_POINTER_P (p
))
4677 return valid_pointer_p (p
);
4684 int valid
= valid_pointer_p (p
);
4696 case MEM_TYPE_NON_LISP
:
4699 case MEM_TYPE_BUFFER
:
4700 return live_buffer_p (m
, p
);
4703 return live_cons_p (m
, p
);
4705 case MEM_TYPE_STRING
:
4706 return live_string_p (m
, p
);
4709 return live_misc_p (m
, p
);
4711 case MEM_TYPE_SYMBOL
:
4712 return live_symbol_p (m
, p
);
4714 case MEM_TYPE_FLOAT
:
4715 return live_float_p (m
, p
);
4717 case MEM_TYPE_VECTOR
:
4718 case MEM_TYPE_PROCESS
:
4719 case MEM_TYPE_HASH_TABLE
:
4720 case MEM_TYPE_FRAME
:
4721 case MEM_TYPE_WINDOW
:
4722 return live_vector_p (m
, p
);
4735 /***********************************************************************
4736 Pure Storage Management
4737 ***********************************************************************/
4739 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4740 pointer to it. TYPE is the Lisp type for which the memory is
4741 allocated. TYPE < 0 means it's not used for a Lisp object. */
4743 static POINTER_TYPE
*
4744 pure_alloc (size
, type
)
4748 POINTER_TYPE
*result
;
4750 size_t alignment
= (1 << GCTYPEBITS
);
4752 size_t alignment
= sizeof (EMACS_INT
);
4754 /* Give Lisp_Floats an extra alignment. */
4755 if (type
== Lisp_Float
)
4757 #if defined __GNUC__ && __GNUC__ >= 2
4758 alignment
= __alignof (struct Lisp_Float
);
4760 alignment
= sizeof (struct Lisp_Float
);
4768 /* Allocate space for a Lisp object from the beginning of the free
4769 space with taking account of alignment. */
4770 result
= ALIGN (purebeg
+ pure_bytes_used_lisp
, alignment
);
4771 pure_bytes_used_lisp
= ((char *)result
- (char *)purebeg
) + size
;
4775 /* Allocate space for a non-Lisp object from the end of the free
4777 pure_bytes_used_non_lisp
+= size
;
4778 result
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4780 pure_bytes_used
= pure_bytes_used_lisp
+ pure_bytes_used_non_lisp
;
4782 if (pure_bytes_used
<= pure_size
)
4785 /* Don't allocate a large amount here,
4786 because it might get mmap'd and then its address
4787 might not be usable. */
4788 purebeg
= (char *) xmalloc (10000);
4790 pure_bytes_used_before_overflow
+= pure_bytes_used
- size
;
4791 pure_bytes_used
= 0;
4792 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
4797 /* Print a warning if PURESIZE is too small. */
4802 if (pure_bytes_used_before_overflow
)
4803 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4804 (int) (pure_bytes_used
+ pure_bytes_used_before_overflow
));
4808 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4809 the non-Lisp data pool of the pure storage, and return its start
4810 address. Return NULL if not found. */
4813 find_string_data_in_pure (data
, nbytes
)
4817 int i
, skip
, bm_skip
[256], last_char_skip
, infinity
, start
, start_max
;
4821 if (pure_bytes_used_non_lisp
< nbytes
+ 1)
4824 /* Set up the Boyer-Moore table. */
4826 for (i
= 0; i
< 256; i
++)
4829 p
= (unsigned char *) data
;
4831 bm_skip
[*p
++] = skip
;
4833 last_char_skip
= bm_skip
['\0'];
4835 non_lisp_beg
= purebeg
+ pure_size
- pure_bytes_used_non_lisp
;
4836 start_max
= pure_bytes_used_non_lisp
- (nbytes
+ 1);
4838 /* See the comments in the function `boyer_moore' (search.c) for the
4839 use of `infinity'. */
4840 infinity
= pure_bytes_used_non_lisp
+ 1;
4841 bm_skip
['\0'] = infinity
;
4843 p
= (unsigned char *) non_lisp_beg
+ nbytes
;
4847 /* Check the last character (== '\0'). */
4850 start
+= bm_skip
[*(p
+ start
)];
4852 while (start
<= start_max
);
4854 if (start
< infinity
)
4855 /* Couldn't find the last character. */
4858 /* No less than `infinity' means we could find the last
4859 character at `p[start - infinity]'. */
4862 /* Check the remaining characters. */
4863 if (memcmp (data
, non_lisp_beg
+ start
, nbytes
) == 0)
4865 return non_lisp_beg
+ start
;
4867 start
+= last_char_skip
;
4869 while (start
<= start_max
);
4875 /* Return a string allocated in pure space. DATA is a buffer holding
4876 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4877 non-zero means make the result string multibyte.
4879 Must get an error if pure storage is full, since if it cannot hold
4880 a large string it may be able to hold conses that point to that
4881 string; then the string is not protected from gc. */
4884 make_pure_string (data
, nchars
, nbytes
, multibyte
)
4890 struct Lisp_String
*s
;
4892 s
= (struct Lisp_String
*) pure_alloc (sizeof *s
, Lisp_String
);
4893 s
->data
= find_string_data_in_pure (data
, nbytes
);
4894 if (s
->data
== NULL
)
4896 s
->data
= (unsigned char *) pure_alloc (nbytes
+ 1, -1);
4897 bcopy (data
, s
->data
, nbytes
);
4898 s
->data
[nbytes
] = '\0';
4901 s
->size_byte
= multibyte
? nbytes
: -1;
4902 s
->intervals
= NULL_INTERVAL
;
4903 XSETSTRING (string
, s
);
4908 /* Return a cons allocated from pure space. Give it pure copies
4909 of CAR as car and CDR as cdr. */
4912 pure_cons (car
, cdr
)
4913 Lisp_Object car
, cdr
;
4915 register Lisp_Object
new;
4916 struct Lisp_Cons
*p
;
4918 p
= (struct Lisp_Cons
*) pure_alloc (sizeof *p
, Lisp_Cons
);
4920 XSETCAR (new, Fpurecopy (car
));
4921 XSETCDR (new, Fpurecopy (cdr
));
4926 /* Value is a float object with value NUM allocated from pure space. */
4929 make_pure_float (num
)
4932 register Lisp_Object
new;
4933 struct Lisp_Float
*p
;
4935 p
= (struct Lisp_Float
*) pure_alloc (sizeof *p
, Lisp_Float
);
4937 XFLOAT_DATA (new) = num
;
4942 /* Return a vector with room for LEN Lisp_Objects allocated from
4946 make_pure_vector (len
)
4950 struct Lisp_Vector
*p
;
4951 size_t size
= sizeof *p
+ (len
- 1) * sizeof (Lisp_Object
);
4953 p
= (struct Lisp_Vector
*) pure_alloc (size
, Lisp_Vectorlike
);
4954 XSETVECTOR (new, p
);
4955 XVECTOR (new)->size
= len
;
4960 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
4961 doc
: /* Make a copy of object OBJ in pure storage.
4962 Recursively copies contents of vectors and cons cells.
4963 Does not copy symbols. Copies strings without text properties. */)
4965 register Lisp_Object obj
;
4967 if (NILP (Vpurify_flag
))
4970 if (PURE_POINTER_P (XPNTR (obj
)))
4974 return pure_cons (XCAR (obj
), XCDR (obj
));
4975 else if (FLOATP (obj
))
4976 return make_pure_float (XFLOAT_DATA (obj
));
4977 else if (STRINGP (obj
))
4978 return make_pure_string (SDATA (obj
), SCHARS (obj
),
4980 STRING_MULTIBYTE (obj
));
4981 else if (COMPILEDP (obj
) || VECTORP (obj
))
4983 register struct Lisp_Vector
*vec
;
4987 size
= XVECTOR (obj
)->size
;
4988 if (size
& PSEUDOVECTOR_FLAG
)
4989 size
&= PSEUDOVECTOR_SIZE_MASK
;
4990 vec
= XVECTOR (make_pure_vector (size
));
4991 for (i
= 0; i
< size
; i
++)
4992 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
4993 if (COMPILEDP (obj
))
4994 XSETCOMPILED (obj
, vec
);
4996 XSETVECTOR (obj
, vec
);
4999 else if (MARKERP (obj
))
5000 error ("Attempt to copy a marker to pure storage");
5007 /***********************************************************************
5009 ***********************************************************************/
5011 /* Put an entry in staticvec, pointing at the variable with address
5015 staticpro (varaddress
)
5016 Lisp_Object
*varaddress
;
5018 staticvec
[staticidx
++] = varaddress
;
5019 if (staticidx
>= NSTATICS
)
5027 struct catchtag
*next
;
5031 /***********************************************************************
5033 ***********************************************************************/
5035 /* Temporarily prevent garbage collection. */
5038 inhibit_garbage_collection ()
5040 int count
= SPECPDL_INDEX ();
5041 int nbits
= min (VALBITS
, BITS_PER_INT
);
5043 specbind (Qgc_cons_threshold
, make_number (((EMACS_INT
) 1 << (nbits
- 1)) - 1));
5048 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
5049 doc
: /* Reclaim storage for Lisp objects no longer needed.
5050 Garbage collection happens automatically if you cons more than
5051 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
5052 `garbage-collect' normally returns a list with info on amount of space in use:
5053 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
5054 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
5055 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
5056 (USED-STRINGS . FREE-STRINGS))
5057 However, if there was overflow in pure space, `garbage-collect'
5058 returns nil, because real GC can't be done. */)
5061 register struct specbinding
*bind
;
5062 struct catchtag
*catch;
5063 struct handler
*handler
;
5064 char stack_top_variable
;
5067 Lisp_Object total
[8];
5068 int count
= SPECPDL_INDEX ();
5069 EMACS_TIME t1
, t2
, t3
;
5074 /* Can't GC if pure storage overflowed because we can't determine
5075 if something is a pure object or not. */
5076 if (pure_bytes_used_before_overflow
)
5081 /* Don't keep undo information around forever.
5082 Do this early on, so it is no problem if the user quits. */
5084 register struct buffer
*nextb
= all_buffers
;
5088 /* If a buffer's undo list is Qt, that means that undo is
5089 turned off in that buffer. Calling truncate_undo_list on
5090 Qt tends to return NULL, which effectively turns undo back on.
5091 So don't call truncate_undo_list if undo_list is Qt. */
5092 if (! NILP (nextb
->name
) && ! EQ (nextb
->undo_list
, Qt
))
5093 truncate_undo_list (nextb
);
5095 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5096 if (nextb
->base_buffer
== 0 && !NILP (nextb
->name
))
5098 /* If a buffer's gap size is more than 10% of the buffer
5099 size, or larger than 2000 bytes, then shrink it
5100 accordingly. Keep a minimum size of 20 bytes. */
5101 int size
= min (2000, max (20, (nextb
->text
->z_byte
/ 10)));
5103 if (nextb
->text
->gap_size
> size
)
5105 struct buffer
*save_current
= current_buffer
;
5106 current_buffer
= nextb
;
5107 make_gap (-(nextb
->text
->gap_size
- size
));
5108 current_buffer
= save_current
;
5112 nextb
= nextb
->next
;
5116 EMACS_GET_TIME (t1
);
5118 /* In case user calls debug_print during GC,
5119 don't let that cause a recursive GC. */
5120 consing_since_gc
= 0;
5122 /* Save what's currently displayed in the echo area. */
5123 message_p
= push_message ();
5124 record_unwind_protect (pop_message_unwind
, Qnil
);
5126 /* Save a copy of the contents of the stack, for debugging. */
5127 #if MAX_SAVE_STACK > 0
5128 if (NILP (Vpurify_flag
))
5130 i
= &stack_top_variable
- stack_bottom
;
5132 if (i
< MAX_SAVE_STACK
)
5134 if (stack_copy
== 0)
5135 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
5136 else if (stack_copy_size
< i
)
5137 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
5140 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
5141 bcopy (stack_bottom
, stack_copy
, i
);
5143 bcopy (&stack_top_variable
, stack_copy
, i
);
5147 #endif /* MAX_SAVE_STACK > 0 */
5149 if (garbage_collection_messages
)
5150 message1_nolog ("Garbage collecting...");
5154 shrink_regexp_cache ();
5158 /* clear_marks (); */
5160 /* Mark all the special slots that serve as the roots of accessibility. */
5162 for (i
= 0; i
< staticidx
; i
++)
5163 mark_object (*staticvec
[i
]);
5165 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
5167 mark_object (bind
->symbol
);
5168 mark_object (bind
->old_value
);
5174 extern void xg_mark_data ();
5179 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5180 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5184 register struct gcpro
*tail
;
5185 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
5186 for (i
= 0; i
< tail
->nvars
; i
++)
5187 mark_object (tail
->var
[i
]);
5192 for (catch = catchlist
; catch; catch = catch->next
)
5194 mark_object (catch->tag
);
5195 mark_object (catch->val
);
5197 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
5199 mark_object (handler
->handler
);
5200 mark_object (handler
->var
);
5204 #ifdef HAVE_WINDOW_SYSTEM
5205 mark_fringe_data ();
5208 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5212 /* Everything is now marked, except for the things that require special
5213 finalization, i.e. the undo_list.
5214 Look thru every buffer's undo list
5215 for elements that update markers that were not marked,
5218 register struct buffer
*nextb
= all_buffers
;
5222 /* If a buffer's undo list is Qt, that means that undo is
5223 turned off in that buffer. Calling truncate_undo_list on
5224 Qt tends to return NULL, which effectively turns undo back on.
5225 So don't call truncate_undo_list if undo_list is Qt. */
5226 if (! EQ (nextb
->undo_list
, Qt
))
5228 Lisp_Object tail
, prev
;
5229 tail
= nextb
->undo_list
;
5231 while (CONSP (tail
))
5233 if (GC_CONSP (XCAR (tail
))
5234 && GC_MARKERP (XCAR (XCAR (tail
)))
5235 && !XMARKER (XCAR (XCAR (tail
)))->gcmarkbit
)
5238 nextb
->undo_list
= tail
= XCDR (tail
);
5242 XSETCDR (prev
, tail
);
5252 /* Now that we have stripped the elements that need not be in the
5253 undo_list any more, we can finally mark the list. */
5254 mark_object (nextb
->undo_list
);
5256 nextb
= nextb
->next
;
5262 /* Clear the mark bits that we set in certain root slots. */
5264 unmark_byte_stack ();
5265 VECTOR_UNMARK (&buffer_defaults
);
5266 VECTOR_UNMARK (&buffer_local_symbols
);
5268 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5276 /* clear_marks (); */
5279 consing_since_gc
= 0;
5280 if (gc_cons_threshold
< 10000)
5281 gc_cons_threshold
= 10000;
5283 if (FLOATP (Vgc_cons_percentage
))
5284 { /* Set gc_cons_combined_threshold. */
5285 EMACS_INT total
= 0;
5287 total
+= total_conses
* sizeof (struct Lisp_Cons
);
5288 total
+= total_symbols
* sizeof (struct Lisp_Symbol
);
5289 total
+= total_markers
* sizeof (union Lisp_Misc
);
5290 total
+= total_string_size
;
5291 total
+= total_vector_size
* sizeof (Lisp_Object
);
5292 total
+= total_floats
* sizeof (struct Lisp_Float
);
5293 total
+= total_intervals
* sizeof (struct interval
);
5294 total
+= total_strings
* sizeof (struct Lisp_String
);
5296 gc_relative_threshold
= total
* XFLOAT_DATA (Vgc_cons_percentage
);
5299 gc_relative_threshold
= 0;
5301 if (garbage_collection_messages
)
5303 if (message_p
|| minibuf_level
> 0)
5306 message1_nolog ("Garbage collecting...done");
5309 unbind_to (count
, Qnil
);
5311 total
[0] = Fcons (make_number (total_conses
),
5312 make_number (total_free_conses
));
5313 total
[1] = Fcons (make_number (total_symbols
),
5314 make_number (total_free_symbols
));
5315 total
[2] = Fcons (make_number (total_markers
),
5316 make_number (total_free_markers
));
5317 total
[3] = make_number (total_string_size
);
5318 total
[4] = make_number (total_vector_size
);
5319 total
[5] = Fcons (make_number (total_floats
),
5320 make_number (total_free_floats
));
5321 total
[6] = Fcons (make_number (total_intervals
),
5322 make_number (total_free_intervals
));
5323 total
[7] = Fcons (make_number (total_strings
),
5324 make_number (total_free_strings
));
5326 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5328 /* Compute average percentage of zombies. */
5331 for (i
= 0; i
< 7; ++i
)
5332 if (CONSP (total
[i
]))
5333 nlive
+= XFASTINT (XCAR (total
[i
]));
5335 avg_live
= (avg_live
* ngcs
+ nlive
) / (ngcs
+ 1);
5336 max_live
= max (nlive
, max_live
);
5337 avg_zombies
= (avg_zombies
* ngcs
+ nzombies
) / (ngcs
+ 1);
5338 max_zombies
= max (nzombies
, max_zombies
);
5343 if (!NILP (Vpost_gc_hook
))
5345 int count
= inhibit_garbage_collection ();
5346 safe_run_hooks (Qpost_gc_hook
);
5347 unbind_to (count
, Qnil
);
5350 /* Accumulate statistics. */
5351 EMACS_GET_TIME (t2
);
5352 EMACS_SUB_TIME (t3
, t2
, t1
);
5353 if (FLOATP (Vgc_elapsed
))
5354 Vgc_elapsed
= make_float (XFLOAT_DATA (Vgc_elapsed
) +
5356 EMACS_USECS (t3
) * 1.0e-6);
5359 return Flist (sizeof total
/ sizeof *total
, total
);
5363 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5364 only interesting objects referenced from glyphs are strings. */
5367 mark_glyph_matrix (matrix
)
5368 struct glyph_matrix
*matrix
;
5370 struct glyph_row
*row
= matrix
->rows
;
5371 struct glyph_row
*end
= row
+ matrix
->nrows
;
5373 for (; row
< end
; ++row
)
5377 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
5379 struct glyph
*glyph
= row
->glyphs
[area
];
5380 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
5382 for (; glyph
< end_glyph
; ++glyph
)
5383 if (GC_STRINGP (glyph
->object
)
5384 && !STRING_MARKED_P (XSTRING (glyph
->object
)))
5385 mark_object (glyph
->object
);
5391 /* Mark Lisp faces in the face cache C. */
5395 struct face_cache
*c
;
5400 for (i
= 0; i
< c
->used
; ++i
)
5402 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
5406 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
5407 mark_object (face
->lface
[j
]);
5414 #ifdef HAVE_WINDOW_SYSTEM
5416 /* Mark Lisp objects in image IMG. */
5422 mark_object (img
->spec
);
5424 if (!NILP (img
->data
.lisp_val
))
5425 mark_object (img
->data
.lisp_val
);
5429 /* Mark Lisp objects in image cache of frame F. It's done this way so
5430 that we don't have to include xterm.h here. */
5433 mark_image_cache (f
)
5436 forall_images_in_image_cache (f
, mark_image
);
5439 #endif /* HAVE_X_WINDOWS */
5443 /* Mark reference to a Lisp_Object.
5444 If the object referred to has not been seen yet, recursively mark
5445 all the references contained in it. */
5447 #define LAST_MARKED_SIZE 500
5448 Lisp_Object last_marked
[LAST_MARKED_SIZE
];
5449 int last_marked_index
;
5451 /* For debugging--call abort when we cdr down this many
5452 links of a list, in mark_object. In debugging,
5453 the call to abort will hit a breakpoint.
5454 Normally this is zero and the check never goes off. */
5455 int mark_object_loop_halt
;
5461 register Lisp_Object obj
= arg
;
5462 #ifdef GC_CHECK_MARKED_OBJECTS
5470 if (PURE_POINTER_P (XPNTR (obj
)))
5473 last_marked
[last_marked_index
++] = obj
;
5474 if (last_marked_index
== LAST_MARKED_SIZE
)
5475 last_marked_index
= 0;
5477 /* Perform some sanity checks on the objects marked here. Abort if
5478 we encounter an object we know is bogus. This increases GC time
5479 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5480 #ifdef GC_CHECK_MARKED_OBJECTS
5482 po
= (void *) XPNTR (obj
);
5484 /* Check that the object pointed to by PO is known to be a Lisp
5485 structure allocated from the heap. */
5486 #define CHECK_ALLOCATED() \
5488 m = mem_find (po); \
5493 /* Check that the object pointed to by PO is live, using predicate
5495 #define CHECK_LIVE(LIVEP) \
5497 if (!LIVEP (m, po)) \
5501 /* Check both of the above conditions. */
5502 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5504 CHECK_ALLOCATED (); \
5505 CHECK_LIVE (LIVEP); \
5508 #else /* not GC_CHECK_MARKED_OBJECTS */
5510 #define CHECK_ALLOCATED() (void) 0
5511 #define CHECK_LIVE(LIVEP) (void) 0
5512 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5514 #endif /* not GC_CHECK_MARKED_OBJECTS */
5516 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
5520 register struct Lisp_String
*ptr
= XSTRING (obj
);
5521 CHECK_ALLOCATED_AND_LIVE (live_string_p
);
5522 MARK_INTERVAL_TREE (ptr
->intervals
);
5524 #ifdef GC_CHECK_STRING_BYTES
5525 /* Check that the string size recorded in the string is the
5526 same as the one recorded in the sdata structure. */
5527 CHECK_STRING_BYTES (ptr
);
5528 #endif /* GC_CHECK_STRING_BYTES */
5532 case Lisp_Vectorlike
:
5533 #ifdef GC_CHECK_MARKED_OBJECTS
5535 if (m
== MEM_NIL
&& !GC_SUBRP (obj
)
5536 && po
!= &buffer_defaults
5537 && po
!= &buffer_local_symbols
)
5539 #endif /* GC_CHECK_MARKED_OBJECTS */
5541 if (GC_BUFFERP (obj
))
5543 if (!VECTOR_MARKED_P (XBUFFER (obj
)))
5545 #ifdef GC_CHECK_MARKED_OBJECTS
5546 if (po
!= &buffer_defaults
&& po
!= &buffer_local_symbols
)
5549 for (b
= all_buffers
; b
&& b
!= po
; b
= b
->next
)
5554 #endif /* GC_CHECK_MARKED_OBJECTS */
5558 else if (GC_SUBRP (obj
))
5560 else if (GC_COMPILEDP (obj
))
5561 /* We could treat this just like a vector, but it is better to
5562 save the COMPILED_CONSTANTS element for last and avoid
5565 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5566 register EMACS_INT size
= ptr
->size
;
5569 if (VECTOR_MARKED_P (ptr
))
5570 break; /* Already marked */
5572 CHECK_LIVE (live_vector_p
);
5573 VECTOR_MARK (ptr
); /* Else mark it */
5574 size
&= PSEUDOVECTOR_SIZE_MASK
;
5575 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5577 if (i
!= COMPILED_CONSTANTS
)
5578 mark_object (ptr
->contents
[i
]);
5580 obj
= ptr
->contents
[COMPILED_CONSTANTS
];
5583 else if (GC_FRAMEP (obj
))
5585 register struct frame
*ptr
= XFRAME (obj
);
5587 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5588 VECTOR_MARK (ptr
); /* Else mark it */
5590 CHECK_LIVE (live_vector_p
);
5591 mark_object (ptr
->name
);
5592 mark_object (ptr
->icon_name
);
5593 mark_object (ptr
->title
);
5594 mark_object (ptr
->focus_frame
);
5595 mark_object (ptr
->selected_window
);
5596 mark_object (ptr
->minibuffer_window
);
5597 mark_object (ptr
->param_alist
);
5598 mark_object (ptr
->scroll_bars
);
5599 mark_object (ptr
->condemned_scroll_bars
);
5600 mark_object (ptr
->menu_bar_items
);
5601 mark_object (ptr
->face_alist
);
5602 mark_object (ptr
->menu_bar_vector
);
5603 mark_object (ptr
->buffer_predicate
);
5604 mark_object (ptr
->buffer_list
);
5605 mark_object (ptr
->menu_bar_window
);
5606 mark_object (ptr
->tool_bar_window
);
5607 mark_face_cache (ptr
->face_cache
);
5608 #ifdef HAVE_WINDOW_SYSTEM
5609 mark_image_cache (ptr
);
5610 mark_object (ptr
->tool_bar_items
);
5611 mark_object (ptr
->desired_tool_bar_string
);
5612 mark_object (ptr
->current_tool_bar_string
);
5613 #endif /* HAVE_WINDOW_SYSTEM */
5615 else if (GC_BOOL_VECTOR_P (obj
))
5617 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5619 if (VECTOR_MARKED_P (ptr
))
5620 break; /* Already marked */
5621 CHECK_LIVE (live_vector_p
);
5622 VECTOR_MARK (ptr
); /* Else mark it */
5624 else if (GC_WINDOWP (obj
))
5626 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5627 struct window
*w
= XWINDOW (obj
);
5630 /* Stop if already marked. */
5631 if (VECTOR_MARKED_P (ptr
))
5635 CHECK_LIVE (live_vector_p
);
5638 /* There is no Lisp data above The member CURRENT_MATRIX in
5639 struct WINDOW. Stop marking when that slot is reached. */
5641 (char *) &ptr
->contents
[i
] < (char *) &w
->current_matrix
;
5643 mark_object (ptr
->contents
[i
]);
5645 /* Mark glyphs for leaf windows. Marking window matrices is
5646 sufficient because frame matrices use the same glyph
5648 if (NILP (w
->hchild
)
5650 && w
->current_matrix
)
5652 mark_glyph_matrix (w
->current_matrix
);
5653 mark_glyph_matrix (w
->desired_matrix
);
5656 else if (GC_HASH_TABLE_P (obj
))
5658 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
5660 /* Stop if already marked. */
5661 if (VECTOR_MARKED_P (h
))
5665 CHECK_LIVE (live_vector_p
);
5668 /* Mark contents. */
5669 /* Do not mark next_free or next_weak.
5670 Being in the next_weak chain
5671 should not keep the hash table alive.
5672 No need to mark `count' since it is an integer. */
5673 mark_object (h
->test
);
5674 mark_object (h
->weak
);
5675 mark_object (h
->rehash_size
);
5676 mark_object (h
->rehash_threshold
);
5677 mark_object (h
->hash
);
5678 mark_object (h
->next
);
5679 mark_object (h
->index
);
5680 mark_object (h
->user_hash_function
);
5681 mark_object (h
->user_cmp_function
);
5683 /* If hash table is not weak, mark all keys and values.
5684 For weak tables, mark only the vector. */
5685 if (GC_NILP (h
->weak
))
5686 mark_object (h
->key_and_value
);
5688 VECTOR_MARK (XVECTOR (h
->key_and_value
));
5692 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
5693 register EMACS_INT size
= ptr
->size
;
5696 if (VECTOR_MARKED_P (ptr
)) break; /* Already marked */
5697 CHECK_LIVE (live_vector_p
);
5698 VECTOR_MARK (ptr
); /* Else mark it */
5699 if (size
& PSEUDOVECTOR_FLAG
)
5700 size
&= PSEUDOVECTOR_SIZE_MASK
;
5702 /* Note that this size is not the memory-footprint size, but only
5703 the number of Lisp_Object fields that we should trace.
5704 The distinction is used e.g. by Lisp_Process which places extra
5705 non-Lisp_Object fields at the end of the structure. */
5706 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
5707 mark_object (ptr
->contents
[i
]);
5713 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
5714 struct Lisp_Symbol
*ptrx
;
5716 if (ptr
->gcmarkbit
) break;
5717 CHECK_ALLOCATED_AND_LIVE (live_symbol_p
);
5719 mark_object (ptr
->value
);
5720 mark_object (ptr
->function
);
5721 mark_object (ptr
->plist
);
5723 if (!PURE_POINTER_P (XSTRING (ptr
->xname
)))
5724 MARK_STRING (XSTRING (ptr
->xname
));
5725 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr
->xname
));
5727 /* Note that we do not mark the obarray of the symbol.
5728 It is safe not to do so because nothing accesses that
5729 slot except to check whether it is nil. */
5733 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
5734 XSETSYMBOL (obj
, ptrx
);
5741 CHECK_ALLOCATED_AND_LIVE (live_misc_p
);
5742 if (XMARKER (obj
)->gcmarkbit
)
5744 XMARKER (obj
)->gcmarkbit
= 1;
5746 switch (XMISCTYPE (obj
))
5748 case Lisp_Misc_Buffer_Local_Value
:
5749 case Lisp_Misc_Some_Buffer_Local_Value
:
5751 register struct Lisp_Buffer_Local_Value
*ptr
5752 = XBUFFER_LOCAL_VALUE (obj
);
5753 /* If the cdr is nil, avoid recursion for the car. */
5754 if (EQ (ptr
->cdr
, Qnil
))
5756 obj
= ptr
->realvalue
;
5759 mark_object (ptr
->realvalue
);
5760 mark_object (ptr
->buffer
);
5761 mark_object (ptr
->frame
);
5766 case Lisp_Misc_Marker
:
5767 /* DO NOT mark thru the marker's chain.
5768 The buffer's markers chain does not preserve markers from gc;
5769 instead, markers are removed from the chain when freed by gc. */
5772 case Lisp_Misc_Intfwd
:
5773 case Lisp_Misc_Boolfwd
:
5774 case Lisp_Misc_Objfwd
:
5775 case Lisp_Misc_Buffer_Objfwd
:
5776 case Lisp_Misc_Kboard_Objfwd
:
5777 /* Don't bother with Lisp_Buffer_Objfwd,
5778 since all markable slots in current buffer marked anyway. */
5779 /* Don't need to do Lisp_Objfwd, since the places they point
5780 are protected with staticpro. */
5783 case Lisp_Misc_Save_Value
:
5786 register struct Lisp_Save_Value
*ptr
= XSAVE_VALUE (obj
);
5787 /* If DOGC is set, POINTER is the address of a memory
5788 area containing INTEGER potential Lisp_Objects. */
5791 Lisp_Object
*p
= (Lisp_Object
*) ptr
->pointer
;
5793 for (nelt
= ptr
->integer
; nelt
> 0; nelt
--, p
++)
5794 mark_maybe_object (*p
);
5800 case Lisp_Misc_Overlay
:
5802 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
5803 mark_object (ptr
->start
);
5804 mark_object (ptr
->end
);
5805 mark_object (ptr
->plist
);
5808 XSETMISC (obj
, ptr
->next
);
5821 register struct Lisp_Cons
*ptr
= XCONS (obj
);
5822 if (CONS_MARKED_P (ptr
)) break;
5823 CHECK_ALLOCATED_AND_LIVE (live_cons_p
);
5825 /* If the cdr is nil, avoid recursion for the car. */
5826 if (EQ (ptr
->u
.cdr
, Qnil
))
5832 mark_object (ptr
->car
);
5835 if (cdr_count
== mark_object_loop_halt
)
5841 CHECK_ALLOCATED_AND_LIVE (live_float_p
);
5842 FLOAT_MARK (XFLOAT (obj
));
5853 #undef CHECK_ALLOCATED
5854 #undef CHECK_ALLOCATED_AND_LIVE
5857 /* Mark the pointers in a buffer structure. */
5863 register struct buffer
*buffer
= XBUFFER (buf
);
5864 register Lisp_Object
*ptr
, tmp
;
5865 Lisp_Object base_buffer
;
5867 VECTOR_MARK (buffer
);
5869 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
5871 /* For now, we just don't mark the undo_list. It's done later in
5872 a special way just before the sweep phase, and after stripping
5873 some of its elements that are not needed any more. */
5875 if (buffer
->overlays_before
)
5877 XSETMISC (tmp
, buffer
->overlays_before
);
5880 if (buffer
->overlays_after
)
5882 XSETMISC (tmp
, buffer
->overlays_after
);
5886 for (ptr
= &buffer
->name
;
5887 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
5891 /* If this is an indirect buffer, mark its base buffer. */
5892 if (buffer
->base_buffer
&& !VECTOR_MARKED_P (buffer
->base_buffer
))
5894 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
5895 mark_buffer (base_buffer
);
5900 /* Value is non-zero if OBJ will survive the current GC because it's
5901 either marked or does not need to be marked to survive. */
5909 switch (XGCTYPE (obj
))
5916 survives_p
= XSYMBOL (obj
)->gcmarkbit
;
5920 survives_p
= XMARKER (obj
)->gcmarkbit
;
5924 survives_p
= STRING_MARKED_P (XSTRING (obj
));
5927 case Lisp_Vectorlike
:
5928 survives_p
= GC_SUBRP (obj
) || VECTOR_MARKED_P (XVECTOR (obj
));
5932 survives_p
= CONS_MARKED_P (XCONS (obj
));
5936 survives_p
= FLOAT_MARKED_P (XFLOAT (obj
));
5943 return survives_p
|| PURE_POINTER_P ((void *) XPNTR (obj
));
5948 /* Sweep: find all structures not marked, and free them. */
5953 /* Remove or mark entries in weak hash tables.
5954 This must be done before any object is unmarked. */
5955 sweep_weak_hash_tables ();
5958 #ifdef GC_CHECK_STRING_BYTES
5959 if (!noninteractive
)
5960 check_string_bytes (1);
5963 /* Put all unmarked conses on free list */
5965 register struct cons_block
*cblk
;
5966 struct cons_block
**cprev
= &cons_block
;
5967 register int lim
= cons_block_index
;
5968 register int num_free
= 0, num_used
= 0;
5972 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
5976 for (i
= 0; i
< lim
; i
++)
5977 if (!CONS_MARKED_P (&cblk
->conses
[i
]))
5980 cblk
->conses
[i
].u
.chain
= cons_free_list
;
5981 cons_free_list
= &cblk
->conses
[i
];
5983 cons_free_list
->car
= Vdead
;
5989 CONS_UNMARK (&cblk
->conses
[i
]);
5991 lim
= CONS_BLOCK_SIZE
;
5992 /* If this block contains only free conses and we have already
5993 seen more than two blocks worth of free conses then deallocate
5995 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
5997 *cprev
= cblk
->next
;
5998 /* Unhook from the free list. */
5999 cons_free_list
= cblk
->conses
[0].u
.chain
;
6000 lisp_align_free (cblk
);
6005 num_free
+= this_free
;
6006 cprev
= &cblk
->next
;
6009 total_conses
= num_used
;
6010 total_free_conses
= num_free
;
6013 /* Put all unmarked floats on free list */
6015 register struct float_block
*fblk
;
6016 struct float_block
**fprev
= &float_block
;
6017 register int lim
= float_block_index
;
6018 register int num_free
= 0, num_used
= 0;
6020 float_free_list
= 0;
6022 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
6026 for (i
= 0; i
< lim
; i
++)
6027 if (!FLOAT_MARKED_P (&fblk
->floats
[i
]))
6030 fblk
->floats
[i
].u
.chain
= float_free_list
;
6031 float_free_list
= &fblk
->floats
[i
];
6036 FLOAT_UNMARK (&fblk
->floats
[i
]);
6038 lim
= FLOAT_BLOCK_SIZE
;
6039 /* If this block contains only free floats and we have already
6040 seen more than two blocks worth of free floats then deallocate
6042 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
6044 *fprev
= fblk
->next
;
6045 /* Unhook from the free list. */
6046 float_free_list
= fblk
->floats
[0].u
.chain
;
6047 lisp_align_free (fblk
);
6052 num_free
+= this_free
;
6053 fprev
= &fblk
->next
;
6056 total_floats
= num_used
;
6057 total_free_floats
= num_free
;
6060 /* Put all unmarked intervals on free list */
6062 register struct interval_block
*iblk
;
6063 struct interval_block
**iprev
= &interval_block
;
6064 register int lim
= interval_block_index
;
6065 register int num_free
= 0, num_used
= 0;
6067 interval_free_list
= 0;
6069 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
6074 for (i
= 0; i
< lim
; i
++)
6076 if (!iblk
->intervals
[i
].gcmarkbit
)
6078 SET_INTERVAL_PARENT (&iblk
->intervals
[i
], interval_free_list
);
6079 interval_free_list
= &iblk
->intervals
[i
];
6085 iblk
->intervals
[i
].gcmarkbit
= 0;
6088 lim
= INTERVAL_BLOCK_SIZE
;
6089 /* If this block contains only free intervals and we have already
6090 seen more than two blocks worth of free intervals then
6091 deallocate this block. */
6092 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
6094 *iprev
= iblk
->next
;
6095 /* Unhook from the free list. */
6096 interval_free_list
= INTERVAL_PARENT (&iblk
->intervals
[0]);
6098 n_interval_blocks
--;
6102 num_free
+= this_free
;
6103 iprev
= &iblk
->next
;
6106 total_intervals
= num_used
;
6107 total_free_intervals
= num_free
;
6110 /* Put all unmarked symbols on free list */
6112 register struct symbol_block
*sblk
;
6113 struct symbol_block
**sprev
= &symbol_block
;
6114 register int lim
= symbol_block_index
;
6115 register int num_free
= 0, num_used
= 0;
6117 symbol_free_list
= NULL
;
6119 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
6122 struct Lisp_Symbol
*sym
= sblk
->symbols
;
6123 struct Lisp_Symbol
*end
= sym
+ lim
;
6125 for (; sym
< end
; ++sym
)
6127 /* Check if the symbol was created during loadup. In such a case
6128 it might be pointed to by pure bytecode which we don't trace,
6129 so we conservatively assume that it is live. */
6130 int pure_p
= PURE_POINTER_P (XSTRING (sym
->xname
));
6132 if (!sym
->gcmarkbit
&& !pure_p
)
6134 sym
->next
= symbol_free_list
;
6135 symbol_free_list
= sym
;
6137 symbol_free_list
->function
= Vdead
;
6145 UNMARK_STRING (XSTRING (sym
->xname
));
6150 lim
= SYMBOL_BLOCK_SIZE
;
6151 /* If this block contains only free symbols and we have already
6152 seen more than two blocks worth of free symbols then deallocate
6154 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
6156 *sprev
= sblk
->next
;
6157 /* Unhook from the free list. */
6158 symbol_free_list
= sblk
->symbols
[0].next
;
6164 num_free
+= this_free
;
6165 sprev
= &sblk
->next
;
6168 total_symbols
= num_used
;
6169 total_free_symbols
= num_free
;
6172 /* Put all unmarked misc's on free list.
6173 For a marker, first unchain it from the buffer it points into. */
6175 register struct marker_block
*mblk
;
6176 struct marker_block
**mprev
= &marker_block
;
6177 register int lim
= marker_block_index
;
6178 register int num_free
= 0, num_used
= 0;
6180 marker_free_list
= 0;
6182 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
6187 for (i
= 0; i
< lim
; i
++)
6189 if (!mblk
->markers
[i
].u_marker
.gcmarkbit
)
6191 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
6192 unchain_marker (&mblk
->markers
[i
].u_marker
);
6193 /* Set the type of the freed object to Lisp_Misc_Free.
6194 We could leave the type alone, since nobody checks it,
6195 but this might catch bugs faster. */
6196 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
6197 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
6198 marker_free_list
= &mblk
->markers
[i
];
6204 mblk
->markers
[i
].u_marker
.gcmarkbit
= 0;
6207 lim
= MARKER_BLOCK_SIZE
;
6208 /* If this block contains only free markers and we have already
6209 seen more than two blocks worth of free markers then deallocate
6211 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
6213 *mprev
= mblk
->next
;
6214 /* Unhook from the free list. */
6215 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
6221 num_free
+= this_free
;
6222 mprev
= &mblk
->next
;
6226 total_markers
= num_used
;
6227 total_free_markers
= num_free
;
6230 /* Free all unmarked buffers */
6232 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
6235 if (!VECTOR_MARKED_P (buffer
))
6238 prev
->next
= buffer
->next
;
6240 all_buffers
= buffer
->next
;
6241 next
= buffer
->next
;
6247 VECTOR_UNMARK (buffer
);
6248 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
6249 prev
= buffer
, buffer
= buffer
->next
;
6253 /* Free all unmarked vectors */
6255 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
6256 total_vector_size
= 0;
6259 if (!VECTOR_MARKED_P (vector
))
6262 prev
->next
= vector
->next
;
6264 all_vectors
= vector
->next
;
6265 next
= vector
->next
;
6273 VECTOR_UNMARK (vector
);
6274 if (vector
->size
& PSEUDOVECTOR_FLAG
)
6275 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
6277 total_vector_size
+= vector
->size
;
6278 prev
= vector
, vector
= vector
->next
;
6282 #ifdef GC_CHECK_STRING_BYTES
6283 if (!noninteractive
)
6284 check_string_bytes (1);
6291 /* Debugging aids. */
6293 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
6294 doc
: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6295 This may be helpful in debugging Emacs's memory usage.
6296 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6301 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
6306 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
6307 doc
: /* Return a list of counters that measure how much consing there has been.
6308 Each of these counters increments for a certain kind of object.
6309 The counters wrap around from the largest positive integer to zero.
6310 Garbage collection does not decrease them.
6311 The elements of the value are as follows:
6312 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6313 All are in units of 1 = one object consed
6314 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6316 MISCS include overlays, markers, and some internal types.
6317 Frames, windows, buffers, and subprocesses count as vectors
6318 (but the contents of a buffer's text do not count here). */)
6321 Lisp_Object consed
[8];
6323 consed
[0] = make_number (min (MOST_POSITIVE_FIXNUM
, cons_cells_consed
));
6324 consed
[1] = make_number (min (MOST_POSITIVE_FIXNUM
, floats_consed
));
6325 consed
[2] = make_number (min (MOST_POSITIVE_FIXNUM
, vector_cells_consed
));
6326 consed
[3] = make_number (min (MOST_POSITIVE_FIXNUM
, symbols_consed
));
6327 consed
[4] = make_number (min (MOST_POSITIVE_FIXNUM
, string_chars_consed
));
6328 consed
[5] = make_number (min (MOST_POSITIVE_FIXNUM
, misc_objects_consed
));
6329 consed
[6] = make_number (min (MOST_POSITIVE_FIXNUM
, intervals_consed
));
6330 consed
[7] = make_number (min (MOST_POSITIVE_FIXNUM
, strings_consed
));
6332 return Flist (8, consed
);
6335 int suppress_checking
;
6337 die (msg
, file
, line
)
6342 fprintf (stderr
, "\r\nEmacs fatal error: %s:%d: %s\r\n",
6347 /* Initialization */
6352 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6354 pure_size
= PURESIZE
;
6355 pure_bytes_used
= 0;
6356 pure_bytes_used_lisp
= pure_bytes_used_non_lisp
= 0;
6357 pure_bytes_used_before_overflow
= 0;
6359 /* Initialize the list of free aligned blocks. */
6362 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6364 Vdead
= make_pure_string ("DEAD", 4, 4, 0);
6368 ignore_warnings
= 1;
6369 #ifdef DOUG_LEA_MALLOC
6370 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
6371 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
6372 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
6382 malloc_hysteresis
= 32;
6384 malloc_hysteresis
= 0;
6387 refill_memory_reserve ();
6389 ignore_warnings
= 0;
6391 byte_stack_list
= 0;
6393 consing_since_gc
= 0;
6394 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
6395 gc_relative_threshold
= 0;
6397 #ifdef VIRT_ADDR_VARIES
6398 malloc_sbrk_unused
= 1<<22; /* A large number */
6399 malloc_sbrk_used
= 100000; /* as reasonable as any number */
6400 #endif /* VIRT_ADDR_VARIES */
6407 byte_stack_list
= 0;
6409 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6410 setjmp_tested_p
= longjmps_done
= 0;
6413 Vgc_elapsed
= make_float (0.0);
6420 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
6421 doc
: /* *Number of bytes of consing between garbage collections.
6422 Garbage collection can happen automatically once this many bytes have been
6423 allocated since the last garbage collection. All data types count.
6425 Garbage collection happens automatically only when `eval' is called.
6427 By binding this temporarily to a large number, you can effectively
6428 prevent garbage collection during a part of the program.
6429 See also `gc-cons-percentage'. */);
6431 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage
,
6432 doc
: /* *Portion of the heap used for allocation.
6433 Garbage collection can happen automatically once this portion of the heap
6434 has been allocated since the last garbage collection.
6435 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6436 Vgc_cons_percentage
= make_float (0.1);
6438 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used
,
6439 doc
: /* Number of bytes of sharable Lisp data allocated so far. */);
6441 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
6442 doc
: /* Number of cons cells that have been consed so far. */);
6444 DEFVAR_INT ("floats-consed", &floats_consed
,
6445 doc
: /* Number of floats that have been consed so far. */);
6447 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
6448 doc
: /* Number of vector cells that have been consed so far. */);
6450 DEFVAR_INT ("symbols-consed", &symbols_consed
,
6451 doc
: /* Number of symbols that have been consed so far. */);
6453 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
6454 doc
: /* Number of string characters that have been consed so far. */);
6456 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
6457 doc
: /* Number of miscellaneous objects that have been consed so far. */);
6459 DEFVAR_INT ("intervals-consed", &intervals_consed
,
6460 doc
: /* Number of intervals that have been consed so far. */);
6462 DEFVAR_INT ("strings-consed", &strings_consed
,
6463 doc
: /* Number of strings that have been consed so far. */);
6465 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
6466 doc
: /* Non-nil means loading Lisp code in order to dump an executable.
6467 This means that certain objects should be allocated in shared (pure) space. */);
6469 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
6470 doc
: /* Non-nil means display messages at start and end of garbage collection. */);
6471 garbage_collection_messages
= 0;
6473 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook
,
6474 doc
: /* Hook run after garbage collection has finished. */);
6475 Vpost_gc_hook
= Qnil
;
6476 Qpost_gc_hook
= intern ("post-gc-hook");
6477 staticpro (&Qpost_gc_hook
);
6479 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data
,
6480 doc
: /* Precomputed `signal' argument for memory-full error. */);
6481 /* We build this in advance because if we wait until we need it, we might
6482 not be able to allocate the memory to hold it. */
6485 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6487 DEFVAR_LISP ("memory-full", &Vmemory_full
,
6488 doc
: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6489 Vmemory_full
= Qnil
;
6491 staticpro (&Qgc_cons_threshold
);
6492 Qgc_cons_threshold
= intern ("gc-cons-threshold");
6494 staticpro (&Qchar_table_extra_slots
);
6495 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
6497 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed
,
6498 doc
: /* Accumulated time elapsed in garbage collections.
6499 The time is in seconds as a floating point value. */);
6500 DEFVAR_INT ("gcs-done", &gcs_done
,
6501 doc
: /* Accumulated number of garbage collections done. */);
6506 defsubr (&Smake_byte_code
);
6507 defsubr (&Smake_list
);
6508 defsubr (&Smake_vector
);
6509 defsubr (&Smake_char_table
);
6510 defsubr (&Smake_string
);
6511 defsubr (&Smake_bool_vector
);
6512 defsubr (&Smake_symbol
);
6513 defsubr (&Smake_marker
);
6514 defsubr (&Spurecopy
);
6515 defsubr (&Sgarbage_collect
);
6516 defsubr (&Smemory_limit
);
6517 defsubr (&Smemory_use_counts
);
6519 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6520 defsubr (&Sgc_status
);
6524 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6525 (do not change this comment) */