Consolidate the image_cache to the terminal struct.
[emacs.git] / src / alloc.c
blobfe37eec93793d6099b1f5a8b21b11e39e207cdd9
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, 2008
4 Free Software Foundation, Inc.
6 This file is part of GNU Emacs.
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
23 #include <config.h>
24 #include <stdio.h>
25 #include <limits.h> /* For CHAR_BIT. */
27 #ifdef STDC_HEADERS
28 #include <stddef.h> /* For offsetof, used by PSEUDOVECSIZE. */
29 #endif
31 #ifdef ALLOC_DEBUG
32 #undef INLINE
33 #endif
35 /* Note that this declares bzero on OSF/1. How dumb. */
37 #include <signal.h>
39 #ifdef HAVE_GTK_AND_PTHREAD
40 #include <pthread.h>
41 #endif
43 /* This file is part of the core Lisp implementation, and thus must
44 deal with the real data structures. If the Lisp implementation is
45 replaced, this file likely will not be used. */
47 #undef HIDE_LISP_IMPLEMENTATION
48 #include "lisp.h"
49 #include "process.h"
50 #include "intervals.h"
51 #include "puresize.h"
52 #include "buffer.h"
53 #include "window.h"
54 #include "keyboard.h"
55 #include "frame.h"
56 #include "blockinput.h"
57 #include "character.h"
58 #include "syssignal.h"
59 #include "termhooks.h" /* For struct terminal. */
60 #include <setjmp.h>
62 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
63 memory. Can do this only if using gmalloc.c. */
65 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
66 #undef GC_MALLOC_CHECK
67 #endif
69 #ifdef HAVE_UNISTD_H
70 #include <unistd.h>
71 #else
72 extern POINTER_TYPE *sbrk ();
73 #endif
75 #ifdef HAVE_FCNTL_H
76 #define INCLUDED_FCNTL
77 #include <fcntl.h>
78 #endif
79 #ifndef O_WRONLY
80 #define O_WRONLY 1
81 #endif
83 #ifdef WINDOWSNT
84 #include <fcntl.h>
85 #include "w32.h"
86 #endif
88 #ifdef DOUG_LEA_MALLOC
90 #include <malloc.h>
91 /* malloc.h #defines this as size_t, at least in glibc2. */
92 #ifndef __malloc_size_t
93 #define __malloc_size_t int
94 #endif
96 /* Specify maximum number of areas to mmap. It would be nice to use a
97 value that explicitly means "no limit". */
99 #define MMAP_MAX_AREAS 100000000
101 #else /* not DOUG_LEA_MALLOC */
103 /* The following come from gmalloc.c. */
105 #define __malloc_size_t size_t
106 extern __malloc_size_t _bytes_used;
107 extern __malloc_size_t __malloc_extra_blocks;
109 #endif /* not DOUG_LEA_MALLOC */
111 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
113 /* When GTK uses the file chooser dialog, different backends can be loaded
114 dynamically. One such a backend is the Gnome VFS backend that gets loaded
115 if you run Gnome. That backend creates several threads and also allocates
116 memory with malloc.
118 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
119 functions below are called from malloc, there is a chance that one
120 of these threads preempts the Emacs main thread and the hook variables
121 end up in an inconsistent state. So we have a mutex to prevent that (note
122 that the backend handles concurrent access to malloc within its own threads
123 but Emacs code running in the main thread is not included in that control).
125 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
126 happens in one of the backend threads we will have two threads that tries
127 to run Emacs code at once, and the code is not prepared for that.
128 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
130 static pthread_mutex_t alloc_mutex;
132 #define BLOCK_INPUT_ALLOC \
133 do \
135 if (pthread_equal (pthread_self (), main_thread)) \
136 BLOCK_INPUT; \
137 pthread_mutex_lock (&alloc_mutex); \
139 while (0)
140 #define UNBLOCK_INPUT_ALLOC \
141 do \
143 pthread_mutex_unlock (&alloc_mutex); \
144 if (pthread_equal (pthread_self (), main_thread)) \
145 UNBLOCK_INPUT; \
147 while (0)
149 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
151 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
152 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
154 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
156 /* Value of _bytes_used, when spare_memory was freed. */
158 static __malloc_size_t bytes_used_when_full;
160 static __malloc_size_t bytes_used_when_reconsidered;
162 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
163 to a struct Lisp_String. */
165 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
166 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
167 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
169 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
170 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
171 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
173 /* Value is the number of bytes/chars of S, a pointer to a struct
174 Lisp_String. This must be used instead of STRING_BYTES (S) or
175 S->size during GC, because S->size contains the mark bit for
176 strings. */
178 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
179 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
181 /* Number of bytes of consing done since the last gc. */
183 int consing_since_gc;
185 /* Count the amount of consing of various sorts of space. */
187 EMACS_INT cons_cells_consed;
188 EMACS_INT floats_consed;
189 EMACS_INT vector_cells_consed;
190 EMACS_INT symbols_consed;
191 EMACS_INT string_chars_consed;
192 EMACS_INT misc_objects_consed;
193 EMACS_INT intervals_consed;
194 EMACS_INT strings_consed;
196 /* Minimum number of bytes of consing since GC before next GC. */
198 EMACS_INT gc_cons_threshold;
200 /* Similar minimum, computed from Vgc_cons_percentage. */
202 EMACS_INT gc_relative_threshold;
204 static Lisp_Object Vgc_cons_percentage;
206 /* Minimum number of bytes of consing since GC before next GC,
207 when memory is full. */
209 EMACS_INT memory_full_cons_threshold;
211 /* Nonzero during GC. */
213 int gc_in_progress;
215 /* Nonzero means abort if try to GC.
216 This is for code which is written on the assumption that
217 no GC will happen, so as to verify that assumption. */
219 int abort_on_gc;
221 /* Nonzero means display messages at beginning and end of GC. */
223 int garbage_collection_messages;
225 #ifndef VIRT_ADDR_VARIES
226 extern
227 #endif /* VIRT_ADDR_VARIES */
228 int malloc_sbrk_used;
230 #ifndef VIRT_ADDR_VARIES
231 extern
232 #endif /* VIRT_ADDR_VARIES */
233 int malloc_sbrk_unused;
235 /* Number of live and free conses etc. */
237 static int total_conses, total_markers, total_symbols, total_vector_size;
238 static int total_free_conses, total_free_markers, total_free_symbols;
239 static int total_free_floats, total_floats;
241 /* Points to memory space allocated as "spare", to be freed if we run
242 out of memory. We keep one large block, four cons-blocks, and
243 two string blocks. */
245 static char *spare_memory[7];
247 /* Amount of spare memory to keep in large reserve block. */
249 #define SPARE_MEMORY (1 << 14)
251 /* Number of extra blocks malloc should get when it needs more core. */
253 static int malloc_hysteresis;
255 /* Non-nil means defun should do purecopy on the function definition. */
257 Lisp_Object Vpurify_flag;
259 /* Non-nil means we are handling a memory-full error. */
261 Lisp_Object Vmemory_full;
263 #ifndef HAVE_SHM
265 /* Initialize it to a nonzero value to force it into data space
266 (rather than bss space). That way unexec will remap it into text
267 space (pure), on some systems. We have not implemented the
268 remapping on more recent systems because this is less important
269 nowadays than in the days of small memories and timesharing. */
271 EMACS_INT pure[(PURESIZE + sizeof (EMACS_INT) - 1) / sizeof (EMACS_INT)] = {1,};
272 #define PUREBEG (char *) pure
274 #else /* HAVE_SHM */
276 #define pure PURE_SEG_BITS /* Use shared memory segment */
277 #define PUREBEG (char *)PURE_SEG_BITS
279 #endif /* HAVE_SHM */
281 /* Pointer to the pure area, and its size. */
283 static char *purebeg;
284 static size_t pure_size;
286 /* Number of bytes of pure storage used before pure storage overflowed.
287 If this is non-zero, this implies that an overflow occurred. */
289 static size_t pure_bytes_used_before_overflow;
291 /* Value is non-zero if P points into pure space. */
293 #define PURE_POINTER_P(P) \
294 (((PNTR_COMPARISON_TYPE) (P) \
295 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
296 && ((PNTR_COMPARISON_TYPE) (P) \
297 >= (PNTR_COMPARISON_TYPE) purebeg))
299 /* Total number of bytes allocated in pure storage. */
301 EMACS_INT pure_bytes_used;
303 /* Index in pure at which next pure Lisp object will be allocated.. */
305 static EMACS_INT pure_bytes_used_lisp;
307 /* Number of bytes allocated for non-Lisp objects in pure storage. */
309 static EMACS_INT pure_bytes_used_non_lisp;
311 /* If nonzero, this is a warning delivered by malloc and not yet
312 displayed. */
314 char *pending_malloc_warning;
316 /* Pre-computed signal argument for use when memory is exhausted. */
318 Lisp_Object Vmemory_signal_data;
320 /* Maximum amount of C stack to save when a GC happens. */
322 #ifndef MAX_SAVE_STACK
323 #define MAX_SAVE_STACK 16000
324 #endif
326 /* Buffer in which we save a copy of the C stack at each GC. */
328 static char *stack_copy;
329 static int stack_copy_size;
331 /* Non-zero means ignore malloc warnings. Set during initialization.
332 Currently not used. */
334 static int ignore_warnings;
336 Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
338 /* Hook run after GC has finished. */
340 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
342 Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
343 EMACS_INT gcs_done; /* accumulated GCs */
345 static void mark_buffer P_ ((Lisp_Object));
346 static void mark_terminals P_ ((void));
347 extern void mark_kboards P_ ((void));
348 extern void mark_ttys P_ ((void));
349 extern void mark_backtrace P_ ((void));
350 static void gc_sweep P_ ((void));
351 static void mark_glyph_matrix P_ ((struct glyph_matrix *));
352 static void mark_face_cache P_ ((struct face_cache *));
354 #ifdef HAVE_WINDOW_SYSTEM
355 extern void mark_fringe_data P_ ((void));
356 #endif /* HAVE_WINDOW_SYSTEM */
358 static struct Lisp_String *allocate_string P_ ((void));
359 static void compact_small_strings P_ ((void));
360 static void free_large_strings P_ ((void));
361 static void sweep_strings P_ ((void));
363 extern int message_enable_multibyte;
365 /* When scanning the C stack for live Lisp objects, Emacs keeps track
366 of what memory allocated via lisp_malloc is intended for what
367 purpose. This enumeration specifies the type of memory. */
369 enum mem_type
371 MEM_TYPE_NON_LISP,
372 MEM_TYPE_BUFFER,
373 MEM_TYPE_CONS,
374 MEM_TYPE_STRING,
375 MEM_TYPE_MISC,
376 MEM_TYPE_SYMBOL,
377 MEM_TYPE_FLOAT,
378 /* We used to keep separate mem_types for subtypes of vectors such as
379 process, hash_table, frame, terminal, and window, but we never made
380 use of the distinction, so it only caused source-code complexity
381 and runtime slowdown. Minor but pointless. */
382 MEM_TYPE_VECTORLIKE
385 static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
386 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
387 void refill_memory_reserve ();
390 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
392 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
393 #include <stdio.h> /* For fprintf. */
394 #endif
396 /* A unique object in pure space used to make some Lisp objects
397 on free lists recognizable in O(1). */
399 static Lisp_Object Vdead;
401 #ifdef GC_MALLOC_CHECK
403 enum mem_type allocated_mem_type;
404 static int dont_register_blocks;
406 #endif /* GC_MALLOC_CHECK */
408 /* A node in the red-black tree describing allocated memory containing
409 Lisp data. Each such block is recorded with its start and end
410 address when it is allocated, and removed from the tree when it
411 is freed.
413 A red-black tree is a balanced binary tree with the following
414 properties:
416 1. Every node is either red or black.
417 2. Every leaf is black.
418 3. If a node is red, then both of its children are black.
419 4. Every simple path from a node to a descendant leaf contains
420 the same number of black nodes.
421 5. The root is always black.
423 When nodes are inserted into the tree, or deleted from the tree,
424 the tree is "fixed" so that these properties are always true.
426 A red-black tree with N internal nodes has height at most 2
427 log(N+1). Searches, insertions and deletions are done in O(log N).
428 Please see a text book about data structures for a detailed
429 description of red-black trees. Any book worth its salt should
430 describe them. */
432 struct mem_node
434 /* Children of this node. These pointers are never NULL. When there
435 is no child, the value is MEM_NIL, which points to a dummy node. */
436 struct mem_node *left, *right;
438 /* The parent of this node. In the root node, this is NULL. */
439 struct mem_node *parent;
441 /* Start and end of allocated region. */
442 void *start, *end;
444 /* Node color. */
445 enum {MEM_BLACK, MEM_RED} color;
447 /* Memory type. */
448 enum mem_type type;
451 /* Base address of stack. Set in main. */
453 Lisp_Object *stack_base;
455 /* Root of the tree describing allocated Lisp memory. */
457 static struct mem_node *mem_root;
459 /* Lowest and highest known address in the heap. */
461 static void *min_heap_address, *max_heap_address;
463 /* Sentinel node of the tree. */
465 static struct mem_node mem_z;
466 #define MEM_NIL &mem_z
468 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
469 static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT));
470 static void lisp_free P_ ((POINTER_TYPE *));
471 static void mark_stack P_ ((void));
472 static int live_vector_p P_ ((struct mem_node *, void *));
473 static int live_buffer_p P_ ((struct mem_node *, void *));
474 static int live_string_p P_ ((struct mem_node *, void *));
475 static int live_cons_p P_ ((struct mem_node *, void *));
476 static int live_symbol_p P_ ((struct mem_node *, void *));
477 static int live_float_p P_ ((struct mem_node *, void *));
478 static int live_misc_p P_ ((struct mem_node *, void *));
479 static void mark_maybe_object P_ ((Lisp_Object));
480 static void mark_memory P_ ((void *, void *, int));
481 static void mem_init P_ ((void));
482 static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
483 static void mem_insert_fixup P_ ((struct mem_node *));
484 static void mem_rotate_left P_ ((struct mem_node *));
485 static void mem_rotate_right P_ ((struct mem_node *));
486 static void mem_delete P_ ((struct mem_node *));
487 static void mem_delete_fixup P_ ((struct mem_node *));
488 static INLINE struct mem_node *mem_find P_ ((void *));
491 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
492 static void check_gcpros P_ ((void));
493 #endif
495 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
497 /* Recording what needs to be marked for gc. */
499 struct gcpro *gcprolist;
501 /* Addresses of staticpro'd variables. Initialize it to a nonzero
502 value; otherwise some compilers put it into BSS. */
504 #define NSTATICS 0x600
505 static Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
507 /* Index of next unused slot in staticvec. */
509 static int staticidx = 0;
511 static POINTER_TYPE *pure_alloc P_ ((size_t, int));
514 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
515 ALIGNMENT must be a power of 2. */
517 #define ALIGN(ptr, ALIGNMENT) \
518 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
519 & ~((ALIGNMENT) - 1)))
523 /************************************************************************
524 Malloc
525 ************************************************************************/
527 /* Function malloc calls this if it finds we are near exhausting storage. */
529 void
530 malloc_warning (str)
531 char *str;
533 pending_malloc_warning = str;
537 /* Display an already-pending malloc warning. */
539 void
540 display_malloc_warning ()
542 call3 (intern ("display-warning"),
543 intern ("alloc"),
544 build_string (pending_malloc_warning),
545 intern ("emergency"));
546 pending_malloc_warning = 0;
550 #ifdef DOUG_LEA_MALLOC
551 # define BYTES_USED (mallinfo ().uordblks)
552 #else
553 # define BYTES_USED _bytes_used
554 #endif
556 /* Called if we can't allocate relocatable space for a buffer. */
558 void
559 buffer_memory_full ()
561 /* If buffers use the relocating allocator, no need to free
562 spare_memory, because we may have plenty of malloc space left
563 that we could get, and if we don't, the malloc that fails will
564 itself cause spare_memory to be freed. If buffers don't use the
565 relocating allocator, treat this like any other failing
566 malloc. */
568 #ifndef REL_ALLOC
569 memory_full ();
570 #endif
572 /* This used to call error, but if we've run out of memory, we could
573 get infinite recursion trying to build the string. */
574 xsignal (Qnil, Vmemory_signal_data);
578 #ifdef XMALLOC_OVERRUN_CHECK
580 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
581 and a 16 byte trailer around each block.
583 The header consists of 12 fixed bytes + a 4 byte integer contaning the
584 original block size, while the trailer consists of 16 fixed bytes.
586 The header is used to detect whether this block has been allocated
587 through these functions -- as it seems that some low-level libc
588 functions may bypass the malloc hooks.
592 #define XMALLOC_OVERRUN_CHECK_SIZE 16
594 static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
595 { 0x9a, 0x9b, 0xae, 0xaf,
596 0xbf, 0xbe, 0xce, 0xcf,
597 0xea, 0xeb, 0xec, 0xed };
599 static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
600 { 0xaa, 0xab, 0xac, 0xad,
601 0xba, 0xbb, 0xbc, 0xbd,
602 0xca, 0xcb, 0xcc, 0xcd,
603 0xda, 0xdb, 0xdc, 0xdd };
605 /* Macros to insert and extract the block size in the header. */
607 #define XMALLOC_PUT_SIZE(ptr, size) \
608 (ptr[-1] = (size & 0xff), \
609 ptr[-2] = ((size >> 8) & 0xff), \
610 ptr[-3] = ((size >> 16) & 0xff), \
611 ptr[-4] = ((size >> 24) & 0xff))
613 #define XMALLOC_GET_SIZE(ptr) \
614 (size_t)((unsigned)(ptr[-1]) | \
615 ((unsigned)(ptr[-2]) << 8) | \
616 ((unsigned)(ptr[-3]) << 16) | \
617 ((unsigned)(ptr[-4]) << 24))
620 /* The call depth in overrun_check functions. For example, this might happen:
621 xmalloc()
622 overrun_check_malloc()
623 -> malloc -> (via hook)_-> emacs_blocked_malloc
624 -> overrun_check_malloc
625 call malloc (hooks are NULL, so real malloc is called).
626 malloc returns 10000.
627 add overhead, return 10016.
628 <- (back in overrun_check_malloc)
629 add overhead again, return 10032
630 xmalloc returns 10032.
632 (time passes).
634 xfree(10032)
635 overrun_check_free(10032)
636 decrease overhed
637 free(10016) <- crash, because 10000 is the original pointer. */
639 static int check_depth;
641 /* Like malloc, but wraps allocated block with header and trailer. */
643 POINTER_TYPE *
644 overrun_check_malloc (size)
645 size_t size;
647 register unsigned char *val;
648 size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
650 val = (unsigned char *) malloc (size + overhead);
651 if (val && check_depth == 1)
653 bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
654 val += XMALLOC_OVERRUN_CHECK_SIZE;
655 XMALLOC_PUT_SIZE(val, size);
656 bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
658 --check_depth;
659 return (POINTER_TYPE *)val;
663 /* Like realloc, but checks old block for overrun, and wraps new block
664 with header and trailer. */
666 POINTER_TYPE *
667 overrun_check_realloc (block, size)
668 POINTER_TYPE *block;
669 size_t size;
671 register unsigned char *val = (unsigned char *)block;
672 size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
674 if (val
675 && check_depth == 1
676 && bcmp (xmalloc_overrun_check_header,
677 val - XMALLOC_OVERRUN_CHECK_SIZE,
678 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
680 size_t osize = XMALLOC_GET_SIZE (val);
681 if (bcmp (xmalloc_overrun_check_trailer,
682 val + osize,
683 XMALLOC_OVERRUN_CHECK_SIZE))
684 abort ();
685 bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
686 val -= XMALLOC_OVERRUN_CHECK_SIZE;
687 bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
690 val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
692 if (val && check_depth == 1)
694 bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
695 val += XMALLOC_OVERRUN_CHECK_SIZE;
696 XMALLOC_PUT_SIZE(val, size);
697 bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
699 --check_depth;
700 return (POINTER_TYPE *)val;
703 /* Like free, but checks block for overrun. */
705 void
706 overrun_check_free (block)
707 POINTER_TYPE *block;
709 unsigned char *val = (unsigned char *)block;
711 ++check_depth;
712 if (val
713 && check_depth == 1
714 && bcmp (xmalloc_overrun_check_header,
715 val - XMALLOC_OVERRUN_CHECK_SIZE,
716 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
718 size_t osize = XMALLOC_GET_SIZE (val);
719 if (bcmp (xmalloc_overrun_check_trailer,
720 val + osize,
721 XMALLOC_OVERRUN_CHECK_SIZE))
722 abort ();
723 #ifdef XMALLOC_CLEAR_FREE_MEMORY
724 val -= XMALLOC_OVERRUN_CHECK_SIZE;
725 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
726 #else
727 bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
728 val -= XMALLOC_OVERRUN_CHECK_SIZE;
729 bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
730 #endif
733 free (val);
734 --check_depth;
737 #undef malloc
738 #undef realloc
739 #undef free
740 #define malloc overrun_check_malloc
741 #define realloc overrun_check_realloc
742 #define free overrun_check_free
743 #endif
745 #ifdef SYNC_INPUT
746 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
747 there's no need to block input around malloc. */
748 #define MALLOC_BLOCK_INPUT ((void)0)
749 #define MALLOC_UNBLOCK_INPUT ((void)0)
750 #else
751 #define MALLOC_BLOCK_INPUT BLOCK_INPUT
752 #define MALLOC_UNBLOCK_INPUT UNBLOCK_INPUT
753 #endif
755 /* Like malloc but check for no memory and block interrupt input.. */
757 POINTER_TYPE *
758 xmalloc (size)
759 size_t size;
761 register POINTER_TYPE *val;
763 MALLOC_BLOCK_INPUT;
764 val = (POINTER_TYPE *) malloc (size);
765 MALLOC_UNBLOCK_INPUT;
767 if (!val && size)
768 memory_full ();
769 return val;
773 /* Like realloc but check for no memory and block interrupt input.. */
775 POINTER_TYPE *
776 xrealloc (block, size)
777 POINTER_TYPE *block;
778 size_t size;
780 register POINTER_TYPE *val;
782 MALLOC_BLOCK_INPUT;
783 /* We must call malloc explicitly when BLOCK is 0, since some
784 reallocs don't do this. */
785 if (! block)
786 val = (POINTER_TYPE *) malloc (size);
787 else
788 val = (POINTER_TYPE *) realloc (block, size);
789 MALLOC_UNBLOCK_INPUT;
791 if (!val && size) memory_full ();
792 return val;
796 /* Like free but block interrupt input. */
798 void
799 xfree (block)
800 POINTER_TYPE *block;
802 MALLOC_BLOCK_INPUT;
803 free (block);
804 MALLOC_UNBLOCK_INPUT;
805 /* We don't call refill_memory_reserve here
806 because that duplicates doing so in emacs_blocked_free
807 and the criterion should go there. */
811 /* Like strdup, but uses xmalloc. */
813 char *
814 xstrdup (s)
815 const char *s;
817 size_t len = strlen (s) + 1;
818 char *p = (char *) xmalloc (len);
819 bcopy (s, p, len);
820 return p;
824 /* Unwind for SAFE_ALLOCA */
826 Lisp_Object
827 safe_alloca_unwind (arg)
828 Lisp_Object arg;
830 register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
832 p->dogc = 0;
833 xfree (p->pointer);
834 p->pointer = 0;
835 free_misc (arg);
836 return Qnil;
840 /* Like malloc but used for allocating Lisp data. NBYTES is the
841 number of bytes to allocate, TYPE describes the intended use of the
842 allcated memory block (for strings, for conses, ...). */
844 #ifndef USE_LSB_TAG
845 static void *lisp_malloc_loser;
846 #endif
848 static POINTER_TYPE *
849 lisp_malloc (nbytes, type)
850 size_t nbytes;
851 enum mem_type type;
853 register void *val;
855 MALLOC_BLOCK_INPUT;
857 #ifdef GC_MALLOC_CHECK
858 allocated_mem_type = type;
859 #endif
861 val = (void *) malloc (nbytes);
863 #ifndef USE_LSB_TAG
864 /* If the memory just allocated cannot be addressed thru a Lisp
865 object's pointer, and it needs to be,
866 that's equivalent to running out of memory. */
867 if (val && type != MEM_TYPE_NON_LISP)
869 Lisp_Object tem;
870 XSETCONS (tem, (char *) val + nbytes - 1);
871 if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
873 lisp_malloc_loser = val;
874 free (val);
875 val = 0;
878 #endif
880 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
881 if (val && type != MEM_TYPE_NON_LISP)
882 mem_insert (val, (char *) val + nbytes, type);
883 #endif
885 MALLOC_UNBLOCK_INPUT;
886 if (!val && nbytes)
887 memory_full ();
888 return val;
891 /* Free BLOCK. This must be called to free memory allocated with a
892 call to lisp_malloc. */
894 static void
895 lisp_free (block)
896 POINTER_TYPE *block;
898 MALLOC_BLOCK_INPUT;
899 free (block);
900 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
901 mem_delete (mem_find (block));
902 #endif
903 MALLOC_UNBLOCK_INPUT;
906 /* Allocation of aligned blocks of memory to store Lisp data. */
907 /* The entry point is lisp_align_malloc which returns blocks of at most */
908 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
910 /* Use posix_memalloc if the system has it and we're using the system's
911 malloc (because our gmalloc.c routines don't have posix_memalign although
912 its memalloc could be used). */
913 #if defined (HAVE_POSIX_MEMALIGN) && defined (SYSTEM_MALLOC)
914 #define USE_POSIX_MEMALIGN 1
915 #endif
917 /* BLOCK_ALIGN has to be a power of 2. */
918 #define BLOCK_ALIGN (1 << 10)
920 /* Padding to leave at the end of a malloc'd block. This is to give
921 malloc a chance to minimize the amount of memory wasted to alignment.
922 It should be tuned to the particular malloc library used.
923 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
924 posix_memalign on the other hand would ideally prefer a value of 4
925 because otherwise, there's 1020 bytes wasted between each ablocks.
926 In Emacs, testing shows that those 1020 can most of the time be
927 efficiently used by malloc to place other objects, so a value of 0 can
928 still preferable unless you have a lot of aligned blocks and virtually
929 nothing else. */
930 #define BLOCK_PADDING 0
931 #define BLOCK_BYTES \
932 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
934 /* Internal data structures and constants. */
936 #define ABLOCKS_SIZE 16
938 /* An aligned block of memory. */
939 struct ablock
941 union
943 char payload[BLOCK_BYTES];
944 struct ablock *next_free;
945 } x;
946 /* `abase' is the aligned base of the ablocks. */
947 /* It is overloaded to hold the virtual `busy' field that counts
948 the number of used ablock in the parent ablocks.
949 The first ablock has the `busy' field, the others have the `abase'
950 field. To tell the difference, we assume that pointers will have
951 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
952 is used to tell whether the real base of the parent ablocks is `abase'
953 (if not, the word before the first ablock holds a pointer to the
954 real base). */
955 struct ablocks *abase;
956 /* The padding of all but the last ablock is unused. The padding of
957 the last ablock in an ablocks is not allocated. */
958 #if BLOCK_PADDING
959 char padding[BLOCK_PADDING];
960 #endif
963 /* A bunch of consecutive aligned blocks. */
964 struct ablocks
966 struct ablock blocks[ABLOCKS_SIZE];
969 /* Size of the block requested from malloc or memalign. */
970 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
972 #define ABLOCK_ABASE(block) \
973 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
974 ? (struct ablocks *)(block) \
975 : (block)->abase)
977 /* Virtual `busy' field. */
978 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
980 /* Pointer to the (not necessarily aligned) malloc block. */
981 #ifdef USE_POSIX_MEMALIGN
982 #define ABLOCKS_BASE(abase) (abase)
983 #else
984 #define ABLOCKS_BASE(abase) \
985 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
986 #endif
988 /* The list of free ablock. */
989 static struct ablock *free_ablock;
991 /* Allocate an aligned block of nbytes.
992 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
993 smaller or equal to BLOCK_BYTES. */
994 static POINTER_TYPE *
995 lisp_align_malloc (nbytes, type)
996 size_t nbytes;
997 enum mem_type type;
999 void *base, *val;
1000 struct ablocks *abase;
1002 eassert (nbytes <= BLOCK_BYTES);
1004 MALLOC_BLOCK_INPUT;
1006 #ifdef GC_MALLOC_CHECK
1007 allocated_mem_type = type;
1008 #endif
1010 if (!free_ablock)
1012 int i;
1013 EMACS_INT aligned; /* int gets warning casting to 64-bit pointer. */
1015 #ifdef DOUG_LEA_MALLOC
1016 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1017 because mapped region contents are not preserved in
1018 a dumped Emacs. */
1019 mallopt (M_MMAP_MAX, 0);
1020 #endif
1022 #ifdef USE_POSIX_MEMALIGN
1024 int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
1025 if (err)
1026 base = NULL;
1027 abase = base;
1029 #else
1030 base = malloc (ABLOCKS_BYTES);
1031 abase = ALIGN (base, BLOCK_ALIGN);
1032 #endif
1034 if (base == 0)
1036 MALLOC_UNBLOCK_INPUT;
1037 memory_full ();
1040 aligned = (base == abase);
1041 if (!aligned)
1042 ((void**)abase)[-1] = base;
1044 #ifdef DOUG_LEA_MALLOC
1045 /* Back to a reasonable maximum of mmap'ed areas. */
1046 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1047 #endif
1049 #ifndef USE_LSB_TAG
1050 /* If the memory just allocated cannot be addressed thru a Lisp
1051 object's pointer, and it needs to be, that's equivalent to
1052 running out of memory. */
1053 if (type != MEM_TYPE_NON_LISP)
1055 Lisp_Object tem;
1056 char *end = (char *) base + ABLOCKS_BYTES - 1;
1057 XSETCONS (tem, end);
1058 if ((char *) XCONS (tem) != end)
1060 lisp_malloc_loser = base;
1061 free (base);
1062 MALLOC_UNBLOCK_INPUT;
1063 memory_full ();
1066 #endif
1068 /* Initialize the blocks and put them on the free list.
1069 Is `base' was not properly aligned, we can't use the last block. */
1070 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
1072 abase->blocks[i].abase = abase;
1073 abase->blocks[i].x.next_free = free_ablock;
1074 free_ablock = &abase->blocks[i];
1076 ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
1078 eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
1079 eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
1080 eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
1081 eassert (ABLOCKS_BASE (abase) == base);
1082 eassert (aligned == (long) ABLOCKS_BUSY (abase));
1085 abase = ABLOCK_ABASE (free_ablock);
1086 ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) ABLOCKS_BUSY (abase));
1087 val = free_ablock;
1088 free_ablock = free_ablock->x.next_free;
1090 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1091 if (val && type != MEM_TYPE_NON_LISP)
1092 mem_insert (val, (char *) val + nbytes, type);
1093 #endif
1095 MALLOC_UNBLOCK_INPUT;
1096 if (!val && nbytes)
1097 memory_full ();
1099 eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
1100 return val;
1103 static void
1104 lisp_align_free (block)
1105 POINTER_TYPE *block;
1107 struct ablock *ablock = block;
1108 struct ablocks *abase = ABLOCK_ABASE (ablock);
1110 MALLOC_BLOCK_INPUT;
1111 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
1112 mem_delete (mem_find (block));
1113 #endif
1114 /* Put on free list. */
1115 ablock->x.next_free = free_ablock;
1116 free_ablock = ablock;
1117 /* Update busy count. */
1118 ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
1120 if (2 > (long) ABLOCKS_BUSY (abase))
1121 { /* All the blocks are free. */
1122 int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
1123 struct ablock **tem = &free_ablock;
1124 struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
1126 while (*tem)
1128 if (*tem >= (struct ablock *) abase && *tem < atop)
1130 i++;
1131 *tem = (*tem)->x.next_free;
1133 else
1134 tem = &(*tem)->x.next_free;
1136 eassert ((aligned & 1) == aligned);
1137 eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
1138 #ifdef USE_POSIX_MEMALIGN
1139 eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
1140 #endif
1141 free (ABLOCKS_BASE (abase));
1143 MALLOC_UNBLOCK_INPUT;
1146 /* Return a new buffer structure allocated from the heap with
1147 a call to lisp_malloc. */
1149 struct buffer *
1150 allocate_buffer ()
1152 struct buffer *b
1153 = (struct buffer *) lisp_malloc (sizeof (struct buffer),
1154 MEM_TYPE_BUFFER);
1155 b->size = sizeof (struct buffer) / sizeof (EMACS_INT);
1156 XSETPVECTYPE (b, PVEC_BUFFER);
1157 return b;
1161 #ifndef SYSTEM_MALLOC
1163 /* Arranging to disable input signals while we're in malloc.
1165 This only works with GNU malloc. To help out systems which can't
1166 use GNU malloc, all the calls to malloc, realloc, and free
1167 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
1168 pair; unfortunately, we have no idea what C library functions
1169 might call malloc, so we can't really protect them unless you're
1170 using GNU malloc. Fortunately, most of the major operating systems
1171 can use GNU malloc. */
1173 #ifndef SYNC_INPUT
1174 /* When using SYNC_INPUT, we don't call malloc from a signal handler, so
1175 there's no need to block input around malloc. */
1177 #ifndef DOUG_LEA_MALLOC
1178 extern void * (*__malloc_hook) P_ ((size_t, const void *));
1179 extern void * (*__realloc_hook) P_ ((void *, size_t, const void *));
1180 extern void (*__free_hook) P_ ((void *, const void *));
1181 /* Else declared in malloc.h, perhaps with an extra arg. */
1182 #endif /* DOUG_LEA_MALLOC */
1183 static void * (*old_malloc_hook) P_ ((size_t, const void *));
1184 static void * (*old_realloc_hook) P_ ((void *, size_t, const void*));
1185 static void (*old_free_hook) P_ ((void*, const void*));
1187 /* This function is used as the hook for free to call. */
1189 static void
1190 emacs_blocked_free (ptr, ptr2)
1191 void *ptr;
1192 const void *ptr2;
1194 BLOCK_INPUT_ALLOC;
1196 #ifdef GC_MALLOC_CHECK
1197 if (ptr)
1199 struct mem_node *m;
1201 m = mem_find (ptr);
1202 if (m == MEM_NIL || m->start != ptr)
1204 fprintf (stderr,
1205 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
1206 abort ();
1208 else
1210 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
1211 mem_delete (m);
1214 #endif /* GC_MALLOC_CHECK */
1216 __free_hook = old_free_hook;
1217 free (ptr);
1219 /* If we released our reserve (due to running out of memory),
1220 and we have a fair amount free once again,
1221 try to set aside another reserve in case we run out once more. */
1222 if (! NILP (Vmemory_full)
1223 /* Verify there is enough space that even with the malloc
1224 hysteresis this call won't run out again.
1225 The code here is correct as long as SPARE_MEMORY
1226 is substantially larger than the block size malloc uses. */
1227 && (bytes_used_when_full
1228 > ((bytes_used_when_reconsidered = BYTES_USED)
1229 + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
1230 refill_memory_reserve ();
1232 __free_hook = emacs_blocked_free;
1233 UNBLOCK_INPUT_ALLOC;
1237 /* This function is the malloc hook that Emacs uses. */
1239 static void *
1240 emacs_blocked_malloc (size, ptr)
1241 size_t size;
1242 const void *ptr;
1244 void *value;
1246 BLOCK_INPUT_ALLOC;
1247 __malloc_hook = old_malloc_hook;
1248 #ifdef DOUG_LEA_MALLOC
1249 /* Segfaults on my system. --lorentey */
1250 /* mallopt (M_TOP_PAD, malloc_hysteresis * 4096); */
1251 #else
1252 __malloc_extra_blocks = malloc_hysteresis;
1253 #endif
1255 value = (void *) malloc (size);
1257 #ifdef GC_MALLOC_CHECK
1259 struct mem_node *m = mem_find (value);
1260 if (m != MEM_NIL)
1262 fprintf (stderr, "Malloc returned %p which is already in use\n",
1263 value);
1264 fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
1265 m->start, m->end, (char *) m->end - (char *) m->start,
1266 m->type);
1267 abort ();
1270 if (!dont_register_blocks)
1272 mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
1273 allocated_mem_type = MEM_TYPE_NON_LISP;
1276 #endif /* GC_MALLOC_CHECK */
1278 __malloc_hook = emacs_blocked_malloc;
1279 UNBLOCK_INPUT_ALLOC;
1281 /* fprintf (stderr, "%p malloc\n", value); */
1282 return value;
1286 /* This function is the realloc hook that Emacs uses. */
1288 static void *
1289 emacs_blocked_realloc (ptr, size, ptr2)
1290 void *ptr;
1291 size_t size;
1292 const void *ptr2;
1294 void *value;
1296 BLOCK_INPUT_ALLOC;
1297 __realloc_hook = old_realloc_hook;
1299 #ifdef GC_MALLOC_CHECK
1300 if (ptr)
1302 struct mem_node *m = mem_find (ptr);
1303 if (m == MEM_NIL || m->start != ptr)
1305 fprintf (stderr,
1306 "Realloc of %p which wasn't allocated with malloc\n",
1307 ptr);
1308 abort ();
1311 mem_delete (m);
1314 /* fprintf (stderr, "%p -> realloc\n", ptr); */
1316 /* Prevent malloc from registering blocks. */
1317 dont_register_blocks = 1;
1318 #endif /* GC_MALLOC_CHECK */
1320 value = (void *) realloc (ptr, size);
1322 #ifdef GC_MALLOC_CHECK
1323 dont_register_blocks = 0;
1326 struct mem_node *m = mem_find (value);
1327 if (m != MEM_NIL)
1329 fprintf (stderr, "Realloc returns memory that is already in use\n");
1330 abort ();
1333 /* Can't handle zero size regions in the red-black tree. */
1334 mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
1337 /* fprintf (stderr, "%p <- realloc\n", value); */
1338 #endif /* GC_MALLOC_CHECK */
1340 __realloc_hook = emacs_blocked_realloc;
1341 UNBLOCK_INPUT_ALLOC;
1343 return value;
1347 #ifdef HAVE_GTK_AND_PTHREAD
1348 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
1349 normal malloc. Some thread implementations need this as they call
1350 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
1351 calls malloc because it is the first call, and we have an endless loop. */
1353 void
1354 reset_malloc_hooks ()
1356 __free_hook = old_free_hook;
1357 __malloc_hook = old_malloc_hook;
1358 __realloc_hook = old_realloc_hook;
1360 #endif /* HAVE_GTK_AND_PTHREAD */
1363 /* Called from main to set up malloc to use our hooks. */
1365 void
1366 uninterrupt_malloc ()
1368 #ifdef HAVE_GTK_AND_PTHREAD
1369 pthread_mutexattr_t attr;
1371 /* GLIBC has a faster way to do this, but lets keep it portable.
1372 This is according to the Single UNIX Specification. */
1373 pthread_mutexattr_init (&attr);
1374 pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
1375 pthread_mutex_init (&alloc_mutex, &attr);
1376 #endif /* HAVE_GTK_AND_PTHREAD */
1378 if (__free_hook != emacs_blocked_free)
1379 old_free_hook = __free_hook;
1380 __free_hook = emacs_blocked_free;
1382 if (__malloc_hook != emacs_blocked_malloc)
1383 old_malloc_hook = __malloc_hook;
1384 __malloc_hook = emacs_blocked_malloc;
1386 if (__realloc_hook != emacs_blocked_realloc)
1387 old_realloc_hook = __realloc_hook;
1388 __realloc_hook = emacs_blocked_realloc;
1391 #endif /* not SYNC_INPUT */
1392 #endif /* not SYSTEM_MALLOC */
1396 /***********************************************************************
1397 Interval Allocation
1398 ***********************************************************************/
1400 /* Number of intervals allocated in an interval_block structure.
1401 The 1020 is 1024 minus malloc overhead. */
1403 #define INTERVAL_BLOCK_SIZE \
1404 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
1406 /* Intervals are allocated in chunks in form of an interval_block
1407 structure. */
1409 struct interval_block
1411 /* Place `intervals' first, to preserve alignment. */
1412 struct interval intervals[INTERVAL_BLOCK_SIZE];
1413 struct interval_block *next;
1416 /* Current interval block. Its `next' pointer points to older
1417 blocks. */
1419 static struct interval_block *interval_block;
1421 /* Index in interval_block above of the next unused interval
1422 structure. */
1424 static int interval_block_index;
1426 /* Number of free and live intervals. */
1428 static int total_free_intervals, total_intervals;
1430 /* List of free intervals. */
1432 INTERVAL interval_free_list;
1434 /* Total number of interval blocks now in use. */
1436 static int n_interval_blocks;
1439 /* Initialize interval allocation. */
1441 static void
1442 init_intervals ()
1444 interval_block = NULL;
1445 interval_block_index = INTERVAL_BLOCK_SIZE;
1446 interval_free_list = 0;
1447 n_interval_blocks = 0;
1451 /* Return a new interval. */
1453 INTERVAL
1454 make_interval ()
1456 INTERVAL val;
1458 /* eassert (!handling_signal); */
1460 MALLOC_BLOCK_INPUT;
1462 if (interval_free_list)
1464 val = interval_free_list;
1465 interval_free_list = INTERVAL_PARENT (interval_free_list);
1467 else
1469 if (interval_block_index == INTERVAL_BLOCK_SIZE)
1471 register struct interval_block *newi;
1473 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
1474 MEM_TYPE_NON_LISP);
1476 newi->next = interval_block;
1477 interval_block = newi;
1478 interval_block_index = 0;
1479 n_interval_blocks++;
1481 val = &interval_block->intervals[interval_block_index++];
1484 MALLOC_UNBLOCK_INPUT;
1486 consing_since_gc += sizeof (struct interval);
1487 intervals_consed++;
1488 RESET_INTERVAL (val);
1489 val->gcmarkbit = 0;
1490 return val;
1494 /* Mark Lisp objects in interval I. */
1496 static void
1497 mark_interval (i, dummy)
1498 register INTERVAL i;
1499 Lisp_Object dummy;
1501 eassert (!i->gcmarkbit); /* Intervals are never shared. */
1502 i->gcmarkbit = 1;
1503 mark_object (i->plist);
1507 /* Mark the interval tree rooted in TREE. Don't call this directly;
1508 use the macro MARK_INTERVAL_TREE instead. */
1510 static void
1511 mark_interval_tree (tree)
1512 register INTERVAL tree;
1514 /* No need to test if this tree has been marked already; this
1515 function is always called through the MARK_INTERVAL_TREE macro,
1516 which takes care of that. */
1518 traverse_intervals_noorder (tree, mark_interval, Qnil);
1522 /* Mark the interval tree rooted in I. */
1524 #define MARK_INTERVAL_TREE(i) \
1525 do { \
1526 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
1527 mark_interval_tree (i); \
1528 } while (0)
1531 #define UNMARK_BALANCE_INTERVALS(i) \
1532 do { \
1533 if (! NULL_INTERVAL_P (i)) \
1534 (i) = balance_intervals (i); \
1535 } while (0)
1538 /* Number support. If NO_UNION_TYPE isn't in effect, we
1539 can't create number objects in macros. */
1540 #ifndef make_number
1541 Lisp_Object
1542 make_number (n)
1543 EMACS_INT n;
1545 Lisp_Object obj;
1546 obj.s.val = n;
1547 obj.s.type = Lisp_Int;
1548 return obj;
1550 #endif
1552 /***********************************************************************
1553 String Allocation
1554 ***********************************************************************/
1556 /* Lisp_Strings are allocated in string_block structures. When a new
1557 string_block is allocated, all the Lisp_Strings it contains are
1558 added to a free-list string_free_list. When a new Lisp_String is
1559 needed, it is taken from that list. During the sweep phase of GC,
1560 string_blocks that are entirely free are freed, except two which
1561 we keep.
1563 String data is allocated from sblock structures. Strings larger
1564 than LARGE_STRING_BYTES, get their own sblock, data for smaller
1565 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
1567 Sblocks consist internally of sdata structures, one for each
1568 Lisp_String. The sdata structure points to the Lisp_String it
1569 belongs to. The Lisp_String points back to the `u.data' member of
1570 its sdata structure.
1572 When a Lisp_String is freed during GC, it is put back on
1573 string_free_list, and its `data' member and its sdata's `string'
1574 pointer is set to null. The size of the string is recorded in the
1575 `u.nbytes' member of the sdata. So, sdata structures that are no
1576 longer used, can be easily recognized, and it's easy to compact the
1577 sblocks of small strings which we do in compact_small_strings. */
1579 /* Size in bytes of an sblock structure used for small strings. This
1580 is 8192 minus malloc overhead. */
1582 #define SBLOCK_SIZE 8188
1584 /* Strings larger than this are considered large strings. String data
1585 for large strings is allocated from individual sblocks. */
1587 #define LARGE_STRING_BYTES 1024
1589 /* Structure describing string memory sub-allocated from an sblock.
1590 This is where the contents of Lisp strings are stored. */
1592 struct sdata
1594 /* Back-pointer to the string this sdata belongs to. If null, this
1595 structure is free, and the NBYTES member of the union below
1596 contains the string's byte size (the same value that STRING_BYTES
1597 would return if STRING were non-null). If non-null, STRING_BYTES
1598 (STRING) is the size of the data, and DATA contains the string's
1599 contents. */
1600 struct Lisp_String *string;
1602 #ifdef GC_CHECK_STRING_BYTES
1604 EMACS_INT nbytes;
1605 unsigned char data[1];
1607 #define SDATA_NBYTES(S) (S)->nbytes
1608 #define SDATA_DATA(S) (S)->data
1610 #else /* not GC_CHECK_STRING_BYTES */
1612 union
1614 /* When STRING in non-null. */
1615 unsigned char data[1];
1617 /* When STRING is null. */
1618 EMACS_INT nbytes;
1619 } u;
1622 #define SDATA_NBYTES(S) (S)->u.nbytes
1623 #define SDATA_DATA(S) (S)->u.data
1625 #endif /* not GC_CHECK_STRING_BYTES */
1629 /* Structure describing a block of memory which is sub-allocated to
1630 obtain string data memory for strings. Blocks for small strings
1631 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
1632 as large as needed. */
1634 struct sblock
1636 /* Next in list. */
1637 struct sblock *next;
1639 /* Pointer to the next free sdata block. This points past the end
1640 of the sblock if there isn't any space left in this block. */
1641 struct sdata *next_free;
1643 /* Start of data. */
1644 struct sdata first_data;
1647 /* Number of Lisp strings in a string_block structure. The 1020 is
1648 1024 minus malloc overhead. */
1650 #define STRING_BLOCK_SIZE \
1651 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
1653 /* Structure describing a block from which Lisp_String structures
1654 are allocated. */
1656 struct string_block
1658 /* Place `strings' first, to preserve alignment. */
1659 struct Lisp_String strings[STRING_BLOCK_SIZE];
1660 struct string_block *next;
1663 /* Head and tail of the list of sblock structures holding Lisp string
1664 data. We always allocate from current_sblock. The NEXT pointers
1665 in the sblock structures go from oldest_sblock to current_sblock. */
1667 static struct sblock *oldest_sblock, *current_sblock;
1669 /* List of sblocks for large strings. */
1671 static struct sblock *large_sblocks;
1673 /* List of string_block structures, and how many there are. */
1675 static struct string_block *string_blocks;
1676 static int n_string_blocks;
1678 /* Free-list of Lisp_Strings. */
1680 static struct Lisp_String *string_free_list;
1682 /* Number of live and free Lisp_Strings. */
1684 static int total_strings, total_free_strings;
1686 /* Number of bytes used by live strings. */
1688 static int total_string_size;
1690 /* Given a pointer to a Lisp_String S which is on the free-list
1691 string_free_list, return a pointer to its successor in the
1692 free-list. */
1694 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
1696 /* Return a pointer to the sdata structure belonging to Lisp string S.
1697 S must be live, i.e. S->data must not be null. S->data is actually
1698 a pointer to the `u.data' member of its sdata structure; the
1699 structure starts at a constant offset in front of that. */
1701 #ifdef GC_CHECK_STRING_BYTES
1703 #define SDATA_OF_STRING(S) \
1704 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
1705 - sizeof (EMACS_INT)))
1707 #else /* not GC_CHECK_STRING_BYTES */
1709 #define SDATA_OF_STRING(S) \
1710 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
1712 #endif /* not GC_CHECK_STRING_BYTES */
1715 #ifdef GC_CHECK_STRING_OVERRUN
1717 /* We check for overrun in string data blocks by appending a small
1718 "cookie" after each allocated string data block, and check for the
1719 presence of this cookie during GC. */
1721 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
1722 static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
1723 { 0xde, 0xad, 0xbe, 0xef };
1725 #else
1726 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
1727 #endif
1729 /* Value is the size of an sdata structure large enough to hold NBYTES
1730 bytes of string data. The value returned includes a terminating
1731 NUL byte, the size of the sdata structure, and padding. */
1733 #ifdef GC_CHECK_STRING_BYTES
1735 #define SDATA_SIZE(NBYTES) \
1736 ((sizeof (struct Lisp_String *) \
1737 + (NBYTES) + 1 \
1738 + sizeof (EMACS_INT) \
1739 + sizeof (EMACS_INT) - 1) \
1740 & ~(sizeof (EMACS_INT) - 1))
1742 #else /* not GC_CHECK_STRING_BYTES */
1744 #define SDATA_SIZE(NBYTES) \
1745 ((sizeof (struct Lisp_String *) \
1746 + (NBYTES) + 1 \
1747 + sizeof (EMACS_INT) - 1) \
1748 & ~(sizeof (EMACS_INT) - 1))
1750 #endif /* not GC_CHECK_STRING_BYTES */
1752 /* Extra bytes to allocate for each string. */
1754 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
1756 /* Initialize string allocation. Called from init_alloc_once. */
1758 static void
1759 init_strings ()
1761 total_strings = total_free_strings = total_string_size = 0;
1762 oldest_sblock = current_sblock = large_sblocks = NULL;
1763 string_blocks = NULL;
1764 n_string_blocks = 0;
1765 string_free_list = NULL;
1766 empty_unibyte_string = make_pure_string ("", 0, 0, 0);
1767 empty_multibyte_string = make_pure_string ("", 0, 0, 1);
1771 #ifdef GC_CHECK_STRING_BYTES
1773 static int check_string_bytes_count;
1775 static void check_string_bytes P_ ((int));
1776 static void check_sblock P_ ((struct sblock *));
1778 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
1781 /* Like GC_STRING_BYTES, but with debugging check. */
1784 string_bytes (s)
1785 struct Lisp_String *s;
1787 int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
1788 if (!PURE_POINTER_P (s)
1789 && s->data
1790 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
1791 abort ();
1792 return nbytes;
1795 /* Check validity of Lisp strings' string_bytes member in B. */
1797 static void
1798 check_sblock (b)
1799 struct sblock *b;
1801 struct sdata *from, *end, *from_end;
1803 end = b->next_free;
1805 for (from = &b->first_data; from < end; from = from_end)
1807 /* Compute the next FROM here because copying below may
1808 overwrite data we need to compute it. */
1809 int nbytes;
1811 /* Check that the string size recorded in the string is the
1812 same as the one recorded in the sdata structure. */
1813 if (from->string)
1814 CHECK_STRING_BYTES (from->string);
1816 if (from->string)
1817 nbytes = GC_STRING_BYTES (from->string);
1818 else
1819 nbytes = SDATA_NBYTES (from);
1821 nbytes = SDATA_SIZE (nbytes);
1822 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
1827 /* Check validity of Lisp strings' string_bytes member. ALL_P
1828 non-zero means check all strings, otherwise check only most
1829 recently allocated strings. Used for hunting a bug. */
1831 static void
1832 check_string_bytes (all_p)
1833 int all_p;
1835 if (all_p)
1837 struct sblock *b;
1839 for (b = large_sblocks; b; b = b->next)
1841 struct Lisp_String *s = b->first_data.string;
1842 if (s)
1843 CHECK_STRING_BYTES (s);
1846 for (b = oldest_sblock; b; b = b->next)
1847 check_sblock (b);
1849 else
1850 check_sblock (current_sblock);
1853 #endif /* GC_CHECK_STRING_BYTES */
1855 #ifdef GC_CHECK_STRING_FREE_LIST
1857 /* Walk through the string free list looking for bogus next pointers.
1858 This may catch buffer overrun from a previous string. */
1860 static void
1861 check_string_free_list ()
1863 struct Lisp_String *s;
1865 /* Pop a Lisp_String off the free-list. */
1866 s = string_free_list;
1867 while (s != NULL)
1869 if ((unsigned)s < 1024)
1870 abort();
1871 s = NEXT_FREE_LISP_STRING (s);
1874 #else
1875 #define check_string_free_list()
1876 #endif
1878 /* Return a new Lisp_String. */
1880 static struct Lisp_String *
1881 allocate_string ()
1883 struct Lisp_String *s;
1885 /* eassert (!handling_signal); */
1887 MALLOC_BLOCK_INPUT;
1889 /* If the free-list is empty, allocate a new string_block, and
1890 add all the Lisp_Strings in it to the free-list. */
1891 if (string_free_list == NULL)
1893 struct string_block *b;
1894 int i;
1896 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
1897 bzero (b, sizeof *b);
1898 b->next = string_blocks;
1899 string_blocks = b;
1900 ++n_string_blocks;
1902 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
1904 s = b->strings + i;
1905 NEXT_FREE_LISP_STRING (s) = string_free_list;
1906 string_free_list = s;
1909 total_free_strings += STRING_BLOCK_SIZE;
1912 check_string_free_list ();
1914 /* Pop a Lisp_String off the free-list. */
1915 s = string_free_list;
1916 string_free_list = NEXT_FREE_LISP_STRING (s);
1918 MALLOC_UNBLOCK_INPUT;
1920 /* Probably not strictly necessary, but play it safe. */
1921 bzero (s, sizeof *s);
1923 --total_free_strings;
1924 ++total_strings;
1925 ++strings_consed;
1926 consing_since_gc += sizeof *s;
1928 #ifdef GC_CHECK_STRING_BYTES
1929 if (!noninteractive)
1931 if (++check_string_bytes_count == 200)
1933 check_string_bytes_count = 0;
1934 check_string_bytes (1);
1936 else
1937 check_string_bytes (0);
1939 #endif /* GC_CHECK_STRING_BYTES */
1941 return s;
1945 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
1946 plus a NUL byte at the end. Allocate an sdata structure for S, and
1947 set S->data to its `u.data' member. Store a NUL byte at the end of
1948 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
1949 S->data if it was initially non-null. */
1951 void
1952 allocate_string_data (s, nchars, nbytes)
1953 struct Lisp_String *s;
1954 int nchars, nbytes;
1956 struct sdata *data, *old_data;
1957 struct sblock *b;
1958 int needed, old_nbytes;
1960 /* Determine the number of bytes needed to store NBYTES bytes
1961 of string data. */
1962 needed = SDATA_SIZE (nbytes);
1963 old_data = s->data ? SDATA_OF_STRING (s) : NULL;
1964 old_nbytes = GC_STRING_BYTES (s);
1966 MALLOC_BLOCK_INPUT;
1968 if (nbytes > LARGE_STRING_BYTES)
1970 size_t size = sizeof *b - sizeof (struct sdata) + needed;
1972 #ifdef DOUG_LEA_MALLOC
1973 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
1974 because mapped region contents are not preserved in
1975 a dumped Emacs.
1977 In case you think of allowing it in a dumped Emacs at the
1978 cost of not being able to re-dump, there's another reason:
1979 mmap'ed data typically have an address towards the top of the
1980 address space, which won't fit into an EMACS_INT (at least on
1981 32-bit systems with the current tagging scheme). --fx */
1982 mallopt (M_MMAP_MAX, 0);
1983 #endif
1985 b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
1987 #ifdef DOUG_LEA_MALLOC
1988 /* Back to a reasonable maximum of mmap'ed areas. */
1989 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
1990 #endif
1992 b->next_free = &b->first_data;
1993 b->first_data.string = NULL;
1994 b->next = large_sblocks;
1995 large_sblocks = b;
1997 else if (current_sblock == NULL
1998 || (((char *) current_sblock + SBLOCK_SIZE
1999 - (char *) current_sblock->next_free)
2000 < (needed + GC_STRING_EXTRA)))
2002 /* Not enough room in the current sblock. */
2003 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
2004 b->next_free = &b->first_data;
2005 b->first_data.string = NULL;
2006 b->next = NULL;
2008 if (current_sblock)
2009 current_sblock->next = b;
2010 else
2011 oldest_sblock = b;
2012 current_sblock = b;
2014 else
2015 b = current_sblock;
2017 data = b->next_free;
2018 b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
2020 MALLOC_UNBLOCK_INPUT;
2022 data->string = s;
2023 s->data = SDATA_DATA (data);
2024 #ifdef GC_CHECK_STRING_BYTES
2025 SDATA_NBYTES (data) = nbytes;
2026 #endif
2027 s->size = nchars;
2028 s->size_byte = nbytes;
2029 s->data[nbytes] = '\0';
2030 #ifdef GC_CHECK_STRING_OVERRUN
2031 bcopy (string_overrun_cookie, (char *) data + needed,
2032 GC_STRING_OVERRUN_COOKIE_SIZE);
2033 #endif
2035 /* If S had already data assigned, mark that as free by setting its
2036 string back-pointer to null, and recording the size of the data
2037 in it. */
2038 if (old_data)
2040 SDATA_NBYTES (old_data) = old_nbytes;
2041 old_data->string = NULL;
2044 consing_since_gc += needed;
2048 /* Sweep and compact strings. */
2050 static void
2051 sweep_strings ()
2053 struct string_block *b, *next;
2054 struct string_block *live_blocks = NULL;
2056 string_free_list = NULL;
2057 total_strings = total_free_strings = 0;
2058 total_string_size = 0;
2060 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
2061 for (b = string_blocks; b; b = next)
2063 int i, nfree = 0;
2064 struct Lisp_String *free_list_before = string_free_list;
2066 next = b->next;
2068 for (i = 0; i < STRING_BLOCK_SIZE; ++i)
2070 struct Lisp_String *s = b->strings + i;
2072 if (s->data)
2074 /* String was not on free-list before. */
2075 if (STRING_MARKED_P (s))
2077 /* String is live; unmark it and its intervals. */
2078 UNMARK_STRING (s);
2080 if (!NULL_INTERVAL_P (s->intervals))
2081 UNMARK_BALANCE_INTERVALS (s->intervals);
2083 ++total_strings;
2084 total_string_size += STRING_BYTES (s);
2086 else
2088 /* String is dead. Put it on the free-list. */
2089 struct sdata *data = SDATA_OF_STRING (s);
2091 /* Save the size of S in its sdata so that we know
2092 how large that is. Reset the sdata's string
2093 back-pointer so that we know it's free. */
2094 #ifdef GC_CHECK_STRING_BYTES
2095 if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
2096 abort ();
2097 #else
2098 data->u.nbytes = GC_STRING_BYTES (s);
2099 #endif
2100 data->string = NULL;
2102 /* Reset the strings's `data' member so that we
2103 know it's free. */
2104 s->data = NULL;
2106 /* Put the string on the free-list. */
2107 NEXT_FREE_LISP_STRING (s) = string_free_list;
2108 string_free_list = s;
2109 ++nfree;
2112 else
2114 /* S was on the free-list before. Put it there again. */
2115 NEXT_FREE_LISP_STRING (s) = string_free_list;
2116 string_free_list = s;
2117 ++nfree;
2121 /* Free blocks that contain free Lisp_Strings only, except
2122 the first two of them. */
2123 if (nfree == STRING_BLOCK_SIZE
2124 && total_free_strings > STRING_BLOCK_SIZE)
2126 lisp_free (b);
2127 --n_string_blocks;
2128 string_free_list = free_list_before;
2130 else
2132 total_free_strings += nfree;
2133 b->next = live_blocks;
2134 live_blocks = b;
2138 check_string_free_list ();
2140 string_blocks = live_blocks;
2141 free_large_strings ();
2142 compact_small_strings ();
2144 check_string_free_list ();
2148 /* Free dead large strings. */
2150 static void
2151 free_large_strings ()
2153 struct sblock *b, *next;
2154 struct sblock *live_blocks = NULL;
2156 for (b = large_sblocks; b; b = next)
2158 next = b->next;
2160 if (b->first_data.string == NULL)
2161 lisp_free (b);
2162 else
2164 b->next = live_blocks;
2165 live_blocks = b;
2169 large_sblocks = live_blocks;
2173 /* Compact data of small strings. Free sblocks that don't contain
2174 data of live strings after compaction. */
2176 static void
2177 compact_small_strings ()
2179 struct sblock *b, *tb, *next;
2180 struct sdata *from, *to, *end, *tb_end;
2181 struct sdata *to_end, *from_end;
2183 /* TB is the sblock we copy to, TO is the sdata within TB we copy
2184 to, and TB_END is the end of TB. */
2185 tb = oldest_sblock;
2186 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2187 to = &tb->first_data;
2189 /* Step through the blocks from the oldest to the youngest. We
2190 expect that old blocks will stabilize over time, so that less
2191 copying will happen this way. */
2192 for (b = oldest_sblock; b; b = b->next)
2194 end = b->next_free;
2195 xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
2197 for (from = &b->first_data; from < end; from = from_end)
2199 /* Compute the next FROM here because copying below may
2200 overwrite data we need to compute it. */
2201 int nbytes;
2203 #ifdef GC_CHECK_STRING_BYTES
2204 /* Check that the string size recorded in the string is the
2205 same as the one recorded in the sdata structure. */
2206 if (from->string
2207 && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
2208 abort ();
2209 #endif /* GC_CHECK_STRING_BYTES */
2211 if (from->string)
2212 nbytes = GC_STRING_BYTES (from->string);
2213 else
2214 nbytes = SDATA_NBYTES (from);
2216 if (nbytes > LARGE_STRING_BYTES)
2217 abort ();
2219 nbytes = SDATA_SIZE (nbytes);
2220 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
2222 #ifdef GC_CHECK_STRING_OVERRUN
2223 if (bcmp (string_overrun_cookie,
2224 ((char *) from_end) - GC_STRING_OVERRUN_COOKIE_SIZE,
2225 GC_STRING_OVERRUN_COOKIE_SIZE))
2226 abort ();
2227 #endif
2229 /* FROM->string non-null means it's alive. Copy its data. */
2230 if (from->string)
2232 /* If TB is full, proceed with the next sblock. */
2233 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2234 if (to_end > tb_end)
2236 tb->next_free = to;
2237 tb = tb->next;
2238 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
2239 to = &tb->first_data;
2240 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
2243 /* Copy, and update the string's `data' pointer. */
2244 if (from != to)
2246 xassert (tb != b || to <= from);
2247 safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
2248 to->string->data = SDATA_DATA (to);
2251 /* Advance past the sdata we copied to. */
2252 to = to_end;
2257 /* The rest of the sblocks following TB don't contain live data, so
2258 we can free them. */
2259 for (b = tb->next; b; b = next)
2261 next = b->next;
2262 lisp_free (b);
2265 tb->next_free = to;
2266 tb->next = NULL;
2267 current_sblock = tb;
2271 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
2272 doc: /* Return a newly created string of length LENGTH, with INIT in each element.
2273 LENGTH must be an integer.
2274 INIT must be an integer that represents a character. */)
2275 (length, init)
2276 Lisp_Object length, init;
2278 register Lisp_Object val;
2279 register unsigned char *p, *end;
2280 int c, nbytes;
2282 CHECK_NATNUM (length);
2283 CHECK_NUMBER (init);
2285 c = XINT (init);
2286 if (ASCII_CHAR_P (c))
2288 nbytes = XINT (length);
2289 val = make_uninit_string (nbytes);
2290 p = SDATA (val);
2291 end = p + SCHARS (val);
2292 while (p != end)
2293 *p++ = c;
2295 else
2297 unsigned char str[MAX_MULTIBYTE_LENGTH];
2298 int len = CHAR_STRING (c, str);
2300 nbytes = len * XINT (length);
2301 val = make_uninit_multibyte_string (XINT (length), nbytes);
2302 p = SDATA (val);
2303 end = p + nbytes;
2304 while (p != end)
2306 bcopy (str, p, len);
2307 p += len;
2311 *p = 0;
2312 return val;
2316 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
2317 doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
2318 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
2319 (length, init)
2320 Lisp_Object length, init;
2322 register Lisp_Object val;
2323 struct Lisp_Bool_Vector *p;
2324 int real_init, i;
2325 int length_in_chars, length_in_elts, bits_per_value;
2327 CHECK_NATNUM (length);
2329 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
2331 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
2332 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
2333 / BOOL_VECTOR_BITS_PER_CHAR);
2335 /* We must allocate one more elements than LENGTH_IN_ELTS for the
2336 slot `size' of the struct Lisp_Bool_Vector. */
2337 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
2339 /* Get rid of any bits that would cause confusion. */
2340 XVECTOR (val)->size = 0; /* No Lisp_Object to trace in there. */
2341 /* Use XVECTOR (val) rather than `p' because p->size is not TRT. */
2342 XSETPVECTYPE (XVECTOR (val), PVEC_BOOL_VECTOR);
2344 p = XBOOL_VECTOR (val);
2345 p->size = XFASTINT (length);
2347 real_init = (NILP (init) ? 0 : -1);
2348 for (i = 0; i < length_in_chars ; i++)
2349 p->data[i] = real_init;
2351 /* Clear the extraneous bits in the last byte. */
2352 if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
2353 p->data[length_in_chars - 1]
2354 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
2356 return val;
2360 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
2361 of characters from the contents. This string may be unibyte or
2362 multibyte, depending on the contents. */
2364 Lisp_Object
2365 make_string (contents, nbytes)
2366 const char *contents;
2367 int nbytes;
2369 register Lisp_Object val;
2370 int nchars, multibyte_nbytes;
2372 parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
2373 if (nbytes == nchars || nbytes != multibyte_nbytes)
2374 /* CONTENTS contains no multibyte sequences or contains an invalid
2375 multibyte sequence. We must make unibyte string. */
2376 val = make_unibyte_string (contents, nbytes);
2377 else
2378 val = make_multibyte_string (contents, nchars, nbytes);
2379 return val;
2383 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
2385 Lisp_Object
2386 make_unibyte_string (contents, length)
2387 const char *contents;
2388 int length;
2390 register Lisp_Object val;
2391 val = make_uninit_string (length);
2392 bcopy (contents, SDATA (val), length);
2393 STRING_SET_UNIBYTE (val);
2394 return val;
2398 /* Make a multibyte string from NCHARS characters occupying NBYTES
2399 bytes at CONTENTS. */
2401 Lisp_Object
2402 make_multibyte_string (contents, nchars, nbytes)
2403 const char *contents;
2404 int nchars, nbytes;
2406 register Lisp_Object val;
2407 val = make_uninit_multibyte_string (nchars, nbytes);
2408 bcopy (contents, SDATA (val), nbytes);
2409 return val;
2413 /* Make a string from NCHARS characters occupying NBYTES bytes at
2414 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
2416 Lisp_Object
2417 make_string_from_bytes (contents, nchars, nbytes)
2418 const char *contents;
2419 int nchars, nbytes;
2421 register Lisp_Object val;
2422 val = make_uninit_multibyte_string (nchars, nbytes);
2423 bcopy (contents, SDATA (val), nbytes);
2424 if (SBYTES (val) == SCHARS (val))
2425 STRING_SET_UNIBYTE (val);
2426 return val;
2430 /* Make a string from NCHARS characters occupying NBYTES bytes at
2431 CONTENTS. The argument MULTIBYTE controls whether to label the
2432 string as multibyte. If NCHARS is negative, it counts the number of
2433 characters by itself. */
2435 Lisp_Object
2436 make_specified_string (contents, nchars, nbytes, multibyte)
2437 const char *contents;
2438 int nchars, nbytes;
2439 int multibyte;
2441 register Lisp_Object val;
2443 if (nchars < 0)
2445 if (multibyte)
2446 nchars = multibyte_chars_in_text (contents, nbytes);
2447 else
2448 nchars = nbytes;
2450 val = make_uninit_multibyte_string (nchars, nbytes);
2451 bcopy (contents, SDATA (val), nbytes);
2452 if (!multibyte)
2453 STRING_SET_UNIBYTE (val);
2454 return val;
2458 /* Make a string from the data at STR, treating it as multibyte if the
2459 data warrants. */
2461 Lisp_Object
2462 build_string (str)
2463 const char *str;
2465 return make_string (str, strlen (str));
2469 /* Return an unibyte Lisp_String set up to hold LENGTH characters
2470 occupying LENGTH bytes. */
2472 Lisp_Object
2473 make_uninit_string (length)
2474 int length;
2476 Lisp_Object val;
2478 if (!length)
2479 return empty_unibyte_string;
2480 val = make_uninit_multibyte_string (length, length);
2481 STRING_SET_UNIBYTE (val);
2482 return val;
2486 /* Return a multibyte Lisp_String set up to hold NCHARS characters
2487 which occupy NBYTES bytes. */
2489 Lisp_Object
2490 make_uninit_multibyte_string (nchars, nbytes)
2491 int nchars, nbytes;
2493 Lisp_Object string;
2494 struct Lisp_String *s;
2496 if (nchars < 0)
2497 abort ();
2498 if (!nbytes)
2499 return empty_multibyte_string;
2501 s = allocate_string ();
2502 allocate_string_data (s, nchars, nbytes);
2503 XSETSTRING (string, s);
2504 string_chars_consed += nbytes;
2505 return string;
2510 /***********************************************************************
2511 Float Allocation
2512 ***********************************************************************/
2514 /* We store float cells inside of float_blocks, allocating a new
2515 float_block with malloc whenever necessary. Float cells reclaimed
2516 by GC are put on a free list to be reallocated before allocating
2517 any new float cells from the latest float_block. */
2519 #define FLOAT_BLOCK_SIZE \
2520 (((BLOCK_BYTES - sizeof (struct float_block *) \
2521 /* The compiler might add padding at the end. */ \
2522 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
2523 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
2525 #define GETMARKBIT(block,n) \
2526 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2527 >> ((n) % (sizeof(int) * CHAR_BIT))) \
2528 & 1)
2530 #define SETMARKBIT(block,n) \
2531 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2532 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
2534 #define UNSETMARKBIT(block,n) \
2535 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
2536 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
2538 #define FLOAT_BLOCK(fptr) \
2539 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2541 #define FLOAT_INDEX(fptr) \
2542 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
2544 struct float_block
2546 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
2547 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
2548 int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
2549 struct float_block *next;
2552 #define FLOAT_MARKED_P(fptr) \
2553 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2555 #define FLOAT_MARK(fptr) \
2556 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2558 #define FLOAT_UNMARK(fptr) \
2559 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
2561 /* Current float_block. */
2563 struct float_block *float_block;
2565 /* Index of first unused Lisp_Float in the current float_block. */
2567 int float_block_index;
2569 /* Total number of float blocks now in use. */
2571 int n_float_blocks;
2573 /* Free-list of Lisp_Floats. */
2575 struct Lisp_Float *float_free_list;
2578 /* Initialize float allocation. */
2580 static void
2581 init_float ()
2583 float_block = NULL;
2584 float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
2585 float_free_list = 0;
2586 n_float_blocks = 0;
2590 /* Explicitly free a float cell by putting it on the free-list. */
2592 static void
2593 free_float (ptr)
2594 struct Lisp_Float *ptr;
2596 ptr->u.chain = float_free_list;
2597 float_free_list = ptr;
2601 /* Return a new float object with value FLOAT_VALUE. */
2603 Lisp_Object
2604 make_float (float_value)
2605 double float_value;
2607 register Lisp_Object val;
2609 /* eassert (!handling_signal); */
2611 MALLOC_BLOCK_INPUT;
2613 if (float_free_list)
2615 /* We use the data field for chaining the free list
2616 so that we won't use the same field that has the mark bit. */
2617 XSETFLOAT (val, float_free_list);
2618 float_free_list = float_free_list->u.chain;
2620 else
2622 if (float_block_index == FLOAT_BLOCK_SIZE)
2624 register struct float_block *new;
2626 new = (struct float_block *) lisp_align_malloc (sizeof *new,
2627 MEM_TYPE_FLOAT);
2628 new->next = float_block;
2629 bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
2630 float_block = new;
2631 float_block_index = 0;
2632 n_float_blocks++;
2634 XSETFLOAT (val, &float_block->floats[float_block_index]);
2635 float_block_index++;
2638 MALLOC_UNBLOCK_INPUT;
2640 XFLOAT_DATA (val) = float_value;
2641 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
2642 consing_since_gc += sizeof (struct Lisp_Float);
2643 floats_consed++;
2644 return val;
2649 /***********************************************************************
2650 Cons Allocation
2651 ***********************************************************************/
2653 /* We store cons cells inside of cons_blocks, allocating a new
2654 cons_block with malloc whenever necessary. Cons cells reclaimed by
2655 GC are put on a free list to be reallocated before allocating
2656 any new cons cells from the latest cons_block. */
2658 #define CONS_BLOCK_SIZE \
2659 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
2660 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
2662 #define CONS_BLOCK(fptr) \
2663 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
2665 #define CONS_INDEX(fptr) \
2666 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
2668 struct cons_block
2670 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
2671 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
2672 int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
2673 struct cons_block *next;
2676 #define CONS_MARKED_P(fptr) \
2677 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2679 #define CONS_MARK(fptr) \
2680 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2682 #define CONS_UNMARK(fptr) \
2683 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
2685 /* Current cons_block. */
2687 struct cons_block *cons_block;
2689 /* Index of first unused Lisp_Cons in the current block. */
2691 int cons_block_index;
2693 /* Free-list of Lisp_Cons structures. */
2695 struct Lisp_Cons *cons_free_list;
2697 /* Total number of cons blocks now in use. */
2699 static int n_cons_blocks;
2702 /* Initialize cons allocation. */
2704 static void
2705 init_cons ()
2707 cons_block = NULL;
2708 cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
2709 cons_free_list = 0;
2710 n_cons_blocks = 0;
2714 /* Explicitly free a cons cell by putting it on the free-list. */
2716 void
2717 free_cons (ptr)
2718 struct Lisp_Cons *ptr;
2720 ptr->u.chain = cons_free_list;
2721 #if GC_MARK_STACK
2722 ptr->car = Vdead;
2723 #endif
2724 cons_free_list = ptr;
2727 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
2728 doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
2729 (car, cdr)
2730 Lisp_Object car, cdr;
2732 register Lisp_Object val;
2734 /* eassert (!handling_signal); */
2736 MALLOC_BLOCK_INPUT;
2738 if (cons_free_list)
2740 /* We use the cdr for chaining the free list
2741 so that we won't use the same field that has the mark bit. */
2742 XSETCONS (val, cons_free_list);
2743 cons_free_list = cons_free_list->u.chain;
2745 else
2747 if (cons_block_index == CONS_BLOCK_SIZE)
2749 register struct cons_block *new;
2750 new = (struct cons_block *) lisp_align_malloc (sizeof *new,
2751 MEM_TYPE_CONS);
2752 bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
2753 new->next = cons_block;
2754 cons_block = new;
2755 cons_block_index = 0;
2756 n_cons_blocks++;
2758 XSETCONS (val, &cons_block->conses[cons_block_index]);
2759 cons_block_index++;
2762 MALLOC_UNBLOCK_INPUT;
2764 XSETCAR (val, car);
2765 XSETCDR (val, cdr);
2766 eassert (!CONS_MARKED_P (XCONS (val)));
2767 consing_since_gc += sizeof (struct Lisp_Cons);
2768 cons_cells_consed++;
2769 return val;
2772 /* Get an error now if there's any junk in the cons free list. */
2773 void
2774 check_cons_list ()
2776 #ifdef GC_CHECK_CONS_LIST
2777 struct Lisp_Cons *tail = cons_free_list;
2779 while (tail)
2780 tail = tail->u.chain;
2781 #endif
2784 /* Make a list of 1, 2, 3, 4 or 5 specified objects. */
2786 Lisp_Object
2787 list1 (arg1)
2788 Lisp_Object arg1;
2790 return Fcons (arg1, Qnil);
2793 Lisp_Object
2794 list2 (arg1, arg2)
2795 Lisp_Object arg1, arg2;
2797 return Fcons (arg1, Fcons (arg2, Qnil));
2801 Lisp_Object
2802 list3 (arg1, arg2, arg3)
2803 Lisp_Object arg1, arg2, arg3;
2805 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
2809 Lisp_Object
2810 list4 (arg1, arg2, arg3, arg4)
2811 Lisp_Object arg1, arg2, arg3, arg4;
2813 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
2817 Lisp_Object
2818 list5 (arg1, arg2, arg3, arg4, arg5)
2819 Lisp_Object arg1, arg2, arg3, arg4, arg5;
2821 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
2822 Fcons (arg5, Qnil)))));
2826 DEFUN ("list", Flist, Slist, 0, MANY, 0,
2827 doc: /* Return a newly created list with specified arguments as elements.
2828 Any number of arguments, even zero arguments, are allowed.
2829 usage: (list &rest OBJECTS) */)
2830 (nargs, args)
2831 int nargs;
2832 register Lisp_Object *args;
2834 register Lisp_Object val;
2835 val = Qnil;
2837 while (nargs > 0)
2839 nargs--;
2840 val = Fcons (args[nargs], val);
2842 return val;
2846 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
2847 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
2848 (length, init)
2849 register Lisp_Object length, init;
2851 register Lisp_Object val;
2852 register int size;
2854 CHECK_NATNUM (length);
2855 size = XFASTINT (length);
2857 val = Qnil;
2858 while (size > 0)
2860 val = Fcons (init, val);
2861 --size;
2863 if (size > 0)
2865 val = Fcons (init, val);
2866 --size;
2868 if (size > 0)
2870 val = Fcons (init, val);
2871 --size;
2873 if (size > 0)
2875 val = Fcons (init, val);
2876 --size;
2878 if (size > 0)
2880 val = Fcons (init, val);
2881 --size;
2887 QUIT;
2890 return val;
2895 /***********************************************************************
2896 Vector Allocation
2897 ***********************************************************************/
2899 /* Singly-linked list of all vectors. */
2901 static struct Lisp_Vector *all_vectors;
2903 /* Total number of vector-like objects now in use. */
2905 static int n_vectors;
2908 /* Value is a pointer to a newly allocated Lisp_Vector structure
2909 with room for LEN Lisp_Objects. */
2911 static struct Lisp_Vector *
2912 allocate_vectorlike (len)
2913 EMACS_INT len;
2915 struct Lisp_Vector *p;
2916 size_t nbytes;
2918 MALLOC_BLOCK_INPUT;
2920 #ifdef DOUG_LEA_MALLOC
2921 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
2922 because mapped region contents are not preserved in
2923 a dumped Emacs. */
2924 mallopt (M_MMAP_MAX, 0);
2925 #endif
2927 /* This gets triggered by code which I haven't bothered to fix. --Stef */
2928 /* eassert (!handling_signal); */
2930 nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
2931 p = (struct Lisp_Vector *) lisp_malloc (nbytes, MEM_TYPE_VECTORLIKE);
2933 #ifdef DOUG_LEA_MALLOC
2934 /* Back to a reasonable maximum of mmap'ed areas. */
2935 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
2936 #endif
2938 consing_since_gc += nbytes;
2939 vector_cells_consed += len;
2941 p->next = all_vectors;
2942 all_vectors = p;
2944 MALLOC_UNBLOCK_INPUT;
2946 ++n_vectors;
2947 return p;
2951 /* Allocate a vector with NSLOTS slots. */
2953 struct Lisp_Vector *
2954 allocate_vector (nslots)
2955 EMACS_INT nslots;
2957 struct Lisp_Vector *v = allocate_vectorlike (nslots);
2958 v->size = nslots;
2959 return v;
2963 /* Allocate other vector-like structures. */
2965 struct Lisp_Vector *
2966 allocate_pseudovector (memlen, lisplen, tag)
2967 int memlen, lisplen;
2968 EMACS_INT tag;
2970 struct Lisp_Vector *v = allocate_vectorlike (memlen);
2971 EMACS_INT i;
2973 /* Only the first lisplen slots will be traced normally by the GC. */
2974 v->size = lisplen;
2975 for (i = 0; i < lisplen; ++i)
2976 v->contents[i] = Qnil;
2978 XSETPVECTYPE (v, tag); /* Add the appropriate tag. */
2979 return v;
2982 struct Lisp_Hash_Table *
2983 allocate_hash_table (void)
2985 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Hash_Table, count, PVEC_HASH_TABLE);
2989 struct window *
2990 allocate_window ()
2992 return ALLOCATE_PSEUDOVECTOR(struct window, current_matrix, PVEC_WINDOW);
2996 struct terminal *
2997 allocate_terminal ()
2999 struct terminal *t = ALLOCATE_PSEUDOVECTOR (struct terminal,
3000 next_terminal, PVEC_TERMINAL);
3001 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3002 bzero (&(t->next_terminal),
3003 ((char*)(t+1)) - ((char*)&(t->next_terminal)));
3005 return t;
3008 struct frame *
3009 allocate_frame ()
3011 struct frame *f = ALLOCATE_PSEUDOVECTOR (struct frame,
3012 face_cache, PVEC_FRAME);
3013 /* Zero out the non-GC'd fields. FIXME: This should be made unnecessary. */
3014 bzero (&(f->face_cache),
3015 ((char*)(f+1)) - ((char*)&(f->face_cache)));
3016 return f;
3020 struct Lisp_Process *
3021 allocate_process ()
3023 return ALLOCATE_PSEUDOVECTOR (struct Lisp_Process, pid, PVEC_PROCESS);
3027 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
3028 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
3029 See also the function `vector'. */)
3030 (length, init)
3031 register Lisp_Object length, init;
3033 Lisp_Object vector;
3034 register EMACS_INT sizei;
3035 register int index;
3036 register struct Lisp_Vector *p;
3038 CHECK_NATNUM (length);
3039 sizei = XFASTINT (length);
3041 p = allocate_vector (sizei);
3042 for (index = 0; index < sizei; index++)
3043 p->contents[index] = init;
3045 XSETVECTOR (vector, p);
3046 return vector;
3050 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
3051 doc: /* Return a newly created vector with specified arguments as elements.
3052 Any number of arguments, even zero arguments, are allowed.
3053 usage: (vector &rest OBJECTS) */)
3054 (nargs, args)
3055 register int nargs;
3056 Lisp_Object *args;
3058 register Lisp_Object len, val;
3059 register int index;
3060 register struct Lisp_Vector *p;
3062 XSETFASTINT (len, nargs);
3063 val = Fmake_vector (len, Qnil);
3064 p = XVECTOR (val);
3065 for (index = 0; index < nargs; index++)
3066 p->contents[index] = args[index];
3067 return val;
3071 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
3072 doc: /* Create a byte-code object with specified arguments as elements.
3073 The arguments should be the arglist, bytecode-string, constant vector,
3074 stack size, (optional) doc string, and (optional) interactive spec.
3075 The first four arguments are required; at most six have any
3076 significance.
3077 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
3078 (nargs, args)
3079 register int nargs;
3080 Lisp_Object *args;
3082 register Lisp_Object len, val;
3083 register int index;
3084 register struct Lisp_Vector *p;
3086 XSETFASTINT (len, nargs);
3087 if (!NILP (Vpurify_flag))
3088 val = make_pure_vector ((EMACS_INT) nargs);
3089 else
3090 val = Fmake_vector (len, Qnil);
3092 if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
3093 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
3094 earlier because they produced a raw 8-bit string for byte-code
3095 and now such a byte-code string is loaded as multibyte while
3096 raw 8-bit characters converted to multibyte form. Thus, now we
3097 must convert them back to the original unibyte form. */
3098 args[1] = Fstring_as_unibyte (args[1]);
3100 p = XVECTOR (val);
3101 for (index = 0; index < nargs; index++)
3103 if (!NILP (Vpurify_flag))
3104 args[index] = Fpurecopy (args[index]);
3105 p->contents[index] = args[index];
3107 XSETPVECTYPE (p, PVEC_COMPILED);
3108 XSETCOMPILED (val, p);
3109 return val;
3114 /***********************************************************************
3115 Symbol Allocation
3116 ***********************************************************************/
3118 /* Each symbol_block is just under 1020 bytes long, since malloc
3119 really allocates in units of powers of two and uses 4 bytes for its
3120 own overhead. */
3122 #define SYMBOL_BLOCK_SIZE \
3123 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
3125 struct symbol_block
3127 /* Place `symbols' first, to preserve alignment. */
3128 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
3129 struct symbol_block *next;
3132 /* Current symbol block and index of first unused Lisp_Symbol
3133 structure in it. */
3135 static struct symbol_block *symbol_block;
3136 static int symbol_block_index;
3138 /* List of free symbols. */
3140 static struct Lisp_Symbol *symbol_free_list;
3142 /* Total number of symbol blocks now in use. */
3144 static int n_symbol_blocks;
3147 /* Initialize symbol allocation. */
3149 static void
3150 init_symbol ()
3152 symbol_block = NULL;
3153 symbol_block_index = SYMBOL_BLOCK_SIZE;
3154 symbol_free_list = 0;
3155 n_symbol_blocks = 0;
3159 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
3160 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
3161 Its value and function definition are void, and its property list is nil. */)
3162 (name)
3163 Lisp_Object name;
3165 register Lisp_Object val;
3166 register struct Lisp_Symbol *p;
3168 CHECK_STRING (name);
3170 /* eassert (!handling_signal); */
3172 MALLOC_BLOCK_INPUT;
3174 if (symbol_free_list)
3176 XSETSYMBOL (val, symbol_free_list);
3177 symbol_free_list = symbol_free_list->next;
3179 else
3181 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
3183 struct symbol_block *new;
3184 new = (struct symbol_block *) lisp_malloc (sizeof *new,
3185 MEM_TYPE_SYMBOL);
3186 new->next = symbol_block;
3187 symbol_block = new;
3188 symbol_block_index = 0;
3189 n_symbol_blocks++;
3191 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
3192 symbol_block_index++;
3195 MALLOC_UNBLOCK_INPUT;
3197 p = XSYMBOL (val);
3198 p->xname = name;
3199 p->plist = Qnil;
3200 p->value = Qunbound;
3201 p->function = Qunbound;
3202 p->next = NULL;
3203 p->gcmarkbit = 0;
3204 p->interned = SYMBOL_UNINTERNED;
3205 p->constant = 0;
3206 p->indirect_variable = 0;
3207 consing_since_gc += sizeof (struct Lisp_Symbol);
3208 symbols_consed++;
3209 return val;
3214 /***********************************************************************
3215 Marker (Misc) Allocation
3216 ***********************************************************************/
3218 /* Allocation of markers and other objects that share that structure.
3219 Works like allocation of conses. */
3221 #define MARKER_BLOCK_SIZE \
3222 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
3224 struct marker_block
3226 /* Place `markers' first, to preserve alignment. */
3227 union Lisp_Misc markers[MARKER_BLOCK_SIZE];
3228 struct marker_block *next;
3231 static struct marker_block *marker_block;
3232 static int marker_block_index;
3234 static union Lisp_Misc *marker_free_list;
3236 /* Total number of marker blocks now in use. */
3238 static int n_marker_blocks;
3240 static void
3241 init_marker ()
3243 marker_block = NULL;
3244 marker_block_index = MARKER_BLOCK_SIZE;
3245 marker_free_list = 0;
3246 n_marker_blocks = 0;
3249 /* Return a newly allocated Lisp_Misc object, with no substructure. */
3251 Lisp_Object
3252 allocate_misc ()
3254 Lisp_Object val;
3256 /* eassert (!handling_signal); */
3258 MALLOC_BLOCK_INPUT;
3260 if (marker_free_list)
3262 XSETMISC (val, marker_free_list);
3263 marker_free_list = marker_free_list->u_free.chain;
3265 else
3267 if (marker_block_index == MARKER_BLOCK_SIZE)
3269 struct marker_block *new;
3270 new = (struct marker_block *) lisp_malloc (sizeof *new,
3271 MEM_TYPE_MISC);
3272 new->next = marker_block;
3273 marker_block = new;
3274 marker_block_index = 0;
3275 n_marker_blocks++;
3276 total_free_markers += MARKER_BLOCK_SIZE;
3278 XSETMISC (val, &marker_block->markers[marker_block_index]);
3279 marker_block_index++;
3282 MALLOC_UNBLOCK_INPUT;
3284 --total_free_markers;
3285 consing_since_gc += sizeof (union Lisp_Misc);
3286 misc_objects_consed++;
3287 XMISCANY (val)->gcmarkbit = 0;
3288 return val;
3291 /* Free a Lisp_Misc object */
3293 void
3294 free_misc (misc)
3295 Lisp_Object misc;
3297 XMISCTYPE (misc) = Lisp_Misc_Free;
3298 XMISC (misc)->u_free.chain = marker_free_list;
3299 marker_free_list = XMISC (misc);
3301 total_free_markers++;
3304 /* Return a Lisp_Misc_Save_Value object containing POINTER and
3305 INTEGER. This is used to package C values to call record_unwind_protect.
3306 The unwind function can get the C values back using XSAVE_VALUE. */
3308 Lisp_Object
3309 make_save_value (pointer, integer)
3310 void *pointer;
3311 int integer;
3313 register Lisp_Object val;
3314 register struct Lisp_Save_Value *p;
3316 val = allocate_misc ();
3317 XMISCTYPE (val) = Lisp_Misc_Save_Value;
3318 p = XSAVE_VALUE (val);
3319 p->pointer = pointer;
3320 p->integer = integer;
3321 p->dogc = 0;
3322 return val;
3325 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
3326 doc: /* Return a newly allocated marker which does not point at any place. */)
3329 register Lisp_Object val;
3330 register struct Lisp_Marker *p;
3332 val = allocate_misc ();
3333 XMISCTYPE (val) = Lisp_Misc_Marker;
3334 p = XMARKER (val);
3335 p->buffer = 0;
3336 p->bytepos = 0;
3337 p->charpos = 0;
3338 p->next = NULL;
3339 p->insertion_type = 0;
3340 return val;
3343 /* Put MARKER back on the free list after using it temporarily. */
3345 void
3346 free_marker (marker)
3347 Lisp_Object marker;
3349 unchain_marker (XMARKER (marker));
3350 free_misc (marker);
3354 /* Return a newly created vector or string with specified arguments as
3355 elements. If all the arguments are characters that can fit
3356 in a string of events, make a string; otherwise, make a vector.
3358 Any number of arguments, even zero arguments, are allowed. */
3360 Lisp_Object
3361 make_event_array (nargs, args)
3362 register int nargs;
3363 Lisp_Object *args;
3365 int i;
3367 for (i = 0; i < nargs; i++)
3368 /* The things that fit in a string
3369 are characters that are in 0...127,
3370 after discarding the meta bit and all the bits above it. */
3371 if (!INTEGERP (args[i])
3372 || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
3373 return Fvector (nargs, args);
3375 /* Since the loop exited, we know that all the things in it are
3376 characters, so we can make a string. */
3378 Lisp_Object result;
3380 result = Fmake_string (make_number (nargs), make_number (0));
3381 for (i = 0; i < nargs; i++)
3383 SSET (result, i, XINT (args[i]));
3384 /* Move the meta bit to the right place for a string char. */
3385 if (XINT (args[i]) & CHAR_META)
3386 SSET (result, i, SREF (result, i) | 0x80);
3389 return result;
3395 /************************************************************************
3396 Memory Full Handling
3397 ************************************************************************/
3400 /* Called if malloc returns zero. */
3402 void
3403 memory_full ()
3405 int i;
3407 Vmemory_full = Qt;
3409 memory_full_cons_threshold = sizeof (struct cons_block);
3411 /* The first time we get here, free the spare memory. */
3412 for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
3413 if (spare_memory[i])
3415 if (i == 0)
3416 free (spare_memory[i]);
3417 else if (i >= 1 && i <= 4)
3418 lisp_align_free (spare_memory[i]);
3419 else
3420 lisp_free (spare_memory[i]);
3421 spare_memory[i] = 0;
3424 /* Record the space now used. When it decreases substantially,
3425 we can refill the memory reserve. */
3426 #ifndef SYSTEM_MALLOC
3427 bytes_used_when_full = BYTES_USED;
3428 #endif
3430 /* This used to call error, but if we've run out of memory, we could
3431 get infinite recursion trying to build the string. */
3432 xsignal (Qnil, Vmemory_signal_data);
3435 /* If we released our reserve (due to running out of memory),
3436 and we have a fair amount free once again,
3437 try to set aside another reserve in case we run out once more.
3439 This is called when a relocatable block is freed in ralloc.c,
3440 and also directly from this file, in case we're not using ralloc.c. */
3442 void
3443 refill_memory_reserve ()
3445 #ifndef SYSTEM_MALLOC
3446 if (spare_memory[0] == 0)
3447 spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
3448 if (spare_memory[1] == 0)
3449 spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3450 MEM_TYPE_CONS);
3451 if (spare_memory[2] == 0)
3452 spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3453 MEM_TYPE_CONS);
3454 if (spare_memory[3] == 0)
3455 spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3456 MEM_TYPE_CONS);
3457 if (spare_memory[4] == 0)
3458 spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
3459 MEM_TYPE_CONS);
3460 if (spare_memory[5] == 0)
3461 spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
3462 MEM_TYPE_STRING);
3463 if (spare_memory[6] == 0)
3464 spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
3465 MEM_TYPE_STRING);
3466 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
3467 Vmemory_full = Qnil;
3468 #endif
3471 /************************************************************************
3472 C Stack Marking
3473 ************************************************************************/
3475 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
3477 /* Conservative C stack marking requires a method to identify possibly
3478 live Lisp objects given a pointer value. We do this by keeping
3479 track of blocks of Lisp data that are allocated in a red-black tree
3480 (see also the comment of mem_node which is the type of nodes in
3481 that tree). Function lisp_malloc adds information for an allocated
3482 block to the red-black tree with calls to mem_insert, and function
3483 lisp_free removes it with mem_delete. Functions live_string_p etc
3484 call mem_find to lookup information about a given pointer in the
3485 tree, and use that to determine if the pointer points to a Lisp
3486 object or not. */
3488 /* Initialize this part of alloc.c. */
3490 static void
3491 mem_init ()
3493 mem_z.left = mem_z.right = MEM_NIL;
3494 mem_z.parent = NULL;
3495 mem_z.color = MEM_BLACK;
3496 mem_z.start = mem_z.end = NULL;
3497 mem_root = MEM_NIL;
3501 /* Value is a pointer to the mem_node containing START. Value is
3502 MEM_NIL if there is no node in the tree containing START. */
3504 static INLINE struct mem_node *
3505 mem_find (start)
3506 void *start;
3508 struct mem_node *p;
3510 if (start < min_heap_address || start > max_heap_address)
3511 return MEM_NIL;
3513 /* Make the search always successful to speed up the loop below. */
3514 mem_z.start = start;
3515 mem_z.end = (char *) start + 1;
3517 p = mem_root;
3518 while (start < p->start || start >= p->end)
3519 p = start < p->start ? p->left : p->right;
3520 return p;
3524 /* Insert a new node into the tree for a block of memory with start
3525 address START, end address END, and type TYPE. Value is a
3526 pointer to the node that was inserted. */
3528 static struct mem_node *
3529 mem_insert (start, end, type)
3530 void *start, *end;
3531 enum mem_type type;
3533 struct mem_node *c, *parent, *x;
3535 if (min_heap_address == NULL || start < min_heap_address)
3536 min_heap_address = start;
3537 if (max_heap_address == NULL || end > max_heap_address)
3538 max_heap_address = end;
3540 /* See where in the tree a node for START belongs. In this
3541 particular application, it shouldn't happen that a node is already
3542 present. For debugging purposes, let's check that. */
3543 c = mem_root;
3544 parent = NULL;
3546 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
3548 while (c != MEM_NIL)
3550 if (start >= c->start && start < c->end)
3551 abort ();
3552 parent = c;
3553 c = start < c->start ? c->left : c->right;
3556 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3558 while (c != MEM_NIL)
3560 parent = c;
3561 c = start < c->start ? c->left : c->right;
3564 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
3566 /* Create a new node. */
3567 #ifdef GC_MALLOC_CHECK
3568 x = (struct mem_node *) _malloc_internal (sizeof *x);
3569 if (x == NULL)
3570 abort ();
3571 #else
3572 x = (struct mem_node *) xmalloc (sizeof *x);
3573 #endif
3574 x->start = start;
3575 x->end = end;
3576 x->type = type;
3577 x->parent = parent;
3578 x->left = x->right = MEM_NIL;
3579 x->color = MEM_RED;
3581 /* Insert it as child of PARENT or install it as root. */
3582 if (parent)
3584 if (start < parent->start)
3585 parent->left = x;
3586 else
3587 parent->right = x;
3589 else
3590 mem_root = x;
3592 /* Re-establish red-black tree properties. */
3593 mem_insert_fixup (x);
3595 return x;
3599 /* Re-establish the red-black properties of the tree, and thereby
3600 balance the tree, after node X has been inserted; X is always red. */
3602 static void
3603 mem_insert_fixup (x)
3604 struct mem_node *x;
3606 while (x != mem_root && x->parent->color == MEM_RED)
3608 /* X is red and its parent is red. This is a violation of
3609 red-black tree property #3. */
3611 if (x->parent == x->parent->parent->left)
3613 /* We're on the left side of our grandparent, and Y is our
3614 "uncle". */
3615 struct mem_node *y = x->parent->parent->right;
3617 if (y->color == MEM_RED)
3619 /* Uncle and parent are red but should be black because
3620 X is red. Change the colors accordingly and proceed
3621 with the grandparent. */
3622 x->parent->color = MEM_BLACK;
3623 y->color = MEM_BLACK;
3624 x->parent->parent->color = MEM_RED;
3625 x = x->parent->parent;
3627 else
3629 /* Parent and uncle have different colors; parent is
3630 red, uncle is black. */
3631 if (x == x->parent->right)
3633 x = x->parent;
3634 mem_rotate_left (x);
3637 x->parent->color = MEM_BLACK;
3638 x->parent->parent->color = MEM_RED;
3639 mem_rotate_right (x->parent->parent);
3642 else
3644 /* This is the symmetrical case of above. */
3645 struct mem_node *y = x->parent->parent->left;
3647 if (y->color == MEM_RED)
3649 x->parent->color = MEM_BLACK;
3650 y->color = MEM_BLACK;
3651 x->parent->parent->color = MEM_RED;
3652 x = x->parent->parent;
3654 else
3656 if (x == x->parent->left)
3658 x = x->parent;
3659 mem_rotate_right (x);
3662 x->parent->color = MEM_BLACK;
3663 x->parent->parent->color = MEM_RED;
3664 mem_rotate_left (x->parent->parent);
3669 /* The root may have been changed to red due to the algorithm. Set
3670 it to black so that property #5 is satisfied. */
3671 mem_root->color = MEM_BLACK;
3675 /* (x) (y)
3676 / \ / \
3677 a (y) ===> (x) c
3678 / \ / \
3679 b c a b */
3681 static void
3682 mem_rotate_left (x)
3683 struct mem_node *x;
3685 struct mem_node *y;
3687 /* Turn y's left sub-tree into x's right sub-tree. */
3688 y = x->right;
3689 x->right = y->left;
3690 if (y->left != MEM_NIL)
3691 y->left->parent = x;
3693 /* Y's parent was x's parent. */
3694 if (y != MEM_NIL)
3695 y->parent = x->parent;
3697 /* Get the parent to point to y instead of x. */
3698 if (x->parent)
3700 if (x == x->parent->left)
3701 x->parent->left = y;
3702 else
3703 x->parent->right = y;
3705 else
3706 mem_root = y;
3708 /* Put x on y's left. */
3709 y->left = x;
3710 if (x != MEM_NIL)
3711 x->parent = y;
3715 /* (x) (Y)
3716 / \ / \
3717 (y) c ===> a (x)
3718 / \ / \
3719 a b b c */
3721 static void
3722 mem_rotate_right (x)
3723 struct mem_node *x;
3725 struct mem_node *y = x->left;
3727 x->left = y->right;
3728 if (y->right != MEM_NIL)
3729 y->right->parent = x;
3731 if (y != MEM_NIL)
3732 y->parent = x->parent;
3733 if (x->parent)
3735 if (x == x->parent->right)
3736 x->parent->right = y;
3737 else
3738 x->parent->left = y;
3740 else
3741 mem_root = y;
3743 y->right = x;
3744 if (x != MEM_NIL)
3745 x->parent = y;
3749 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
3751 static void
3752 mem_delete (z)
3753 struct mem_node *z;
3755 struct mem_node *x, *y;
3757 if (!z || z == MEM_NIL)
3758 return;
3760 if (z->left == MEM_NIL || z->right == MEM_NIL)
3761 y = z;
3762 else
3764 y = z->right;
3765 while (y->left != MEM_NIL)
3766 y = y->left;
3769 if (y->left != MEM_NIL)
3770 x = y->left;
3771 else
3772 x = y->right;
3774 x->parent = y->parent;
3775 if (y->parent)
3777 if (y == y->parent->left)
3778 y->parent->left = x;
3779 else
3780 y->parent->right = x;
3782 else
3783 mem_root = x;
3785 if (y != z)
3787 z->start = y->start;
3788 z->end = y->end;
3789 z->type = y->type;
3792 if (y->color == MEM_BLACK)
3793 mem_delete_fixup (x);
3795 #ifdef GC_MALLOC_CHECK
3796 _free_internal (y);
3797 #else
3798 xfree (y);
3799 #endif
3803 /* Re-establish the red-black properties of the tree, after a
3804 deletion. */
3806 static void
3807 mem_delete_fixup (x)
3808 struct mem_node *x;
3810 while (x != mem_root && x->color == MEM_BLACK)
3812 if (x == x->parent->left)
3814 struct mem_node *w = x->parent->right;
3816 if (w->color == MEM_RED)
3818 w->color = MEM_BLACK;
3819 x->parent->color = MEM_RED;
3820 mem_rotate_left (x->parent);
3821 w = x->parent->right;
3824 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
3826 w->color = MEM_RED;
3827 x = x->parent;
3829 else
3831 if (w->right->color == MEM_BLACK)
3833 w->left->color = MEM_BLACK;
3834 w->color = MEM_RED;
3835 mem_rotate_right (w);
3836 w = x->parent->right;
3838 w->color = x->parent->color;
3839 x->parent->color = MEM_BLACK;
3840 w->right->color = MEM_BLACK;
3841 mem_rotate_left (x->parent);
3842 x = mem_root;
3845 else
3847 struct mem_node *w = x->parent->left;
3849 if (w->color == MEM_RED)
3851 w->color = MEM_BLACK;
3852 x->parent->color = MEM_RED;
3853 mem_rotate_right (x->parent);
3854 w = x->parent->left;
3857 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
3859 w->color = MEM_RED;
3860 x = x->parent;
3862 else
3864 if (w->left->color == MEM_BLACK)
3866 w->right->color = MEM_BLACK;
3867 w->color = MEM_RED;
3868 mem_rotate_left (w);
3869 w = x->parent->left;
3872 w->color = x->parent->color;
3873 x->parent->color = MEM_BLACK;
3874 w->left->color = MEM_BLACK;
3875 mem_rotate_right (x->parent);
3876 x = mem_root;
3881 x->color = MEM_BLACK;
3885 /* Value is non-zero if P is a pointer to a live Lisp string on
3886 the heap. M is a pointer to the mem_block for P. */
3888 static INLINE int
3889 live_string_p (m, p)
3890 struct mem_node *m;
3891 void *p;
3893 if (m->type == MEM_TYPE_STRING)
3895 struct string_block *b = (struct string_block *) m->start;
3896 int offset = (char *) p - (char *) &b->strings[0];
3898 /* P must point to the start of a Lisp_String structure, and it
3899 must not be on the free-list. */
3900 return (offset >= 0
3901 && offset % sizeof b->strings[0] == 0
3902 && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
3903 && ((struct Lisp_String *) p)->data != NULL);
3905 else
3906 return 0;
3910 /* Value is non-zero if P is a pointer to a live Lisp cons on
3911 the heap. M is a pointer to the mem_block for P. */
3913 static INLINE int
3914 live_cons_p (m, p)
3915 struct mem_node *m;
3916 void *p;
3918 if (m->type == MEM_TYPE_CONS)
3920 struct cons_block *b = (struct cons_block *) m->start;
3921 int offset = (char *) p - (char *) &b->conses[0];
3923 /* P must point to the start of a Lisp_Cons, not be
3924 one of the unused cells in the current cons block,
3925 and not be on the free-list. */
3926 return (offset >= 0
3927 && offset % sizeof b->conses[0] == 0
3928 && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
3929 && (b != cons_block
3930 || offset / sizeof b->conses[0] < cons_block_index)
3931 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
3933 else
3934 return 0;
3938 /* Value is non-zero if P is a pointer to a live Lisp symbol on
3939 the heap. M is a pointer to the mem_block for P. */
3941 static INLINE int
3942 live_symbol_p (m, p)
3943 struct mem_node *m;
3944 void *p;
3946 if (m->type == MEM_TYPE_SYMBOL)
3948 struct symbol_block *b = (struct symbol_block *) m->start;
3949 int offset = (char *) p - (char *) &b->symbols[0];
3951 /* P must point to the start of a Lisp_Symbol, not be
3952 one of the unused cells in the current symbol block,
3953 and not be on the free-list. */
3954 return (offset >= 0
3955 && offset % sizeof b->symbols[0] == 0
3956 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
3957 && (b != symbol_block
3958 || offset / sizeof b->symbols[0] < symbol_block_index)
3959 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
3961 else
3962 return 0;
3966 /* Value is non-zero if P is a pointer to a live Lisp float on
3967 the heap. M is a pointer to the mem_block for P. */
3969 static INLINE int
3970 live_float_p (m, p)
3971 struct mem_node *m;
3972 void *p;
3974 if (m->type == MEM_TYPE_FLOAT)
3976 struct float_block *b = (struct float_block *) m->start;
3977 int offset = (char *) p - (char *) &b->floats[0];
3979 /* P must point to the start of a Lisp_Float and not be
3980 one of the unused cells in the current float block. */
3981 return (offset >= 0
3982 && offset % sizeof b->floats[0] == 0
3983 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
3984 && (b != float_block
3985 || offset / sizeof b->floats[0] < float_block_index));
3987 else
3988 return 0;
3992 /* Value is non-zero if P is a pointer to a live Lisp Misc on
3993 the heap. M is a pointer to the mem_block for P. */
3995 static INLINE int
3996 live_misc_p (m, p)
3997 struct mem_node *m;
3998 void *p;
4000 if (m->type == MEM_TYPE_MISC)
4002 struct marker_block *b = (struct marker_block *) m->start;
4003 int offset = (char *) p - (char *) &b->markers[0];
4005 /* P must point to the start of a Lisp_Misc, not be
4006 one of the unused cells in the current misc block,
4007 and not be on the free-list. */
4008 return (offset >= 0
4009 && offset % sizeof b->markers[0] == 0
4010 && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
4011 && (b != marker_block
4012 || offset / sizeof b->markers[0] < marker_block_index)
4013 && ((union Lisp_Misc *) p)->u_any.type != Lisp_Misc_Free);
4015 else
4016 return 0;
4020 /* Value is non-zero if P is a pointer to a live vector-like object.
4021 M is a pointer to the mem_block for P. */
4023 static INLINE int
4024 live_vector_p (m, p)
4025 struct mem_node *m;
4026 void *p;
4028 return (p == m->start && m->type == MEM_TYPE_VECTORLIKE);
4032 /* Value is non-zero if P is a pointer to a live buffer. M is a
4033 pointer to the mem_block for P. */
4035 static INLINE int
4036 live_buffer_p (m, p)
4037 struct mem_node *m;
4038 void *p;
4040 /* P must point to the start of the block, and the buffer
4041 must not have been killed. */
4042 return (m->type == MEM_TYPE_BUFFER
4043 && p == m->start
4044 && !NILP (((struct buffer *) p)->name));
4047 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
4049 #if GC_MARK_STACK
4051 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4053 /* Array of objects that are kept alive because the C stack contains
4054 a pattern that looks like a reference to them . */
4056 #define MAX_ZOMBIES 10
4057 static Lisp_Object zombies[MAX_ZOMBIES];
4059 /* Number of zombie objects. */
4061 static int nzombies;
4063 /* Number of garbage collections. */
4065 static int ngcs;
4067 /* Average percentage of zombies per collection. */
4069 static double avg_zombies;
4071 /* Max. number of live and zombie objects. */
4073 static int max_live, max_zombies;
4075 /* Average number of live objects per GC. */
4077 static double avg_live;
4079 DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
4080 doc: /* Show information about live and zombie objects. */)
4083 Lisp_Object args[8], zombie_list = Qnil;
4084 int i;
4085 for (i = 0; i < nzombies; i++)
4086 zombie_list = Fcons (zombies[i], zombie_list);
4087 args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
4088 args[1] = make_number (ngcs);
4089 args[2] = make_float (avg_live);
4090 args[3] = make_float (avg_zombies);
4091 args[4] = make_float (avg_zombies / avg_live / 100);
4092 args[5] = make_number (max_live);
4093 args[6] = make_number (max_zombies);
4094 args[7] = zombie_list;
4095 return Fmessage (8, args);
4098 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4101 /* Mark OBJ if we can prove it's a Lisp_Object. */
4103 static INLINE void
4104 mark_maybe_object (obj)
4105 Lisp_Object obj;
4107 void *po = (void *) XPNTR (obj);
4108 struct mem_node *m = mem_find (po);
4110 if (m != MEM_NIL)
4112 int mark_p = 0;
4114 switch (XTYPE (obj))
4116 case Lisp_String:
4117 mark_p = (live_string_p (m, po)
4118 && !STRING_MARKED_P ((struct Lisp_String *) po));
4119 break;
4121 case Lisp_Cons:
4122 mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
4123 break;
4125 case Lisp_Symbol:
4126 mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
4127 break;
4129 case Lisp_Float:
4130 mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
4131 break;
4133 case Lisp_Vectorlike:
4134 /* Note: can't check BUFFERP before we know it's a
4135 buffer because checking that dereferences the pointer
4136 PO which might point anywhere. */
4137 if (live_vector_p (m, po))
4138 mark_p = !SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
4139 else if (live_buffer_p (m, po))
4140 mark_p = BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
4141 break;
4143 case Lisp_Misc:
4144 mark_p = (live_misc_p (m, po) && !XMISCANY (obj)->gcmarkbit);
4145 break;
4147 case Lisp_Int:
4148 case Lisp_Type_Limit:
4149 break;
4152 if (mark_p)
4154 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4155 if (nzombies < MAX_ZOMBIES)
4156 zombies[nzombies] = obj;
4157 ++nzombies;
4158 #endif
4159 mark_object (obj);
4165 /* If P points to Lisp data, mark that as live if it isn't already
4166 marked. */
4168 static INLINE void
4169 mark_maybe_pointer (p)
4170 void *p;
4172 struct mem_node *m;
4174 /* Quickly rule out some values which can't point to Lisp data. */
4175 if ((EMACS_INT) p %
4176 #ifdef USE_LSB_TAG
4177 8 /* USE_LSB_TAG needs Lisp data to be aligned on multiples of 8. */
4178 #else
4179 2 /* We assume that Lisp data is aligned on even addresses. */
4180 #endif
4182 return;
4184 m = mem_find (p);
4185 if (m != MEM_NIL)
4187 Lisp_Object obj = Qnil;
4189 switch (m->type)
4191 case MEM_TYPE_NON_LISP:
4192 /* Nothing to do; not a pointer to Lisp memory. */
4193 break;
4195 case MEM_TYPE_BUFFER:
4196 if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
4197 XSETVECTOR (obj, p);
4198 break;
4200 case MEM_TYPE_CONS:
4201 if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
4202 XSETCONS (obj, p);
4203 break;
4205 case MEM_TYPE_STRING:
4206 if (live_string_p (m, p)
4207 && !STRING_MARKED_P ((struct Lisp_String *) p))
4208 XSETSTRING (obj, p);
4209 break;
4211 case MEM_TYPE_MISC:
4212 if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
4213 XSETMISC (obj, p);
4214 break;
4216 case MEM_TYPE_SYMBOL:
4217 if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
4218 XSETSYMBOL (obj, p);
4219 break;
4221 case MEM_TYPE_FLOAT:
4222 if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
4223 XSETFLOAT (obj, p);
4224 break;
4226 case MEM_TYPE_VECTORLIKE:
4227 if (live_vector_p (m, p))
4229 Lisp_Object tem;
4230 XSETVECTOR (tem, p);
4231 if (!SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
4232 obj = tem;
4234 break;
4236 default:
4237 abort ();
4240 if (!NILP (obj))
4241 mark_object (obj);
4246 /* Mark Lisp objects referenced from the address range START+OFFSET..END
4247 or END+OFFSET..START. */
4249 static void
4250 mark_memory (start, end, offset)
4251 void *start, *end;
4252 int offset;
4254 Lisp_Object *p;
4255 void **pp;
4257 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4258 nzombies = 0;
4259 #endif
4261 /* Make START the pointer to the start of the memory region,
4262 if it isn't already. */
4263 if (end < start)
4265 void *tem = start;
4266 start = end;
4267 end = tem;
4270 /* Mark Lisp_Objects. */
4271 for (p = (Lisp_Object *) ((char *) start + offset); (void *) p < end; ++p)
4272 mark_maybe_object (*p);
4274 /* Mark Lisp data pointed to. This is necessary because, in some
4275 situations, the C compiler optimizes Lisp objects away, so that
4276 only a pointer to them remains. Example:
4278 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
4281 Lisp_Object obj = build_string ("test");
4282 struct Lisp_String *s = XSTRING (obj);
4283 Fgarbage_collect ();
4284 fprintf (stderr, "test `%s'\n", s->data);
4285 return Qnil;
4288 Here, `obj' isn't really used, and the compiler optimizes it
4289 away. The only reference to the life string is through the
4290 pointer `s'. */
4292 for (pp = (void **) ((char *) start + offset); (void *) pp < end; ++pp)
4293 mark_maybe_pointer (*pp);
4296 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
4297 the GCC system configuration. In gcc 3.2, the only systems for
4298 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
4299 by others?) and ns32k-pc532-min. */
4301 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
4303 static int setjmp_tested_p, longjmps_done;
4305 #define SETJMP_WILL_LIKELY_WORK "\
4307 Emacs garbage collector has been changed to use conservative stack\n\
4308 marking. Emacs has determined that the method it uses to do the\n\
4309 marking will likely work on your system, but this isn't sure.\n\
4311 If you are a system-programmer, or can get the help of a local wizard\n\
4312 who is, please take a look at the function mark_stack in alloc.c, and\n\
4313 verify that the methods used are appropriate for your system.\n\
4315 Please mail the result to <emacs-devel@gnu.org>.\n\
4318 #define SETJMP_WILL_NOT_WORK "\
4320 Emacs garbage collector has been changed to use conservative stack\n\
4321 marking. Emacs has determined that the default method it uses to do the\n\
4322 marking will not work on your system. We will need a system-dependent\n\
4323 solution for your system.\n\
4325 Please take a look at the function mark_stack in alloc.c, and\n\
4326 try to find a way to make it work on your system.\n\
4328 Note that you may get false negatives, depending on the compiler.\n\
4329 In particular, you need to use -O with GCC for this test.\n\
4331 Please mail the result to <emacs-devel@gnu.org>.\n\
4335 /* Perform a quick check if it looks like setjmp saves registers in a
4336 jmp_buf. Print a message to stderr saying so. When this test
4337 succeeds, this is _not_ a proof that setjmp is sufficient for
4338 conservative stack marking. Only the sources or a disassembly
4339 can prove that. */
4341 static void
4342 test_setjmp ()
4344 char buf[10];
4345 register int x;
4346 jmp_buf jbuf;
4347 int result = 0;
4349 /* Arrange for X to be put in a register. */
4350 sprintf (buf, "1");
4351 x = strlen (buf);
4352 x = 2 * x - 1;
4354 setjmp (jbuf);
4355 if (longjmps_done == 1)
4357 /* Came here after the longjmp at the end of the function.
4359 If x == 1, the longjmp has restored the register to its
4360 value before the setjmp, and we can hope that setjmp
4361 saves all such registers in the jmp_buf, although that
4362 isn't sure.
4364 For other values of X, either something really strange is
4365 taking place, or the setjmp just didn't save the register. */
4367 if (x == 1)
4368 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
4369 else
4371 fprintf (stderr, SETJMP_WILL_NOT_WORK);
4372 exit (1);
4376 ++longjmps_done;
4377 x = 2;
4378 if (longjmps_done == 1)
4379 longjmp (jbuf, 1);
4382 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
4385 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4387 /* Abort if anything GCPRO'd doesn't survive the GC. */
4389 static void
4390 check_gcpros ()
4392 struct gcpro *p;
4393 int i;
4395 for (p = gcprolist; p; p = p->next)
4396 for (i = 0; i < p->nvars; ++i)
4397 if (!survives_gc_p (p->var[i]))
4398 /* FIXME: It's not necessarily a bug. It might just be that the
4399 GCPRO is unnecessary or should release the object sooner. */
4400 abort ();
4403 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
4405 static void
4406 dump_zombies ()
4408 int i;
4410 fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
4411 for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
4413 fprintf (stderr, " %d = ", i);
4414 debug_print (zombies[i]);
4418 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
4421 /* Mark live Lisp objects on the C stack.
4423 There are several system-dependent problems to consider when
4424 porting this to new architectures:
4426 Processor Registers
4428 We have to mark Lisp objects in CPU registers that can hold local
4429 variables or are used to pass parameters.
4431 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
4432 something that either saves relevant registers on the stack, or
4433 calls mark_maybe_object passing it each register's contents.
4435 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
4436 implementation assumes that calling setjmp saves registers we need
4437 to see in a jmp_buf which itself lies on the stack. This doesn't
4438 have to be true! It must be verified for each system, possibly
4439 by taking a look at the source code of setjmp.
4441 Stack Layout
4443 Architectures differ in the way their processor stack is organized.
4444 For example, the stack might look like this
4446 +----------------+
4447 | Lisp_Object | size = 4
4448 +----------------+
4449 | something else | size = 2
4450 +----------------+
4451 | Lisp_Object | size = 4
4452 +----------------+
4453 | ... |
4455 In such a case, not every Lisp_Object will be aligned equally. To
4456 find all Lisp_Object on the stack it won't be sufficient to walk
4457 the stack in steps of 4 bytes. Instead, two passes will be
4458 necessary, one starting at the start of the stack, and a second
4459 pass starting at the start of the stack + 2. Likewise, if the
4460 minimal alignment of Lisp_Objects on the stack is 1, four passes
4461 would be necessary, each one starting with one byte more offset
4462 from the stack start.
4464 The current code assumes by default that Lisp_Objects are aligned
4465 equally on the stack. */
4467 static void
4468 mark_stack ()
4470 int i;
4471 /* jmp_buf may not be aligned enough on darwin-ppc64 */
4472 union aligned_jmpbuf {
4473 Lisp_Object o;
4474 jmp_buf j;
4475 } j;
4476 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
4477 void *end;
4479 /* This trick flushes the register windows so that all the state of
4480 the process is contained in the stack. */
4481 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
4482 needed on ia64 too. See mach_dep.c, where it also says inline
4483 assembler doesn't work with relevant proprietary compilers. */
4484 #ifdef sparc
4485 asm ("ta 3");
4486 #endif
4488 /* Save registers that we need to see on the stack. We need to see
4489 registers used to hold register variables and registers used to
4490 pass parameters. */
4491 #ifdef GC_SAVE_REGISTERS_ON_STACK
4492 GC_SAVE_REGISTERS_ON_STACK (end);
4493 #else /* not GC_SAVE_REGISTERS_ON_STACK */
4495 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
4496 setjmp will definitely work, test it
4497 and print a message with the result
4498 of the test. */
4499 if (!setjmp_tested_p)
4501 setjmp_tested_p = 1;
4502 test_setjmp ();
4504 #endif /* GC_SETJMP_WORKS */
4506 setjmp (j.j);
4507 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
4508 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
4510 /* This assumes that the stack is a contiguous region in memory. If
4511 that's not the case, something has to be done here to iterate
4512 over the stack segments. */
4513 #ifndef GC_LISP_OBJECT_ALIGNMENT
4514 #ifdef __GNUC__
4515 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
4516 #else
4517 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
4518 #endif
4519 #endif
4520 for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
4521 mark_memory (stack_base, end, i);
4522 /* Allow for marking a secondary stack, like the register stack on the
4523 ia64. */
4524 #ifdef GC_MARK_SECONDARY_STACK
4525 GC_MARK_SECONDARY_STACK ();
4526 #endif
4528 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
4529 check_gcpros ();
4530 #endif
4533 #endif /* GC_MARK_STACK != 0 */
4536 /* Determine whether it is safe to access memory at address P. */
4537 static int
4538 valid_pointer_p (p)
4539 void *p;
4541 #ifdef WINDOWSNT
4542 return w32_valid_pointer_p (p, 16);
4543 #else
4544 int fd;
4546 /* Obviously, we cannot just access it (we would SEGV trying), so we
4547 trick the o/s to tell us whether p is a valid pointer.
4548 Unfortunately, we cannot use NULL_DEVICE here, as emacs_write may
4549 not validate p in that case. */
4551 if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
4553 int valid = (emacs_write (fd, (char *)p, 16) == 16);
4554 emacs_close (fd);
4555 unlink ("__Valid__Lisp__Object__");
4556 return valid;
4559 return -1;
4560 #endif
4563 /* Return 1 if OBJ is a valid lisp object.
4564 Return 0 if OBJ is NOT a valid lisp object.
4565 Return -1 if we cannot validate OBJ.
4566 This function can be quite slow,
4567 so it should only be used in code for manual debugging. */
4570 valid_lisp_object_p (obj)
4571 Lisp_Object obj;
4573 void *p;
4574 #if GC_MARK_STACK
4575 struct mem_node *m;
4576 #endif
4578 if (INTEGERP (obj))
4579 return 1;
4581 p = (void *) XPNTR (obj);
4582 if (PURE_POINTER_P (p))
4583 return 1;
4585 #if !GC_MARK_STACK
4586 return valid_pointer_p (p);
4587 #else
4589 m = mem_find (p);
4591 if (m == MEM_NIL)
4593 int valid = valid_pointer_p (p);
4594 if (valid <= 0)
4595 return valid;
4597 if (SUBRP (obj))
4598 return 1;
4600 return 0;
4603 switch (m->type)
4605 case MEM_TYPE_NON_LISP:
4606 return 0;
4608 case MEM_TYPE_BUFFER:
4609 return live_buffer_p (m, p);
4611 case MEM_TYPE_CONS:
4612 return live_cons_p (m, p);
4614 case MEM_TYPE_STRING:
4615 return live_string_p (m, p);
4617 case MEM_TYPE_MISC:
4618 return live_misc_p (m, p);
4620 case MEM_TYPE_SYMBOL:
4621 return live_symbol_p (m, p);
4623 case MEM_TYPE_FLOAT:
4624 return live_float_p (m, p);
4626 case MEM_TYPE_VECTORLIKE:
4627 return live_vector_p (m, p);
4629 default:
4630 break;
4633 return 0;
4634 #endif
4640 /***********************************************************************
4641 Pure Storage Management
4642 ***********************************************************************/
4644 /* Allocate room for SIZE bytes from pure Lisp storage and return a
4645 pointer to it. TYPE is the Lisp type for which the memory is
4646 allocated. TYPE < 0 means it's not used for a Lisp object. */
4648 static POINTER_TYPE *
4649 pure_alloc (size, type)
4650 size_t size;
4651 int type;
4653 POINTER_TYPE *result;
4654 #ifdef USE_LSB_TAG
4655 size_t alignment = (1 << GCTYPEBITS);
4656 #else
4657 size_t alignment = sizeof (EMACS_INT);
4659 /* Give Lisp_Floats an extra alignment. */
4660 if (type == Lisp_Float)
4662 #if defined __GNUC__ && __GNUC__ >= 2
4663 alignment = __alignof (struct Lisp_Float);
4664 #else
4665 alignment = sizeof (struct Lisp_Float);
4666 #endif
4668 #endif
4670 again:
4671 if (type >= 0)
4673 /* Allocate space for a Lisp object from the beginning of the free
4674 space with taking account of alignment. */
4675 result = ALIGN (purebeg + pure_bytes_used_lisp, alignment);
4676 pure_bytes_used_lisp = ((char *)result - (char *)purebeg) + size;
4678 else
4680 /* Allocate space for a non-Lisp object from the end of the free
4681 space. */
4682 pure_bytes_used_non_lisp += size;
4683 result = purebeg + pure_size - pure_bytes_used_non_lisp;
4685 pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp;
4687 if (pure_bytes_used <= pure_size)
4688 return result;
4690 /* Don't allocate a large amount here,
4691 because it might get mmap'd and then its address
4692 might not be usable. */
4693 purebeg = (char *) xmalloc (10000);
4694 pure_size = 10000;
4695 pure_bytes_used_before_overflow += pure_bytes_used - size;
4696 pure_bytes_used = 0;
4697 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
4698 goto again;
4702 /* Print a warning if PURESIZE is too small. */
4704 void
4705 check_pure_size ()
4707 if (pure_bytes_used_before_overflow)
4708 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
4709 (int) (pure_bytes_used + pure_bytes_used_before_overflow));
4713 /* Find the byte sequence {DATA[0], ..., DATA[NBYTES-1], '\0'} from
4714 the non-Lisp data pool of the pure storage, and return its start
4715 address. Return NULL if not found. */
4717 static char *
4718 find_string_data_in_pure (data, nbytes)
4719 char *data;
4720 int nbytes;
4722 int i, skip, bm_skip[256], last_char_skip, infinity, start, start_max;
4723 unsigned char *p;
4724 char *non_lisp_beg;
4726 if (pure_bytes_used_non_lisp < nbytes + 1)
4727 return NULL;
4729 /* Set up the Boyer-Moore table. */
4730 skip = nbytes + 1;
4731 for (i = 0; i < 256; i++)
4732 bm_skip[i] = skip;
4734 p = (unsigned char *) data;
4735 while (--skip > 0)
4736 bm_skip[*p++] = skip;
4738 last_char_skip = bm_skip['\0'];
4740 non_lisp_beg = purebeg + pure_size - pure_bytes_used_non_lisp;
4741 start_max = pure_bytes_used_non_lisp - (nbytes + 1);
4743 /* See the comments in the function `boyer_moore' (search.c) for the
4744 use of `infinity'. */
4745 infinity = pure_bytes_used_non_lisp + 1;
4746 bm_skip['\0'] = infinity;
4748 p = (unsigned char *) non_lisp_beg + nbytes;
4749 start = 0;
4752 /* Check the last character (== '\0'). */
4755 start += bm_skip[*(p + start)];
4757 while (start <= start_max);
4759 if (start < infinity)
4760 /* Couldn't find the last character. */
4761 return NULL;
4763 /* No less than `infinity' means we could find the last
4764 character at `p[start - infinity]'. */
4765 start -= infinity;
4767 /* Check the remaining characters. */
4768 if (memcmp (data, non_lisp_beg + start, nbytes) == 0)
4769 /* Found. */
4770 return non_lisp_beg + start;
4772 start += last_char_skip;
4774 while (start <= start_max);
4776 return NULL;
4780 /* Return a string allocated in pure space. DATA is a buffer holding
4781 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
4782 non-zero means make the result string multibyte.
4784 Must get an error if pure storage is full, since if it cannot hold
4785 a large string it may be able to hold conses that point to that
4786 string; then the string is not protected from gc. */
4788 Lisp_Object
4789 make_pure_string (data, nchars, nbytes, multibyte)
4790 char *data;
4791 int nchars, nbytes;
4792 int multibyte;
4794 Lisp_Object string;
4795 struct Lisp_String *s;
4797 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
4798 s->data = find_string_data_in_pure (data, nbytes);
4799 if (s->data == NULL)
4801 s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
4802 bcopy (data, s->data, nbytes);
4803 s->data[nbytes] = '\0';
4805 s->size = nchars;
4806 s->size_byte = multibyte ? nbytes : -1;
4807 s->intervals = NULL_INTERVAL;
4808 XSETSTRING (string, s);
4809 return string;
4813 /* Return a cons allocated from pure space. Give it pure copies
4814 of CAR as car and CDR as cdr. */
4816 Lisp_Object
4817 pure_cons (car, cdr)
4818 Lisp_Object car, cdr;
4820 register Lisp_Object new;
4821 struct Lisp_Cons *p;
4823 p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
4824 XSETCONS (new, p);
4825 XSETCAR (new, Fpurecopy (car));
4826 XSETCDR (new, Fpurecopy (cdr));
4827 return new;
4831 /* Value is a float object with value NUM allocated from pure space. */
4833 static Lisp_Object
4834 make_pure_float (num)
4835 double num;
4837 register Lisp_Object new;
4838 struct Lisp_Float *p;
4840 p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
4841 XSETFLOAT (new, p);
4842 XFLOAT_DATA (new) = num;
4843 return new;
4847 /* Return a vector with room for LEN Lisp_Objects allocated from
4848 pure space. */
4850 Lisp_Object
4851 make_pure_vector (len)
4852 EMACS_INT len;
4854 Lisp_Object new;
4855 struct Lisp_Vector *p;
4856 size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
4858 p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
4859 XSETVECTOR (new, p);
4860 XVECTOR (new)->size = len;
4861 return new;
4865 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
4866 doc: /* Make a copy of object OBJ in pure storage.
4867 Recursively copies contents of vectors and cons cells.
4868 Does not copy symbols. Copies strings without text properties. */)
4869 (obj)
4870 register Lisp_Object obj;
4872 if (NILP (Vpurify_flag))
4873 return obj;
4875 if (PURE_POINTER_P (XPNTR (obj)))
4876 return obj;
4878 if (CONSP (obj))
4879 return pure_cons (XCAR (obj), XCDR (obj));
4880 else if (FLOATP (obj))
4881 return make_pure_float (XFLOAT_DATA (obj));
4882 else if (STRINGP (obj))
4883 return make_pure_string (SDATA (obj), SCHARS (obj),
4884 SBYTES (obj),
4885 STRING_MULTIBYTE (obj));
4886 else if (COMPILEDP (obj) || VECTORP (obj))
4888 register struct Lisp_Vector *vec;
4889 register int i;
4890 EMACS_INT size;
4892 size = XVECTOR (obj)->size;
4893 if (size & PSEUDOVECTOR_FLAG)
4894 size &= PSEUDOVECTOR_SIZE_MASK;
4895 vec = XVECTOR (make_pure_vector (size));
4896 for (i = 0; i < size; i++)
4897 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
4898 if (COMPILEDP (obj))
4900 XSETPVECTYPE (vec, PVEC_COMPILED);
4901 XSETCOMPILED (obj, vec);
4903 else
4904 XSETVECTOR (obj, vec);
4905 return obj;
4907 else if (MARKERP (obj))
4908 error ("Attempt to copy a marker to pure storage");
4910 return obj;
4915 /***********************************************************************
4916 Protection from GC
4917 ***********************************************************************/
4919 /* Put an entry in staticvec, pointing at the variable with address
4920 VARADDRESS. */
4922 void
4923 staticpro (varaddress)
4924 Lisp_Object *varaddress;
4926 staticvec[staticidx++] = varaddress;
4927 if (staticidx >= NSTATICS)
4928 abort ();
4931 struct catchtag
4933 Lisp_Object tag;
4934 Lisp_Object val;
4935 struct catchtag *next;
4939 /***********************************************************************
4940 Protection from GC
4941 ***********************************************************************/
4943 /* Temporarily prevent garbage collection. */
4946 inhibit_garbage_collection ()
4948 int count = SPECPDL_INDEX ();
4949 int nbits = min (VALBITS, BITS_PER_INT);
4951 specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
4952 return count;
4956 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
4957 doc: /* Reclaim storage for Lisp objects no longer needed.
4958 Garbage collection happens automatically if you cons more than
4959 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
4960 `garbage-collect' normally returns a list with info on amount of space in use:
4961 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
4962 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
4963 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
4964 (USED-STRINGS . FREE-STRINGS))
4965 However, if there was overflow in pure space, `garbage-collect'
4966 returns nil, because real GC can't be done. */)
4969 register struct specbinding *bind;
4970 struct catchtag *catch;
4971 struct handler *handler;
4972 char stack_top_variable;
4973 register int i;
4974 int message_p;
4975 Lisp_Object total[8];
4976 int count = SPECPDL_INDEX ();
4977 EMACS_TIME t1, t2, t3;
4979 if (abort_on_gc)
4980 abort ();
4982 /* Can't GC if pure storage overflowed because we can't determine
4983 if something is a pure object or not. */
4984 if (pure_bytes_used_before_overflow)
4985 return Qnil;
4987 CHECK_CONS_LIST ();
4989 /* Don't keep undo information around forever.
4990 Do this early on, so it is no problem if the user quits. */
4992 register struct buffer *nextb = all_buffers;
4994 while (nextb)
4996 /* If a buffer's undo list is Qt, that means that undo is
4997 turned off in that buffer. Calling truncate_undo_list on
4998 Qt tends to return NULL, which effectively turns undo back on.
4999 So don't call truncate_undo_list if undo_list is Qt. */
5000 if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
5001 truncate_undo_list (nextb);
5003 /* Shrink buffer gaps, but skip indirect and dead buffers. */
5004 if (nextb->base_buffer == 0 && !NILP (nextb->name)
5005 && ! nextb->text->inhibit_shrinking)
5007 /* If a buffer's gap size is more than 10% of the buffer
5008 size, or larger than 2000 bytes, then shrink it
5009 accordingly. Keep a minimum size of 20 bytes. */
5010 int size = min (2000, max (20, (nextb->text->z_byte / 10)));
5012 if (nextb->text->gap_size > size)
5014 struct buffer *save_current = current_buffer;
5015 current_buffer = nextb;
5016 make_gap (-(nextb->text->gap_size - size));
5017 current_buffer = save_current;
5021 nextb = nextb->next;
5025 EMACS_GET_TIME (t1);
5027 /* In case user calls debug_print during GC,
5028 don't let that cause a recursive GC. */
5029 consing_since_gc = 0;
5031 /* Save what's currently displayed in the echo area. */
5032 message_p = push_message ();
5033 record_unwind_protect (pop_message_unwind, Qnil);
5035 /* Save a copy of the contents of the stack, for debugging. */
5036 #if MAX_SAVE_STACK > 0
5037 if (NILP (Vpurify_flag))
5039 i = &stack_top_variable - stack_bottom;
5040 if (i < 0) i = -i;
5041 if (i < MAX_SAVE_STACK)
5043 if (stack_copy == 0)
5044 stack_copy = (char *) xmalloc (stack_copy_size = i);
5045 else if (stack_copy_size < i)
5046 stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
5047 if (stack_copy)
5049 if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
5050 bcopy (stack_bottom, stack_copy, i);
5051 else
5052 bcopy (&stack_top_variable, stack_copy, i);
5056 #endif /* MAX_SAVE_STACK > 0 */
5058 if (garbage_collection_messages)
5059 message1_nolog ("Garbage collecting...");
5061 BLOCK_INPUT;
5063 shrink_regexp_cache ();
5065 gc_in_progress = 1;
5067 /* clear_marks (); */
5069 /* Mark all the special slots that serve as the roots of accessibility. */
5071 for (i = 0; i < staticidx; i++)
5072 mark_object (*staticvec[i]);
5074 for (bind = specpdl; bind != specpdl_ptr; bind++)
5076 mark_object (bind->symbol);
5077 mark_object (bind->old_value);
5079 mark_terminals ();
5080 mark_kboards ();
5081 mark_ttys ();
5083 #ifdef USE_GTK
5085 extern void xg_mark_data ();
5086 xg_mark_data ();
5088 #endif
5090 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
5091 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
5092 mark_stack ();
5093 #else
5095 register struct gcpro *tail;
5096 for (tail = gcprolist; tail; tail = tail->next)
5097 for (i = 0; i < tail->nvars; i++)
5098 mark_object (tail->var[i]);
5100 #endif
5102 mark_byte_stack ();
5103 for (catch = catchlist; catch; catch = catch->next)
5105 mark_object (catch->tag);
5106 mark_object (catch->val);
5108 for (handler = handlerlist; handler; handler = handler->next)
5110 mark_object (handler->handler);
5111 mark_object (handler->var);
5113 mark_backtrace ();
5115 #ifdef HAVE_WINDOW_SYSTEM
5116 mark_fringe_data ();
5117 #endif
5119 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5120 mark_stack ();
5121 #endif
5123 /* Everything is now marked, except for the things that require special
5124 finalization, i.e. the undo_list.
5125 Look thru every buffer's undo list
5126 for elements that update markers that were not marked,
5127 and delete them. */
5129 register struct buffer *nextb = all_buffers;
5131 while (nextb)
5133 /* If a buffer's undo list is Qt, that means that undo is
5134 turned off in that buffer. Calling truncate_undo_list on
5135 Qt tends to return NULL, which effectively turns undo back on.
5136 So don't call truncate_undo_list if undo_list is Qt. */
5137 if (! EQ (nextb->undo_list, Qt))
5139 Lisp_Object tail, prev;
5140 tail = nextb->undo_list;
5141 prev = Qnil;
5142 while (CONSP (tail))
5144 if (CONSP (XCAR (tail))
5145 && MARKERP (XCAR (XCAR (tail)))
5146 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
5148 if (NILP (prev))
5149 nextb->undo_list = tail = XCDR (tail);
5150 else
5152 tail = XCDR (tail);
5153 XSETCDR (prev, tail);
5156 else
5158 prev = tail;
5159 tail = XCDR (tail);
5163 /* Now that we have stripped the elements that need not be in the
5164 undo_list any more, we can finally mark the list. */
5165 mark_object (nextb->undo_list);
5167 nextb = nextb->next;
5171 gc_sweep ();
5173 /* Clear the mark bits that we set in certain root slots. */
5175 unmark_byte_stack ();
5176 VECTOR_UNMARK (&buffer_defaults);
5177 VECTOR_UNMARK (&buffer_local_symbols);
5179 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
5180 dump_zombies ();
5181 #endif
5183 UNBLOCK_INPUT;
5185 CHECK_CONS_LIST ();
5187 /* clear_marks (); */
5188 gc_in_progress = 0;
5190 consing_since_gc = 0;
5191 if (gc_cons_threshold < 10000)
5192 gc_cons_threshold = 10000;
5194 if (FLOATP (Vgc_cons_percentage))
5195 { /* Set gc_cons_combined_threshold. */
5196 EMACS_INT total = 0;
5198 total += total_conses * sizeof (struct Lisp_Cons);
5199 total += total_symbols * sizeof (struct Lisp_Symbol);
5200 total += total_markers * sizeof (union Lisp_Misc);
5201 total += total_string_size;
5202 total += total_vector_size * sizeof (Lisp_Object);
5203 total += total_floats * sizeof (struct Lisp_Float);
5204 total += total_intervals * sizeof (struct interval);
5205 total += total_strings * sizeof (struct Lisp_String);
5207 gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
5209 else
5210 gc_relative_threshold = 0;
5212 if (garbage_collection_messages)
5214 if (message_p || minibuf_level > 0)
5215 restore_message ();
5216 else
5217 message1_nolog ("Garbage collecting...done");
5220 unbind_to (count, Qnil);
5222 total[0] = Fcons (make_number (total_conses),
5223 make_number (total_free_conses));
5224 total[1] = Fcons (make_number (total_symbols),
5225 make_number (total_free_symbols));
5226 total[2] = Fcons (make_number (total_markers),
5227 make_number (total_free_markers));
5228 total[3] = make_number (total_string_size);
5229 total[4] = make_number (total_vector_size);
5230 total[5] = Fcons (make_number (total_floats),
5231 make_number (total_free_floats));
5232 total[6] = Fcons (make_number (total_intervals),
5233 make_number (total_free_intervals));
5234 total[7] = Fcons (make_number (total_strings),
5235 make_number (total_free_strings));
5237 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
5239 /* Compute average percentage of zombies. */
5240 double nlive = 0;
5242 for (i = 0; i < 7; ++i)
5243 if (CONSP (total[i]))
5244 nlive += XFASTINT (XCAR (total[i]));
5246 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
5247 max_live = max (nlive, max_live);
5248 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
5249 max_zombies = max (nzombies, max_zombies);
5250 ++ngcs;
5252 #endif
5254 if (!NILP (Vpost_gc_hook))
5256 int count = inhibit_garbage_collection ();
5257 safe_run_hooks (Qpost_gc_hook);
5258 unbind_to (count, Qnil);
5261 /* Accumulate statistics. */
5262 EMACS_GET_TIME (t2);
5263 EMACS_SUB_TIME (t3, t2, t1);
5264 if (FLOATP (Vgc_elapsed))
5265 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
5266 EMACS_SECS (t3) +
5267 EMACS_USECS (t3) * 1.0e-6);
5268 gcs_done++;
5270 return Flist (sizeof total / sizeof *total, total);
5274 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
5275 only interesting objects referenced from glyphs are strings. */
5277 static void
5278 mark_glyph_matrix (matrix)
5279 struct glyph_matrix *matrix;
5281 struct glyph_row *row = matrix->rows;
5282 struct glyph_row *end = row + matrix->nrows;
5284 for (; row < end; ++row)
5285 if (row->enabled_p)
5287 int area;
5288 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
5290 struct glyph *glyph = row->glyphs[area];
5291 struct glyph *end_glyph = glyph + row->used[area];
5293 for (; glyph < end_glyph; ++glyph)
5294 if (STRINGP (glyph->object)
5295 && !STRING_MARKED_P (XSTRING (glyph->object)))
5296 mark_object (glyph->object);
5302 /* Mark Lisp faces in the face cache C. */
5304 static void
5305 mark_face_cache (c)
5306 struct face_cache *c;
5308 if (c)
5310 int i, j;
5311 for (i = 0; i < c->used; ++i)
5313 struct face *face = FACE_FROM_ID (c->f, i);
5315 if (face)
5317 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
5318 mark_object (face->lface[j]);
5326 /* Mark reference to a Lisp_Object.
5327 If the object referred to has not been seen yet, recursively mark
5328 all the references contained in it. */
5330 #define LAST_MARKED_SIZE 500
5331 static Lisp_Object last_marked[LAST_MARKED_SIZE];
5332 int last_marked_index;
5334 /* For debugging--call abort when we cdr down this many
5335 links of a list, in mark_object. In debugging,
5336 the call to abort will hit a breakpoint.
5337 Normally this is zero and the check never goes off. */
5338 static int mark_object_loop_halt;
5340 /* Return non-zero if the object was not yet marked. */
5341 static int
5342 mark_vectorlike (ptr)
5343 struct Lisp_Vector *ptr;
5345 register EMACS_INT size = ptr->size;
5346 register int i;
5348 if (VECTOR_MARKED_P (ptr))
5349 return 0; /* Already marked */
5350 VECTOR_MARK (ptr); /* Else mark it */
5351 if (size & PSEUDOVECTOR_FLAG)
5352 size &= PSEUDOVECTOR_SIZE_MASK;
5354 /* Note that this size is not the memory-footprint size, but only
5355 the number of Lisp_Object fields that we should trace.
5356 The distinction is used e.g. by Lisp_Process which places extra
5357 non-Lisp_Object fields at the end of the structure. */
5358 for (i = 0; i < size; i++) /* and then mark its elements */
5359 mark_object (ptr->contents[i]);
5360 return 1;
5363 void
5364 mark_object (arg)
5365 Lisp_Object arg;
5367 register Lisp_Object obj = arg;
5368 #ifdef GC_CHECK_MARKED_OBJECTS
5369 void *po;
5370 struct mem_node *m;
5371 #endif
5372 int cdr_count = 0;
5374 loop:
5376 if (PURE_POINTER_P (XPNTR (obj)))
5377 return;
5379 last_marked[last_marked_index++] = obj;
5380 if (last_marked_index == LAST_MARKED_SIZE)
5381 last_marked_index = 0;
5383 /* Perform some sanity checks on the objects marked here. Abort if
5384 we encounter an object we know is bogus. This increases GC time
5385 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
5386 #ifdef GC_CHECK_MARKED_OBJECTS
5388 po = (void *) XPNTR (obj);
5390 /* Check that the object pointed to by PO is known to be a Lisp
5391 structure allocated from the heap. */
5392 #define CHECK_ALLOCATED() \
5393 do { \
5394 m = mem_find (po); \
5395 if (m == MEM_NIL) \
5396 abort (); \
5397 } while (0)
5399 /* Check that the object pointed to by PO is live, using predicate
5400 function LIVEP. */
5401 #define CHECK_LIVE(LIVEP) \
5402 do { \
5403 if (!LIVEP (m, po)) \
5404 abort (); \
5405 } while (0)
5407 /* Check both of the above conditions. */
5408 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
5409 do { \
5410 CHECK_ALLOCATED (); \
5411 CHECK_LIVE (LIVEP); \
5412 } while (0) \
5414 #else /* not GC_CHECK_MARKED_OBJECTS */
5416 #define CHECK_ALLOCATED() (void) 0
5417 #define CHECK_LIVE(LIVEP) (void) 0
5418 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
5420 #endif /* not GC_CHECK_MARKED_OBJECTS */
5422 switch (SWITCH_ENUM_CAST (XTYPE (obj)))
5424 case Lisp_String:
5426 register struct Lisp_String *ptr = XSTRING (obj);
5427 CHECK_ALLOCATED_AND_LIVE (live_string_p);
5428 MARK_INTERVAL_TREE (ptr->intervals);
5429 MARK_STRING (ptr);
5430 #ifdef GC_CHECK_STRING_BYTES
5431 /* Check that the string size recorded in the string is the
5432 same as the one recorded in the sdata structure. */
5433 CHECK_STRING_BYTES (ptr);
5434 #endif /* GC_CHECK_STRING_BYTES */
5436 break;
5438 case Lisp_Vectorlike:
5439 #ifdef GC_CHECK_MARKED_OBJECTS
5440 m = mem_find (po);
5441 if (m == MEM_NIL && !SUBRP (obj)
5442 && po != &buffer_defaults
5443 && po != &buffer_local_symbols)
5444 abort ();
5445 #endif /* GC_CHECK_MARKED_OBJECTS */
5447 if (BUFFERP (obj))
5449 if (!VECTOR_MARKED_P (XBUFFER (obj)))
5451 #ifdef GC_CHECK_MARKED_OBJECTS
5452 if (po != &buffer_defaults && po != &buffer_local_symbols)
5454 struct buffer *b;
5455 for (b = all_buffers; b && b != po; b = b->next)
5457 if (b == NULL)
5458 abort ();
5460 #endif /* GC_CHECK_MARKED_OBJECTS */
5461 mark_buffer (obj);
5464 else if (SUBRP (obj))
5465 break;
5466 else if (COMPILEDP (obj))
5467 /* We could treat this just like a vector, but it is better to
5468 save the COMPILED_CONSTANTS element for last and avoid
5469 recursion there. */
5471 register struct Lisp_Vector *ptr = XVECTOR (obj);
5472 register EMACS_INT size = ptr->size;
5473 register int i;
5475 if (VECTOR_MARKED_P (ptr))
5476 break; /* Already marked */
5478 CHECK_LIVE (live_vector_p);
5479 VECTOR_MARK (ptr); /* Else mark it */
5480 size &= PSEUDOVECTOR_SIZE_MASK;
5481 for (i = 0; i < size; i++) /* and then mark its elements */
5483 if (i != COMPILED_CONSTANTS)
5484 mark_object (ptr->contents[i]);
5486 obj = ptr->contents[COMPILED_CONSTANTS];
5487 goto loop;
5489 else if (FRAMEP (obj))
5491 register struct frame *ptr = XFRAME (obj);
5492 if (mark_vectorlike (XVECTOR (obj)))
5493 mark_face_cache (ptr->face_cache);
5495 else if (WINDOWP (obj))
5497 register struct Lisp_Vector *ptr = XVECTOR (obj);
5498 struct window *w = XWINDOW (obj);
5499 if (mark_vectorlike (ptr))
5501 /* Mark glyphs for leaf windows. Marking window matrices is
5502 sufficient because frame matrices use the same glyph
5503 memory. */
5504 if (NILP (w->hchild)
5505 && NILP (w->vchild)
5506 && w->current_matrix)
5508 mark_glyph_matrix (w->current_matrix);
5509 mark_glyph_matrix (w->desired_matrix);
5513 else if (HASH_TABLE_P (obj))
5515 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
5516 if (mark_vectorlike ((struct Lisp_Vector *)h))
5517 { /* If hash table is not weak, mark all keys and values.
5518 For weak tables, mark only the vector. */
5519 if (NILP (h->weak))
5520 mark_object (h->key_and_value);
5521 else
5522 VECTOR_MARK (XVECTOR (h->key_and_value));
5525 else
5526 mark_vectorlike (XVECTOR (obj));
5527 break;
5529 case Lisp_Symbol:
5531 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
5532 struct Lisp_Symbol *ptrx;
5534 if (ptr->gcmarkbit) break;
5535 CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
5536 ptr->gcmarkbit = 1;
5537 mark_object (ptr->value);
5538 mark_object (ptr->function);
5539 mark_object (ptr->plist);
5541 if (!PURE_POINTER_P (XSTRING (ptr->xname)))
5542 MARK_STRING (XSTRING (ptr->xname));
5543 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
5545 /* Note that we do not mark the obarray of the symbol.
5546 It is safe not to do so because nothing accesses that
5547 slot except to check whether it is nil. */
5548 ptr = ptr->next;
5549 if (ptr)
5551 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
5552 XSETSYMBOL (obj, ptrx);
5553 goto loop;
5556 break;
5558 case Lisp_Misc:
5559 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
5560 if (XMISCANY (obj)->gcmarkbit)
5561 break;
5562 XMISCANY (obj)->gcmarkbit = 1;
5564 switch (XMISCTYPE (obj))
5566 case Lisp_Misc_Buffer_Local_Value:
5568 register struct Lisp_Buffer_Local_Value *ptr
5569 = XBUFFER_LOCAL_VALUE (obj);
5570 /* If the cdr is nil, avoid recursion for the car. */
5571 if (EQ (ptr->cdr, Qnil))
5573 obj = ptr->realvalue;
5574 goto loop;
5576 mark_object (ptr->realvalue);
5577 mark_object (ptr->buffer);
5578 mark_object (ptr->frame);
5579 obj = ptr->cdr;
5580 goto loop;
5583 case Lisp_Misc_Marker:
5584 /* DO NOT mark thru the marker's chain.
5585 The buffer's markers chain does not preserve markers from gc;
5586 instead, markers are removed from the chain when freed by gc. */
5587 break;
5589 case Lisp_Misc_Intfwd:
5590 case Lisp_Misc_Boolfwd:
5591 case Lisp_Misc_Objfwd:
5592 case Lisp_Misc_Buffer_Objfwd:
5593 case Lisp_Misc_Kboard_Objfwd:
5594 /* Don't bother with Lisp_Buffer_Objfwd,
5595 since all markable slots in current buffer marked anyway. */
5596 /* Don't need to do Lisp_Objfwd, since the places they point
5597 are protected with staticpro. */
5598 break;
5600 case Lisp_Misc_Save_Value:
5601 #if GC_MARK_STACK
5603 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
5604 /* If DOGC is set, POINTER is the address of a memory
5605 area containing INTEGER potential Lisp_Objects. */
5606 if (ptr->dogc)
5608 Lisp_Object *p = (Lisp_Object *) ptr->pointer;
5609 int nelt;
5610 for (nelt = ptr->integer; nelt > 0; nelt--, p++)
5611 mark_maybe_object (*p);
5614 #endif
5615 break;
5617 case Lisp_Misc_Overlay:
5619 struct Lisp_Overlay *ptr = XOVERLAY (obj);
5620 mark_object (ptr->start);
5621 mark_object (ptr->end);
5622 mark_object (ptr->plist);
5623 if (ptr->next)
5625 XSETMISC (obj, ptr->next);
5626 goto loop;
5629 break;
5631 default:
5632 abort ();
5634 break;
5636 case Lisp_Cons:
5638 register struct Lisp_Cons *ptr = XCONS (obj);
5639 if (CONS_MARKED_P (ptr)) break;
5640 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
5641 CONS_MARK (ptr);
5642 /* If the cdr is nil, avoid recursion for the car. */
5643 if (EQ (ptr->u.cdr, Qnil))
5645 obj = ptr->car;
5646 cdr_count = 0;
5647 goto loop;
5649 mark_object (ptr->car);
5650 obj = ptr->u.cdr;
5651 cdr_count++;
5652 if (cdr_count == mark_object_loop_halt)
5653 abort ();
5654 goto loop;
5657 case Lisp_Float:
5658 CHECK_ALLOCATED_AND_LIVE (live_float_p);
5659 FLOAT_MARK (XFLOAT (obj));
5660 break;
5662 case Lisp_Int:
5663 break;
5665 default:
5666 abort ();
5669 #undef CHECK_LIVE
5670 #undef CHECK_ALLOCATED
5671 #undef CHECK_ALLOCATED_AND_LIVE
5674 /* Mark the pointers in a buffer structure. */
5676 static void
5677 mark_buffer (buf)
5678 Lisp_Object buf;
5680 register struct buffer *buffer = XBUFFER (buf);
5681 register Lisp_Object *ptr, tmp;
5682 Lisp_Object base_buffer;
5684 VECTOR_MARK (buffer);
5686 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
5688 /* For now, we just don't mark the undo_list. It's done later in
5689 a special way just before the sweep phase, and after stripping
5690 some of its elements that are not needed any more. */
5692 if (buffer->overlays_before)
5694 XSETMISC (tmp, buffer->overlays_before);
5695 mark_object (tmp);
5697 if (buffer->overlays_after)
5699 XSETMISC (tmp, buffer->overlays_after);
5700 mark_object (tmp);
5703 /* buffer-local Lisp variables start at `undo_list',
5704 tho only the ones from `name' on are GC'd normally. */
5705 for (ptr = &buffer->name;
5706 (char *)ptr < (char *)buffer + sizeof (struct buffer);
5707 ptr++)
5708 mark_object (*ptr);
5710 /* If this is an indirect buffer, mark its base buffer. */
5711 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
5713 XSETBUFFER (base_buffer, buffer->base_buffer);
5714 mark_buffer (base_buffer);
5718 /* Mark the Lisp pointers in the terminal objects.
5719 Called by the Fgarbage_collector. */
5721 static void
5722 mark_terminals (void)
5724 struct terminal *t;
5725 for (t = terminal_list; t; t = t->next_terminal)
5727 eassert (t->name != NULL);
5728 #ifdef HAVE_WINDOW_SYSTEM
5729 mark_image_cache (t->image_cache);
5730 #endif /* HAVE_WINDOW_SYSTEM */
5731 mark_vectorlike ((struct Lisp_Vector *)t);
5737 /* Value is non-zero if OBJ will survive the current GC because it's
5738 either marked or does not need to be marked to survive. */
5741 survives_gc_p (obj)
5742 Lisp_Object obj;
5744 int survives_p;
5746 switch (XTYPE (obj))
5748 case Lisp_Int:
5749 survives_p = 1;
5750 break;
5752 case Lisp_Symbol:
5753 survives_p = XSYMBOL (obj)->gcmarkbit;
5754 break;
5756 case Lisp_Misc:
5757 survives_p = XMISCANY (obj)->gcmarkbit;
5758 break;
5760 case Lisp_String:
5761 survives_p = STRING_MARKED_P (XSTRING (obj));
5762 break;
5764 case Lisp_Vectorlike:
5765 survives_p = SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
5766 break;
5768 case Lisp_Cons:
5769 survives_p = CONS_MARKED_P (XCONS (obj));
5770 break;
5772 case Lisp_Float:
5773 survives_p = FLOAT_MARKED_P (XFLOAT (obj));
5774 break;
5776 default:
5777 abort ();
5780 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
5785 /* Sweep: find all structures not marked, and free them. */
5787 static void
5788 gc_sweep ()
5790 /* Remove or mark entries in weak hash tables.
5791 This must be done before any object is unmarked. */
5792 sweep_weak_hash_tables ();
5794 sweep_strings ();
5795 #ifdef GC_CHECK_STRING_BYTES
5796 if (!noninteractive)
5797 check_string_bytes (1);
5798 #endif
5800 /* Put all unmarked conses on free list */
5802 register struct cons_block *cblk;
5803 struct cons_block **cprev = &cons_block;
5804 register int lim = cons_block_index;
5805 register int num_free = 0, num_used = 0;
5807 cons_free_list = 0;
5809 for (cblk = cons_block; cblk; cblk = *cprev)
5811 register int i = 0;
5812 int this_free = 0;
5813 int ilim = (lim + BITS_PER_INT - 1) / BITS_PER_INT;
5815 /* Scan the mark bits an int at a time. */
5816 for (i = 0; i <= ilim; i++)
5818 if (cblk->gcmarkbits[i] == -1)
5820 /* Fast path - all cons cells for this int are marked. */
5821 cblk->gcmarkbits[i] = 0;
5822 num_used += BITS_PER_INT;
5824 else
5826 /* Some cons cells for this int are not marked.
5827 Find which ones, and free them. */
5828 int start, pos, stop;
5830 start = i * BITS_PER_INT;
5831 stop = lim - start;
5832 if (stop > BITS_PER_INT)
5833 stop = BITS_PER_INT;
5834 stop += start;
5836 for (pos = start; pos < stop; pos++)
5838 if (!CONS_MARKED_P (&cblk->conses[pos]))
5840 this_free++;
5841 cblk->conses[pos].u.chain = cons_free_list;
5842 cons_free_list = &cblk->conses[pos];
5843 #if GC_MARK_STACK
5844 cons_free_list->car = Vdead;
5845 #endif
5847 else
5849 num_used++;
5850 CONS_UNMARK (&cblk->conses[pos]);
5856 lim = CONS_BLOCK_SIZE;
5857 /* If this block contains only free conses and we have already
5858 seen more than two blocks worth of free conses then deallocate
5859 this block. */
5860 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
5862 *cprev = cblk->next;
5863 /* Unhook from the free list. */
5864 cons_free_list = cblk->conses[0].u.chain;
5865 lisp_align_free (cblk);
5866 n_cons_blocks--;
5868 else
5870 num_free += this_free;
5871 cprev = &cblk->next;
5874 total_conses = num_used;
5875 total_free_conses = num_free;
5878 /* Put all unmarked floats on free list */
5880 register struct float_block *fblk;
5881 struct float_block **fprev = &float_block;
5882 register int lim = float_block_index;
5883 register int num_free = 0, num_used = 0;
5885 float_free_list = 0;
5887 for (fblk = float_block; fblk; fblk = *fprev)
5889 register int i;
5890 int this_free = 0;
5891 for (i = 0; i < lim; i++)
5892 if (!FLOAT_MARKED_P (&fblk->floats[i]))
5894 this_free++;
5895 fblk->floats[i].u.chain = float_free_list;
5896 float_free_list = &fblk->floats[i];
5898 else
5900 num_used++;
5901 FLOAT_UNMARK (&fblk->floats[i]);
5903 lim = FLOAT_BLOCK_SIZE;
5904 /* If this block contains only free floats and we have already
5905 seen more than two blocks worth of free floats then deallocate
5906 this block. */
5907 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
5909 *fprev = fblk->next;
5910 /* Unhook from the free list. */
5911 float_free_list = fblk->floats[0].u.chain;
5912 lisp_align_free (fblk);
5913 n_float_blocks--;
5915 else
5917 num_free += this_free;
5918 fprev = &fblk->next;
5921 total_floats = num_used;
5922 total_free_floats = num_free;
5925 /* Put all unmarked intervals on free list */
5927 register struct interval_block *iblk;
5928 struct interval_block **iprev = &interval_block;
5929 register int lim = interval_block_index;
5930 register int num_free = 0, num_used = 0;
5932 interval_free_list = 0;
5934 for (iblk = interval_block; iblk; iblk = *iprev)
5936 register int i;
5937 int this_free = 0;
5939 for (i = 0; i < lim; i++)
5941 if (!iblk->intervals[i].gcmarkbit)
5943 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
5944 interval_free_list = &iblk->intervals[i];
5945 this_free++;
5947 else
5949 num_used++;
5950 iblk->intervals[i].gcmarkbit = 0;
5953 lim = INTERVAL_BLOCK_SIZE;
5954 /* If this block contains only free intervals and we have already
5955 seen more than two blocks worth of free intervals then
5956 deallocate this block. */
5957 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
5959 *iprev = iblk->next;
5960 /* Unhook from the free list. */
5961 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
5962 lisp_free (iblk);
5963 n_interval_blocks--;
5965 else
5967 num_free += this_free;
5968 iprev = &iblk->next;
5971 total_intervals = num_used;
5972 total_free_intervals = num_free;
5975 /* Put all unmarked symbols on free list */
5977 register struct symbol_block *sblk;
5978 struct symbol_block **sprev = &symbol_block;
5979 register int lim = symbol_block_index;
5980 register int num_free = 0, num_used = 0;
5982 symbol_free_list = NULL;
5984 for (sblk = symbol_block; sblk; sblk = *sprev)
5986 int this_free = 0;
5987 struct Lisp_Symbol *sym = sblk->symbols;
5988 struct Lisp_Symbol *end = sym + lim;
5990 for (; sym < end; ++sym)
5992 /* Check if the symbol was created during loadup. In such a case
5993 it might be pointed to by pure bytecode which we don't trace,
5994 so we conservatively assume that it is live. */
5995 int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
5997 if (!sym->gcmarkbit && !pure_p)
5999 sym->next = symbol_free_list;
6000 symbol_free_list = sym;
6001 #if GC_MARK_STACK
6002 symbol_free_list->function = Vdead;
6003 #endif
6004 ++this_free;
6006 else
6008 ++num_used;
6009 if (!pure_p)
6010 UNMARK_STRING (XSTRING (sym->xname));
6011 sym->gcmarkbit = 0;
6015 lim = SYMBOL_BLOCK_SIZE;
6016 /* If this block contains only free symbols and we have already
6017 seen more than two blocks worth of free symbols then deallocate
6018 this block. */
6019 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
6021 *sprev = sblk->next;
6022 /* Unhook from the free list. */
6023 symbol_free_list = sblk->symbols[0].next;
6024 lisp_free (sblk);
6025 n_symbol_blocks--;
6027 else
6029 num_free += this_free;
6030 sprev = &sblk->next;
6033 total_symbols = num_used;
6034 total_free_symbols = num_free;
6037 /* Put all unmarked misc's on free list.
6038 For a marker, first unchain it from the buffer it points into. */
6040 register struct marker_block *mblk;
6041 struct marker_block **mprev = &marker_block;
6042 register int lim = marker_block_index;
6043 register int num_free = 0, num_used = 0;
6045 marker_free_list = 0;
6047 for (mblk = marker_block; mblk; mblk = *mprev)
6049 register int i;
6050 int this_free = 0;
6052 for (i = 0; i < lim; i++)
6054 if (!mblk->markers[i].u_any.gcmarkbit)
6056 if (mblk->markers[i].u_any.type == Lisp_Misc_Marker)
6057 unchain_marker (&mblk->markers[i].u_marker);
6058 /* Set the type of the freed object to Lisp_Misc_Free.
6059 We could leave the type alone, since nobody checks it,
6060 but this might catch bugs faster. */
6061 mblk->markers[i].u_marker.type = Lisp_Misc_Free;
6062 mblk->markers[i].u_free.chain = marker_free_list;
6063 marker_free_list = &mblk->markers[i];
6064 this_free++;
6066 else
6068 num_used++;
6069 mblk->markers[i].u_any.gcmarkbit = 0;
6072 lim = MARKER_BLOCK_SIZE;
6073 /* If this block contains only free markers and we have already
6074 seen more than two blocks worth of free markers then deallocate
6075 this block. */
6076 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
6078 *mprev = mblk->next;
6079 /* Unhook from the free list. */
6080 marker_free_list = mblk->markers[0].u_free.chain;
6081 lisp_free (mblk);
6082 n_marker_blocks--;
6084 else
6086 num_free += this_free;
6087 mprev = &mblk->next;
6091 total_markers = num_used;
6092 total_free_markers = num_free;
6095 /* Free all unmarked buffers */
6097 register struct buffer *buffer = all_buffers, *prev = 0, *next;
6099 while (buffer)
6100 if (!VECTOR_MARKED_P (buffer))
6102 if (prev)
6103 prev->next = buffer->next;
6104 else
6105 all_buffers = buffer->next;
6106 next = buffer->next;
6107 lisp_free (buffer);
6108 buffer = next;
6110 else
6112 VECTOR_UNMARK (buffer);
6113 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
6114 prev = buffer, buffer = buffer->next;
6118 /* Free all unmarked vectors */
6120 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
6121 total_vector_size = 0;
6123 while (vector)
6124 if (!VECTOR_MARKED_P (vector))
6126 if (prev)
6127 prev->next = vector->next;
6128 else
6129 all_vectors = vector->next;
6130 next = vector->next;
6131 lisp_free (vector);
6132 n_vectors--;
6133 vector = next;
6136 else
6138 VECTOR_UNMARK (vector);
6139 if (vector->size & PSEUDOVECTOR_FLAG)
6140 total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
6141 else
6142 total_vector_size += vector->size;
6143 prev = vector, vector = vector->next;
6147 #ifdef GC_CHECK_STRING_BYTES
6148 if (!noninteractive)
6149 check_string_bytes (1);
6150 #endif
6156 /* Debugging aids. */
6158 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
6159 doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
6160 This may be helpful in debugging Emacs's memory usage.
6161 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
6164 Lisp_Object end;
6166 XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
6168 return end;
6171 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
6172 doc: /* Return a list of counters that measure how much consing there has been.
6173 Each of these counters increments for a certain kind of object.
6174 The counters wrap around from the largest positive integer to zero.
6175 Garbage collection does not decrease them.
6176 The elements of the value are as follows:
6177 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
6178 All are in units of 1 = one object consed
6179 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
6180 objects consed.
6181 MISCS include overlays, markers, and some internal types.
6182 Frames, windows, buffers, and subprocesses count as vectors
6183 (but the contents of a buffer's text do not count here). */)
6186 Lisp_Object consed[8];
6188 consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
6189 consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
6190 consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
6191 consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
6192 consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
6193 consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
6194 consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
6195 consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
6197 return Flist (8, consed);
6200 int suppress_checking;
6202 void
6203 die (msg, file, line)
6204 const char *msg;
6205 const char *file;
6206 int line;
6208 fprintf (stderr, "\r\n%s:%d: Emacs fatal error: %s\r\n",
6209 file, line, msg);
6210 abort ();
6213 /* Initialization */
6215 void
6216 init_alloc_once ()
6218 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
6219 purebeg = PUREBEG;
6220 pure_size = PURESIZE;
6221 pure_bytes_used = 0;
6222 pure_bytes_used_lisp = pure_bytes_used_non_lisp = 0;
6223 pure_bytes_used_before_overflow = 0;
6225 /* Initialize the list of free aligned blocks. */
6226 free_ablock = NULL;
6228 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
6229 mem_init ();
6230 Vdead = make_pure_string ("DEAD", 4, 4, 0);
6231 #endif
6233 all_vectors = 0;
6234 ignore_warnings = 1;
6235 #ifdef DOUG_LEA_MALLOC
6236 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
6237 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
6238 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
6239 #endif
6240 init_strings ();
6241 init_cons ();
6242 init_symbol ();
6243 init_marker ();
6244 init_float ();
6245 init_intervals ();
6247 #ifdef REL_ALLOC
6248 malloc_hysteresis = 32;
6249 #else
6250 malloc_hysteresis = 0;
6251 #endif
6253 refill_memory_reserve ();
6255 ignore_warnings = 0;
6256 gcprolist = 0;
6257 byte_stack_list = 0;
6258 staticidx = 0;
6259 consing_since_gc = 0;
6260 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
6261 gc_relative_threshold = 0;
6263 #ifdef VIRT_ADDR_VARIES
6264 malloc_sbrk_unused = 1<<22; /* A large number */
6265 malloc_sbrk_used = 100000; /* as reasonable as any number */
6266 #endif /* VIRT_ADDR_VARIES */
6269 void
6270 init_alloc ()
6272 gcprolist = 0;
6273 byte_stack_list = 0;
6274 #if GC_MARK_STACK
6275 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
6276 setjmp_tested_p = longjmps_done = 0;
6277 #endif
6278 #endif
6279 Vgc_elapsed = make_float (0.0);
6280 gcs_done = 0;
6283 void
6284 syms_of_alloc ()
6286 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
6287 doc: /* *Number of bytes of consing between garbage collections.
6288 Garbage collection can happen automatically once this many bytes have been
6289 allocated since the last garbage collection. All data types count.
6291 Garbage collection happens automatically only when `eval' is called.
6293 By binding this temporarily to a large number, you can effectively
6294 prevent garbage collection during a part of the program.
6295 See also `gc-cons-percentage'. */);
6297 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
6298 doc: /* *Portion of the heap used for allocation.
6299 Garbage collection can happen automatically once this portion of the heap
6300 has been allocated since the last garbage collection.
6301 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
6302 Vgc_cons_percentage = make_float (0.1);
6304 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
6305 doc: /* Number of bytes of sharable Lisp data allocated so far. */);
6307 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
6308 doc: /* Number of cons cells that have been consed so far. */);
6310 DEFVAR_INT ("floats-consed", &floats_consed,
6311 doc: /* Number of floats that have been consed so far. */);
6313 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
6314 doc: /* Number of vector cells that have been consed so far. */);
6316 DEFVAR_INT ("symbols-consed", &symbols_consed,
6317 doc: /* Number of symbols that have been consed so far. */);
6319 DEFVAR_INT ("string-chars-consed", &string_chars_consed,
6320 doc: /* Number of string characters that have been consed so far. */);
6322 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
6323 doc: /* Number of miscellaneous objects that have been consed so far. */);
6325 DEFVAR_INT ("intervals-consed", &intervals_consed,
6326 doc: /* Number of intervals that have been consed so far. */);
6328 DEFVAR_INT ("strings-consed", &strings_consed,
6329 doc: /* Number of strings that have been consed so far. */);
6331 DEFVAR_LISP ("purify-flag", &Vpurify_flag,
6332 doc: /* Non-nil means loading Lisp code in order to dump an executable.
6333 This means that certain objects should be allocated in shared (pure) space. */);
6335 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
6336 doc: /* Non-nil means display messages at start and end of garbage collection. */);
6337 garbage_collection_messages = 0;
6339 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
6340 doc: /* Hook run after garbage collection has finished. */);
6341 Vpost_gc_hook = Qnil;
6342 Qpost_gc_hook = intern ("post-gc-hook");
6343 staticpro (&Qpost_gc_hook);
6345 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
6346 doc: /* Precomputed `signal' argument for memory-full error. */);
6347 /* We build this in advance because if we wait until we need it, we might
6348 not be able to allocate the memory to hold it. */
6349 Vmemory_signal_data
6350 = list2 (Qerror,
6351 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
6353 DEFVAR_LISP ("memory-full", &Vmemory_full,
6354 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
6355 Vmemory_full = Qnil;
6357 staticpro (&Qgc_cons_threshold);
6358 Qgc_cons_threshold = intern ("gc-cons-threshold");
6360 staticpro (&Qchar_table_extra_slots);
6361 Qchar_table_extra_slots = intern ("char-table-extra-slots");
6363 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
6364 doc: /* Accumulated time elapsed in garbage collections.
6365 The time is in seconds as a floating point value. */);
6366 DEFVAR_INT ("gcs-done", &gcs_done,
6367 doc: /* Accumulated number of garbage collections done. */);
6369 defsubr (&Scons);
6370 defsubr (&Slist);
6371 defsubr (&Svector);
6372 defsubr (&Smake_byte_code);
6373 defsubr (&Smake_list);
6374 defsubr (&Smake_vector);
6375 defsubr (&Smake_string);
6376 defsubr (&Smake_bool_vector);
6377 defsubr (&Smake_symbol);
6378 defsubr (&Smake_marker);
6379 defsubr (&Spurecopy);
6380 defsubr (&Sgarbage_collect);
6381 defsubr (&Smemory_limit);
6382 defsubr (&Smemory_use_counts);
6384 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
6385 defsubr (&Sgc_status);
6386 #endif
6389 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
6390 (do not change this comment) */