1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Note that this declares bzero on OSF/1. How dumb. */
27 #include "intervals.h"
33 #include "blockinput.h"
38 #include "syssignal.h"
42 #ifdef DOUG_LEA_MALLOC
44 #define __malloc_size_t int
46 /* Specify maximum number of areas to mmap.
47 It would be nice to use a value that explicitly
49 #define MMAP_MAX_AREAS 100000000
52 /* The following come from gmalloc.c. */
54 #if defined (__STDC__) && __STDC__
56 #define __malloc_size_t size_t
58 #define __malloc_size_t unsigned int
60 extern __malloc_size_t _bytes_used
;
61 extern int __malloc_extra_blocks
;
62 #endif /* !defined(DOUG_LEA_MALLOC) */
64 #define max(A,B) ((A) > (B) ? (A) : (B))
65 #define min(A,B) ((A) < (B) ? (A) : (B))
67 /* Macro to verify that storage intended for Lisp objects is not
68 out of range to fit in the space for a pointer.
69 ADDRESS is the start of the block, and SIZE
70 is the amount of space within which objects can start. */
71 #define VALIDATE_LISP_STORAGE(address, size) \
75 XSETCONS (val, (char *) address + size); \
76 if ((char *) XCONS (val) != (char *) address + size) \
83 /* Value of _bytes_used, when spare_memory was freed. */
84 static __malloc_size_t bytes_used_when_full
;
86 /* Number of bytes of consing done since the last gc */
89 /* Count the amount of consing of various sorts of space. */
90 int cons_cells_consed
;
92 int vector_cells_consed
;
94 int string_chars_consed
;
95 int misc_objects_consed
;
98 /* Number of bytes of consing since gc before another gc should be done. */
99 int gc_cons_threshold
;
101 /* Nonzero during gc */
104 /* Nonzero means display messages at beginning and end of GC. */
105 int garbage_collection_messages
;
107 #ifndef VIRT_ADDR_VARIES
109 #endif /* VIRT_ADDR_VARIES */
110 int malloc_sbrk_used
;
112 #ifndef VIRT_ADDR_VARIES
114 #endif /* VIRT_ADDR_VARIES */
115 int malloc_sbrk_unused
;
117 /* Two limits controlling how much undo information to keep. */
119 int undo_strong_limit
;
121 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
122 int total_free_conses
, total_free_markers
, total_free_symbols
;
123 #ifdef LISP_FLOAT_TYPE
124 int total_free_floats
, total_floats
;
125 #endif /* LISP_FLOAT_TYPE */
127 /* Points to memory space allocated as "spare",
128 to be freed if we run out of memory. */
129 static char *spare_memory
;
131 /* Amount of spare memory to keep in reserve. */
132 #define SPARE_MEMORY (1 << 14)
134 /* Number of extra blocks malloc should get when it needs more core. */
135 static int malloc_hysteresis
;
137 /* Nonzero when malloc is called for allocating Lisp object space. */
138 int allocating_for_lisp
;
140 /* Non-nil means defun should do purecopy on the function definition */
141 Lisp_Object Vpurify_flag
;
144 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
145 #define PUREBEG (char *) pure
147 #define pure PURE_SEG_BITS /* Use shared memory segment */
148 #define PUREBEG (char *)PURE_SEG_BITS
150 /* This variable is used only by the XPNTR macro when HAVE_SHM is
151 defined. If we used the PURESIZE macro directly there, that would
152 make most of emacs dependent on puresize.h, which we don't want -
153 you should be able to change that without too much recompilation.
154 So map_in_data initializes pure_size, and the dependencies work
157 #endif /* not HAVE_SHM */
159 /* Index in pure at which next pure object will be allocated. */
162 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
163 char *pending_malloc_warning
;
165 /* Pre-computed signal argument for use when memory is exhausted. */
166 Lisp_Object memory_signal_data
;
168 /* Maximum amount of C stack to save when a GC happens. */
170 #ifndef MAX_SAVE_STACK
171 #define MAX_SAVE_STACK 16000
174 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
175 pointer to a Lisp_Object, when that pointer is viewed as an integer.
176 (On most machines, pointers are even, so we can use the low bit.
177 Word-addressable architectures may need to override this in the m-file.)
178 When linking references to small strings through the size field, we
179 use this slot to hold the bit that would otherwise be interpreted as
181 #ifndef DONT_COPY_FLAG
182 #define DONT_COPY_FLAG 1
183 #endif /* no DONT_COPY_FLAG */
185 /* Buffer in which we save a copy of the C stack at each GC. */
190 /* Non-zero means ignore malloc warnings. Set during initialization. */
193 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
195 static void mark_buffer (), mark_kboards ();
196 static void clear_marks (), gc_sweep ();
197 static void compact_strings ();
198 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
199 static void mark_face_cache
P_ ((struct face_cache
*));
201 #ifdef HAVE_WINDOW_SYSTEM
202 static void mark_image
P_ ((struct image
*));
203 static void mark_image_cache
P_ ((struct frame
*));
204 #endif /* HAVE_WINDOW_SYSTEM */
207 extern int message_enable_multibyte
;
209 /* Versions of malloc and realloc that print warnings as memory gets full. */
212 malloc_warning_1 (str
)
215 Fprinc (str
, Vstandard_output
);
216 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
217 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
218 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
222 /* malloc calls this if it finds we are near exhausting storage */
228 pending_malloc_warning
= str
;
232 display_malloc_warning ()
234 register Lisp_Object val
;
236 val
= build_string (pending_malloc_warning
);
237 pending_malloc_warning
= 0;
238 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
241 #ifdef DOUG_LEA_MALLOC
242 # define BYTES_USED (mallinfo ().arena)
244 # define BYTES_USED _bytes_used
247 /* Called if malloc returns zero */
252 #ifndef SYSTEM_MALLOC
253 bytes_used_when_full
= BYTES_USED
;
256 /* The first time we get here, free the spare memory. */
263 /* This used to call error, but if we've run out of memory, we could get
264 infinite recursion trying to build the string. */
266 Fsignal (Qnil
, memory_signal_data
);
269 /* Called if we can't allocate relocatable space for a buffer. */
272 buffer_memory_full ()
274 /* If buffers use the relocating allocator,
275 no need to free spare_memory, because we may have plenty of malloc
276 space left that we could get, and if we don't, the malloc that fails
277 will itself cause spare_memory to be freed.
278 If buffers don't use the relocating allocator,
279 treat this like any other failing malloc. */
285 /* This used to call error, but if we've run out of memory, we could get
286 infinite recursion trying to build the string. */
288 Fsignal (Qerror
, memory_signal_data
);
291 /* Like malloc routines but check for no memory and block interrupt input. */
300 val
= (long *) malloc (size
);
303 if (!val
&& size
) memory_full ();
308 xrealloc (block
, size
)
315 /* We must call malloc explicitly when BLOCK is 0, since some
316 reallocs don't do this. */
318 val
= (long *) malloc (size
);
320 val
= (long *) realloc (block
, size
);
323 if (!val
&& size
) memory_full ();
336 /* Like malloc but used for allocating Lisp data. */
345 allocating_for_lisp
++;
346 val
= (long *) malloc (size
);
347 allocating_for_lisp
--;
350 if (!val
&& size
) memory_full ();
359 allocating_for_lisp
++;
361 allocating_for_lisp
--;
365 /* Arranging to disable input signals while we're in malloc.
367 This only works with GNU malloc. To help out systems which can't
368 use GNU malloc, all the calls to malloc, realloc, and free
369 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
370 pairs; unfortunately, we have no idea what C library functions
371 might call malloc, so we can't really protect them unless you're
372 using GNU malloc. Fortunately, most of the major operating can use
375 #ifndef SYSTEM_MALLOC
376 extern void * (*__malloc_hook
) ();
377 static void * (*old_malloc_hook
) ();
378 extern void * (*__realloc_hook
) ();
379 static void * (*old_realloc_hook
) ();
380 extern void (*__free_hook
) ();
381 static void (*old_free_hook
) ();
383 /* This function is used as the hook for free to call. */
386 emacs_blocked_free (ptr
)
390 __free_hook
= old_free_hook
;
392 /* If we released our reserve (due to running out of memory),
393 and we have a fair amount free once again,
394 try to set aside another reserve in case we run out once more. */
395 if (spare_memory
== 0
396 /* Verify there is enough space that even with the malloc
397 hysteresis this call won't run out again.
398 The code here is correct as long as SPARE_MEMORY
399 is substantially larger than the block size malloc uses. */
400 && (bytes_used_when_full
401 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
402 spare_memory
= (char *) malloc (SPARE_MEMORY
);
404 __free_hook
= emacs_blocked_free
;
408 /* If we released our reserve (due to running out of memory),
409 and we have a fair amount free once again,
410 try to set aside another reserve in case we run out once more.
412 This is called when a relocatable block is freed in ralloc.c. */
415 refill_memory_reserve ()
417 if (spare_memory
== 0)
418 spare_memory
= (char *) malloc (SPARE_MEMORY
);
421 /* This function is the malloc hook that Emacs uses. */
424 emacs_blocked_malloc (size
)
430 __malloc_hook
= old_malloc_hook
;
431 #ifdef DOUG_LEA_MALLOC
432 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
434 __malloc_extra_blocks
= malloc_hysteresis
;
436 value
= (void *) malloc (size
);
437 __malloc_hook
= emacs_blocked_malloc
;
444 emacs_blocked_realloc (ptr
, size
)
451 __realloc_hook
= old_realloc_hook
;
452 value
= (void *) realloc (ptr
, size
);
453 __realloc_hook
= emacs_blocked_realloc
;
460 uninterrupt_malloc ()
462 if (__free_hook
!= emacs_blocked_free
)
463 old_free_hook
= __free_hook
;
464 __free_hook
= emacs_blocked_free
;
466 if (__malloc_hook
!= emacs_blocked_malloc
)
467 old_malloc_hook
= __malloc_hook
;
468 __malloc_hook
= emacs_blocked_malloc
;
470 if (__realloc_hook
!= emacs_blocked_realloc
)
471 old_realloc_hook
= __realloc_hook
;
472 __realloc_hook
= emacs_blocked_realloc
;
476 /* Interval allocation. */
478 #ifdef USE_TEXT_PROPERTIES
479 #define INTERVAL_BLOCK_SIZE \
480 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
482 struct interval_block
484 struct interval_block
*next
;
485 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
488 struct interval_block
*interval_block
;
489 static int interval_block_index
;
491 INTERVAL interval_free_list
;
493 /* Total number of interval blocks now in use. */
494 int n_interval_blocks
;
500 = (struct interval_block
*) lisp_malloc (sizeof (struct interval_block
));
501 interval_block
->next
= 0;
502 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
503 interval_block_index
= 0;
504 interval_free_list
= 0;
505 n_interval_blocks
= 1;
508 #define INIT_INTERVALS init_intervals ()
515 if (interval_free_list
)
517 val
= interval_free_list
;
518 interval_free_list
= interval_free_list
->parent
;
522 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
524 register struct interval_block
*newi
;
526 newi
= (struct interval_block
*) lisp_malloc (sizeof (struct interval_block
));
528 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
529 newi
->next
= interval_block
;
530 interval_block
= newi
;
531 interval_block_index
= 0;
534 val
= &interval_block
->intervals
[interval_block_index
++];
536 consing_since_gc
+= sizeof (struct interval
);
538 RESET_INTERVAL (val
);
542 static int total_free_intervals
, total_intervals
;
544 /* Mark the pointers of one interval. */
547 mark_interval (i
, dummy
)
551 if (XMARKBIT (i
->plist
))
553 mark_object (&i
->plist
);
558 mark_interval_tree (tree
)
559 register INTERVAL tree
;
561 /* No need to test if this tree has been marked already; this
562 function is always called through the MARK_INTERVAL_TREE macro,
563 which takes care of that. */
565 /* XMARK expands to an assignment; the LHS of an assignment can't be
567 XMARK (* (Lisp_Object
*) &tree
->parent
);
569 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
572 #define MARK_INTERVAL_TREE(i) \
574 if (!NULL_INTERVAL_P (i) \
575 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
576 mark_interval_tree (i); \
579 /* The oddity in the call to XUNMARK is necessary because XUNMARK
580 expands to an assignment to its argument, and most C compilers don't
581 support casts on the left operand of `='. */
582 #define UNMARK_BALANCE_INTERVALS(i) \
584 if (! NULL_INTERVAL_P (i)) \
586 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
587 (i) = balance_intervals (i); \
591 #else /* no interval use */
593 #define INIT_INTERVALS
595 #define UNMARK_BALANCE_INTERVALS(i)
596 #define MARK_INTERVAL_TREE(i)
598 #endif /* no interval use */
600 /* Floating point allocation. */
602 #ifdef LISP_FLOAT_TYPE
603 /* Allocation of float cells, just like conses */
604 /* We store float cells inside of float_blocks, allocating a new
605 float_block with malloc whenever necessary. Float cells reclaimed by
606 GC are put on a free list to be reallocated before allocating
607 any new float cells from the latest float_block.
609 Each float_block is just under 1020 bytes long,
610 since malloc really allocates in units of powers of two
611 and uses 4 bytes for its own overhead. */
613 #define FLOAT_BLOCK_SIZE \
614 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
618 struct float_block
*next
;
619 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
622 struct float_block
*float_block
;
623 int float_block_index
;
625 /* Total number of float blocks now in use. */
628 struct Lisp_Float
*float_free_list
;
633 float_block
= (struct float_block
*) lisp_malloc (sizeof (struct float_block
));
634 float_block
->next
= 0;
635 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
636 float_block_index
= 0;
641 /* Explicitly free a float cell. */
644 struct Lisp_Float
*ptr
;
646 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
647 float_free_list
= ptr
;
651 make_float (float_value
)
654 register Lisp_Object val
;
658 /* We use the data field for chaining the free list
659 so that we won't use the same field that has the mark bit. */
660 XSETFLOAT (val
, float_free_list
);
661 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
665 if (float_block_index
== FLOAT_BLOCK_SIZE
)
667 register struct float_block
*new;
669 new = (struct float_block
*) lisp_malloc (sizeof (struct float_block
));
670 VALIDATE_LISP_STORAGE (new, sizeof *new);
671 new->next
= float_block
;
673 float_block_index
= 0;
676 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
678 XFLOAT (val
)->data
= float_value
;
679 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
680 consing_since_gc
+= sizeof (struct Lisp_Float
);
685 #endif /* LISP_FLOAT_TYPE */
687 /* Allocation of cons cells */
688 /* We store cons cells inside of cons_blocks, allocating a new
689 cons_block with malloc whenever necessary. Cons cells reclaimed by
690 GC are put on a free list to be reallocated before allocating
691 any new cons cells from the latest cons_block.
693 Each cons_block is just under 1020 bytes long,
694 since malloc really allocates in units of powers of two
695 and uses 4 bytes for its own overhead. */
697 #define CONS_BLOCK_SIZE \
698 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
702 struct cons_block
*next
;
703 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
706 struct cons_block
*cons_block
;
707 int cons_block_index
;
709 struct Lisp_Cons
*cons_free_list
;
711 /* Total number of cons blocks now in use. */
717 cons_block
= (struct cons_block
*) lisp_malloc (sizeof (struct cons_block
));
718 cons_block
->next
= 0;
719 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
720 cons_block_index
= 0;
725 /* Explicitly free a cons cell. */
729 struct Lisp_Cons
*ptr
;
731 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
732 cons_free_list
= ptr
;
735 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
736 "Create a new cons, give it CAR and CDR as components, and return it.")
738 Lisp_Object car
, cdr
;
740 register Lisp_Object val
;
744 /* We use the cdr for chaining the free list
745 so that we won't use the same field that has the mark bit. */
746 XSETCONS (val
, cons_free_list
);
747 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
751 if (cons_block_index
== CONS_BLOCK_SIZE
)
753 register struct cons_block
*new;
754 new = (struct cons_block
*) lisp_malloc (sizeof (struct cons_block
));
755 VALIDATE_LISP_STORAGE (new, sizeof *new);
756 new->next
= cons_block
;
758 cons_block_index
= 0;
761 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
763 XCONS (val
)->car
= car
;
764 XCONS (val
)->cdr
= cdr
;
765 consing_since_gc
+= sizeof (struct Lisp_Cons
);
770 /* Make a list of 2, 3, 4 or 5 specified objects. */
774 Lisp_Object arg1
, arg2
;
776 return Fcons (arg1
, Fcons (arg2
, Qnil
));
780 list3 (arg1
, arg2
, arg3
)
781 Lisp_Object arg1
, arg2
, arg3
;
783 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
787 list4 (arg1
, arg2
, arg3
, arg4
)
788 Lisp_Object arg1
, arg2
, arg3
, arg4
;
790 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
794 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
795 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
797 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
798 Fcons (arg5
, Qnil
)))));
801 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
802 "Return a newly created list with specified arguments as elements.\n\
803 Any number of arguments, even zero arguments, are allowed.")
806 register Lisp_Object
*args
;
808 register Lisp_Object val
;
814 val
= Fcons (args
[nargs
], val
);
819 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
820 "Return a newly created list of length LENGTH, with each element being INIT.")
822 register Lisp_Object length
, init
;
824 register Lisp_Object val
;
827 CHECK_NATNUM (length
, 0);
828 size
= XFASTINT (length
);
832 val
= Fcons (init
, val
);
836 /* Allocation of vectors */
838 struct Lisp_Vector
*all_vectors
;
840 /* Total number of vectorlike objects now in use. */
844 allocate_vectorlike (len
)
847 struct Lisp_Vector
*p
;
849 #ifdef DOUG_LEA_MALLOC
850 /* Prevent mmap'ing the chunk (which is potentially very large). */
851 mallopt (M_MMAP_MAX
, 0);
853 p
= (struct Lisp_Vector
*)lisp_malloc (sizeof (struct Lisp_Vector
)
854 + (len
- 1) * sizeof (Lisp_Object
));
855 #ifdef DOUG_LEA_MALLOC
856 /* Back to a reasonable maximum of mmap'ed areas. */
857 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
859 VALIDATE_LISP_STORAGE (p
, 0);
860 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
861 + (len
- 1) * sizeof (Lisp_Object
));
862 vector_cells_consed
+= len
;
865 p
->next
= all_vectors
;
870 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
871 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
872 See also the function `vector'.")
874 register Lisp_Object length
, init
;
877 register EMACS_INT sizei
;
879 register struct Lisp_Vector
*p
;
881 CHECK_NATNUM (length
, 0);
882 sizei
= XFASTINT (length
);
884 p
= allocate_vectorlike (sizei
);
886 for (index
= 0; index
< sizei
; index
++)
887 p
->contents
[index
] = init
;
889 XSETVECTOR (vector
, p
);
893 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
894 "Return a newly created char-table, with purpose PURPOSE.\n\
895 Each element is initialized to INIT, which defaults to nil.\n\
896 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
897 The property's value should be an integer between 0 and 10.")
899 register Lisp_Object purpose
, init
;
903 CHECK_SYMBOL (purpose
, 1);
904 n
= Fget (purpose
, Qchar_table_extra_slots
);
906 if (XINT (n
) < 0 || XINT (n
) > 10)
907 args_out_of_range (n
, Qnil
);
908 /* Add 2 to the size for the defalt and parent slots. */
909 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
911 XCHAR_TABLE (vector
)->top
= Qt
;
912 XCHAR_TABLE (vector
)->parent
= Qnil
;
913 XCHAR_TABLE (vector
)->purpose
= purpose
;
914 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
918 /* Return a newly created sub char table with default value DEFALT.
919 Since a sub char table does not appear as a top level Emacs Lisp
920 object, we don't need a Lisp interface to make it. */
923 make_sub_char_table (defalt
)
927 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
928 XCHAR_TABLE (vector
)->top
= Qnil
;
929 XCHAR_TABLE (vector
)->defalt
= defalt
;
930 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
934 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
935 "Return a newly created vector with specified arguments as elements.\n\
936 Any number of arguments, even zero arguments, are allowed.")
941 register Lisp_Object len
, val
;
943 register struct Lisp_Vector
*p
;
945 XSETFASTINT (len
, nargs
);
946 val
= Fmake_vector (len
, Qnil
);
948 for (index
= 0; index
< nargs
; index
++)
949 p
->contents
[index
] = args
[index
];
953 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
954 "Create a byte-code object with specified arguments as elements.\n\
955 The arguments should be the arglist, bytecode-string, constant vector,\n\
956 stack size, (optional) doc string, and (optional) interactive spec.\n\
957 The first four arguments are required; at most six have any\n\
963 register Lisp_Object len
, val
;
965 register struct Lisp_Vector
*p
;
967 XSETFASTINT (len
, nargs
);
968 if (!NILP (Vpurify_flag
))
969 val
= make_pure_vector ((EMACS_INT
) nargs
);
971 val
= Fmake_vector (len
, Qnil
);
973 for (index
= 0; index
< nargs
; index
++)
975 if (!NILP (Vpurify_flag
))
976 args
[index
] = Fpurecopy (args
[index
]);
977 p
->contents
[index
] = args
[index
];
979 XSETCOMPILED (val
, p
);
983 /* Allocation of symbols.
984 Just like allocation of conses!
986 Each symbol_block is just under 1020 bytes long,
987 since malloc really allocates in units of powers of two
988 and uses 4 bytes for its own overhead. */
990 #define SYMBOL_BLOCK_SIZE \
991 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
995 struct symbol_block
*next
;
996 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
999 struct symbol_block
*symbol_block
;
1000 int symbol_block_index
;
1002 struct Lisp_Symbol
*symbol_free_list
;
1004 /* Total number of symbol blocks now in use. */
1005 int n_symbol_blocks
;
1010 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof (struct symbol_block
));
1011 symbol_block
->next
= 0;
1012 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
1013 symbol_block_index
= 0;
1014 symbol_free_list
= 0;
1015 n_symbol_blocks
= 1;
1018 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
1019 "Return a newly allocated uninterned symbol whose name is NAME.\n\
1020 Its value and function definition are void, and its property list is nil.")
1024 register Lisp_Object val
;
1025 register struct Lisp_Symbol
*p
;
1027 CHECK_STRING (name
, 0);
1029 if (symbol_free_list
)
1031 XSETSYMBOL (val
, symbol_free_list
);
1032 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
1036 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
1038 struct symbol_block
*new;
1039 new = (struct symbol_block
*) lisp_malloc (sizeof (struct symbol_block
));
1040 VALIDATE_LISP_STORAGE (new, sizeof *new);
1041 new->next
= symbol_block
;
1043 symbol_block_index
= 0;
1046 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
1049 p
->name
= XSTRING (name
);
1052 p
->value
= Qunbound
;
1053 p
->function
= Qunbound
;
1055 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
1060 /* Allocation of markers and other objects that share that structure.
1061 Works like allocation of conses. */
1063 #define MARKER_BLOCK_SIZE \
1064 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
1068 struct marker_block
*next
;
1069 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
1072 struct marker_block
*marker_block
;
1073 int marker_block_index
;
1075 union Lisp_Misc
*marker_free_list
;
1077 /* Total number of marker blocks now in use. */
1078 int n_marker_blocks
;
1083 marker_block
= (struct marker_block
*) lisp_malloc (sizeof (struct marker_block
));
1084 marker_block
->next
= 0;
1085 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1086 marker_block_index
= 0;
1087 marker_free_list
= 0;
1088 n_marker_blocks
= 1;
1091 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1097 if (marker_free_list
)
1099 XSETMISC (val
, marker_free_list
);
1100 marker_free_list
= marker_free_list
->u_free
.chain
;
1104 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1106 struct marker_block
*new;
1107 new = (struct marker_block
*) lisp_malloc (sizeof (struct marker_block
));
1108 VALIDATE_LISP_STORAGE (new, sizeof *new);
1109 new->next
= marker_block
;
1111 marker_block_index
= 0;
1114 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1116 consing_since_gc
+= sizeof (union Lisp_Misc
);
1117 misc_objects_consed
++;
1121 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1122 "Return a newly allocated marker which does not point at any place.")
1125 register Lisp_Object val
;
1126 register struct Lisp_Marker
*p
;
1128 val
= allocate_misc ();
1129 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1135 p
->insertion_type
= 0;
1139 /* Put MARKER back on the free list after using it temporarily. */
1142 free_marker (marker
)
1145 unchain_marker (marker
);
1147 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1148 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1149 marker_free_list
= XMISC (marker
);
1151 total_free_markers
++;
1154 /* Allocation of strings */
1156 /* Strings reside inside of string_blocks. The entire data of the string,
1157 both the size and the contents, live in part of the `chars' component of a string_block.
1158 The `pos' component is the index within `chars' of the first free byte.
1160 first_string_block points to the first string_block ever allocated.
1161 Each block points to the next one with its `next' field.
1162 The `prev' fields chain in reverse order.
1163 The last one allocated is the one currently being filled.
1164 current_string_block points to it.
1166 The string_blocks that hold individual large strings
1167 go in a separate chain, started by large_string_blocks. */
1170 /* String blocks contain this many useful bytes.
1171 8188 is power of 2, minus 4 for malloc overhead. */
1172 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1174 /* A string bigger than this gets its own specially-made string block
1175 if it doesn't fit in the current one. */
1176 #define STRING_BLOCK_OUTSIZE 1024
1178 struct string_block_head
1180 struct string_block
*next
, *prev
;
1186 struct string_block
*next
, *prev
;
1188 char chars
[STRING_BLOCK_SIZE
];
1191 /* This points to the string block we are now allocating strings. */
1193 struct string_block
*current_string_block
;
1195 /* This points to the oldest string block, the one that starts the chain. */
1197 struct string_block
*first_string_block
;
1199 /* Last string block in chain of those made for individual large strings. */
1201 struct string_block
*large_string_blocks
;
1203 /* If SIZE is the length of a string, this returns how many bytes
1204 the string occupies in a string_block (including padding). */
1206 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1207 & ~(STRING_PAD - 1))
1208 /* Add 1 for the null terminator,
1209 and add STRING_PAD - 1 as part of rounding up. */
1211 #define STRING_PAD (sizeof (EMACS_INT))
1212 /* Size of the stuff in the string not including its data. */
1213 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1216 #define STRING_FULLSIZE(SIZE) \
1217 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1220 /* Total number of string blocks now in use. */
1221 int n_string_blocks
;
1226 current_string_block
= (struct string_block
*) lisp_malloc (sizeof (struct string_block
));
1227 first_string_block
= current_string_block
;
1228 consing_since_gc
+= sizeof (struct string_block
);
1229 current_string_block
->next
= 0;
1230 current_string_block
->prev
= 0;
1231 current_string_block
->pos
= 0;
1232 large_string_blocks
= 0;
1233 n_string_blocks
= 1;
1236 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1237 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1238 Both LENGTH and INIT must be numbers.")
1240 Lisp_Object length
, init
;
1242 register Lisp_Object val
;
1243 register unsigned char *p
, *end
;
1246 CHECK_NATNUM (length
, 0);
1247 CHECK_NUMBER (init
, 1);
1250 if (SINGLE_BYTE_CHAR_P (c
))
1252 nbytes
= XINT (length
);
1253 val
= make_uninit_string (nbytes
);
1254 p
= XSTRING (val
)->data
;
1255 end
= p
+ XSTRING (val
)->size
;
1261 unsigned char work
[4], *str
;
1262 int len
= CHAR_STRING (c
, work
, str
);
1264 nbytes
= len
* XINT (length
);
1265 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1266 p
= XSTRING (val
)->data
;
1270 bcopy (str
, p
, len
);
1278 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1279 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1280 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1282 Lisp_Object length
, init
;
1284 register Lisp_Object val
;
1285 struct Lisp_Bool_Vector
*p
;
1287 int length_in_chars
, length_in_elts
, bits_per_value
;
1289 CHECK_NATNUM (length
, 0);
1291 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1293 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1294 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1296 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1297 slot `size' of the struct Lisp_Bool_Vector. */
1298 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1299 p
= XBOOL_VECTOR (val
);
1300 /* Get rid of any bits that would cause confusion. */
1302 XSETBOOL_VECTOR (val
, p
);
1303 p
->size
= XFASTINT (length
);
1305 real_init
= (NILP (init
) ? 0 : -1);
1306 for (i
= 0; i
< length_in_chars
; i
++)
1307 p
->data
[i
] = real_init
;
1308 /* Clear the extraneous bits in the last byte. */
1309 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1310 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1311 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1316 /* Make a string from NBYTES bytes at CONTENTS,
1317 and compute the number of characters from the contents.
1318 This string may be unibyte or multibyte, depending on the contents. */
1321 make_string (contents
, nbytes
)
1325 register Lisp_Object val
;
1326 int nchars
= chars_in_text (contents
, nbytes
);
1327 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1328 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1329 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1330 SET_STRING_BYTES (XSTRING (val
), -1);
1334 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
1337 make_unibyte_string (contents
, length
)
1341 register Lisp_Object val
;
1342 val
= make_uninit_string (length
);
1343 bcopy (contents
, XSTRING (val
)->data
, length
);
1344 SET_STRING_BYTES (XSTRING (val
), -1);
1348 /* Make a multibyte string from NCHARS characters
1349 occupying NBYTES bytes at CONTENTS. */
1352 make_multibyte_string (contents
, nchars
, nbytes
)
1356 register Lisp_Object val
;
1357 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1358 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1362 /* Make a string from NCHARS characters
1363 occupying NBYTES bytes at CONTENTS.
1364 It is a multibyte string if NBYTES != NCHARS. */
1367 make_string_from_bytes (contents
, nchars
, nbytes
)
1371 register Lisp_Object val
;
1372 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1373 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1374 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1375 SET_STRING_BYTES (XSTRING (val
), -1);
1379 /* Make a multibyte string from NCHARS characters
1380 occupying NBYTES bytes at CONTENTS. */
1383 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1388 register Lisp_Object val
;
1389 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1390 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1392 SET_STRING_BYTES (XSTRING (val
), -1);
1396 /* Make a string from the data at STR,
1397 treating it as multibyte if the data warrants. */
1403 return make_string (str
, strlen (str
));
1407 make_uninit_string (length
)
1411 val
= make_uninit_multibyte_string (length
, length
);
1412 SET_STRING_BYTES (XSTRING (val
), -1);
1417 make_uninit_multibyte_string (length
, length_byte
)
1418 int length
, length_byte
;
1420 register Lisp_Object val
;
1421 register int fullsize
= STRING_FULLSIZE (length_byte
);
1423 if (length
< 0) abort ();
1425 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1426 /* This string can fit in the current string block */
1429 ((struct Lisp_String
*)
1430 (current_string_block
->chars
+ current_string_block
->pos
)));
1431 current_string_block
->pos
+= fullsize
;
1433 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1434 /* This string gets its own string block */
1436 register struct string_block
*new;
1437 #ifdef DOUG_LEA_MALLOC
1438 /* Prevent mmap'ing the chunk (which is potentially very large). */
1439 mallopt (M_MMAP_MAX
, 0);
1441 new = (struct string_block
*) lisp_malloc (sizeof (struct string_block_head
) + fullsize
);
1442 #ifdef DOUG_LEA_MALLOC
1443 /* Back to a reasonable maximum of mmap'ed areas. */
1444 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1447 VALIDATE_LISP_STORAGE (new, 0);
1448 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1449 new->pos
= fullsize
;
1450 new->next
= large_string_blocks
;
1451 large_string_blocks
= new;
1453 ((struct Lisp_String
*)
1454 ((struct string_block_head
*)new + 1)));
1457 /* Make a new current string block and start it off with this string */
1459 register struct string_block
*new;
1460 new = (struct string_block
*) lisp_malloc (sizeof (struct string_block
));
1462 VALIDATE_LISP_STORAGE (new, sizeof *new);
1463 consing_since_gc
+= sizeof (struct string_block
);
1464 current_string_block
->next
= new;
1465 new->prev
= current_string_block
;
1467 current_string_block
= new;
1468 new->pos
= fullsize
;
1470 (struct Lisp_String
*) current_string_block
->chars
);
1473 string_chars_consed
+= fullsize
;
1474 XSTRING (val
)->size
= length
;
1475 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1476 XSTRING (val
)->data
[length_byte
] = 0;
1477 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1482 /* Return a newly created vector or string with specified arguments as
1483 elements. If all the arguments are characters that can fit
1484 in a string of events, make a string; otherwise, make a vector.
1486 Any number of arguments, even zero arguments, are allowed. */
1489 make_event_array (nargs
, args
)
1495 for (i
= 0; i
< nargs
; i
++)
1496 /* The things that fit in a string
1497 are characters that are in 0...127,
1498 after discarding the meta bit and all the bits above it. */
1499 if (!INTEGERP (args
[i
])
1500 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1501 return Fvector (nargs
, args
);
1503 /* Since the loop exited, we know that all the things in it are
1504 characters, so we can make a string. */
1508 result
= Fmake_string (make_number (nargs
), make_number (0));
1509 for (i
= 0; i
< nargs
; i
++)
1511 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1512 /* Move the meta bit to the right place for a string char. */
1513 if (XINT (args
[i
]) & CHAR_META
)
1514 XSTRING (result
)->data
[i
] |= 0x80;
1521 /* Pure storage management. */
1523 /* Must get an error if pure storage is full,
1524 since if it cannot hold a large string
1525 it may be able to hold conses that point to that string;
1526 then the string is not protected from gc. */
1529 make_pure_string (data
, length
, length_byte
, multibyte
)
1536 register Lisp_Object
new;
1537 register int size
= STRING_FULLSIZE (length_byte
);
1539 if (pureptr
+ size
> PURESIZE
)
1540 error ("Pure Lisp storage exhausted");
1541 XSETSTRING (new, PUREBEG
+ pureptr
);
1542 XSTRING (new)->size
= length
;
1543 SET_STRING_BYTES (XSTRING (new), (multibyte
? length_byte
: -1));
1544 bcopy (data
, XSTRING (new)->data
, length_byte
);
1545 XSTRING (new)->data
[length_byte
] = 0;
1547 /* We must give strings in pure storage some kind of interval. So we
1548 give them a null one. */
1549 #if defined (USE_TEXT_PROPERTIES)
1550 XSTRING (new)->intervals
= NULL_INTERVAL
;
1557 pure_cons (car
, cdr
)
1558 Lisp_Object car
, cdr
;
1560 register Lisp_Object
new;
1562 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1563 error ("Pure Lisp storage exhausted");
1564 XSETCONS (new, PUREBEG
+ pureptr
);
1565 pureptr
+= sizeof (struct Lisp_Cons
);
1566 XCONS (new)->car
= Fpurecopy (car
);
1567 XCONS (new)->cdr
= Fpurecopy (cdr
);
1571 #ifdef LISP_FLOAT_TYPE
1574 make_pure_float (num
)
1577 register Lisp_Object
new;
1579 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1580 (double) boundary. Some architectures (like the sparc) require
1581 this, and I suspect that floats are rare enough that it's no
1582 tragedy for those that do. */
1585 char *p
= PUREBEG
+ pureptr
;
1589 alignment
= __alignof (struct Lisp_Float
);
1591 alignment
= sizeof (struct Lisp_Float
);
1594 alignment
= sizeof (struct Lisp_Float
);
1596 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1597 pureptr
= p
- PUREBEG
;
1600 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1601 error ("Pure Lisp storage exhausted");
1602 XSETFLOAT (new, PUREBEG
+ pureptr
);
1603 pureptr
+= sizeof (struct Lisp_Float
);
1604 XFLOAT (new)->data
= num
;
1605 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1609 #endif /* LISP_FLOAT_TYPE */
1612 make_pure_vector (len
)
1615 register Lisp_Object
new;
1616 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1618 if (pureptr
+ size
> PURESIZE
)
1619 error ("Pure Lisp storage exhausted");
1621 XSETVECTOR (new, PUREBEG
+ pureptr
);
1623 XVECTOR (new)->size
= len
;
1627 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1628 "Make a copy of OBJECT in pure storage.\n\
1629 Recursively copies contents of vectors and cons cells.\n\
1630 Does not copy symbols.")
1632 register Lisp_Object obj
;
1634 if (NILP (Vpurify_flag
))
1637 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1638 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1642 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1643 #ifdef LISP_FLOAT_TYPE
1644 else if (FLOATP (obj
))
1645 return make_pure_float (XFLOAT (obj
)->data
);
1646 #endif /* LISP_FLOAT_TYPE */
1647 else if (STRINGP (obj
))
1648 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1649 STRING_BYTES (XSTRING (obj
)),
1650 STRING_MULTIBYTE (obj
));
1651 else if (COMPILEDP (obj
) || VECTORP (obj
))
1653 register struct Lisp_Vector
*vec
;
1654 register int i
, size
;
1656 size
= XVECTOR (obj
)->size
;
1657 if (size
& PSEUDOVECTOR_FLAG
)
1658 size
&= PSEUDOVECTOR_SIZE_MASK
;
1659 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1660 for (i
= 0; i
< size
; i
++)
1661 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1662 if (COMPILEDP (obj
))
1663 XSETCOMPILED (obj
, vec
);
1665 XSETVECTOR (obj
, vec
);
1668 else if (MARKERP (obj
))
1669 error ("Attempt to copy a marker to pure storage");
1674 /* Recording what needs to be marked for gc. */
1676 struct gcpro
*gcprolist
;
1678 #define NSTATICS 1024
1680 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1684 /* Put an entry in staticvec, pointing at the variable whose address is given */
1687 staticpro (varaddress
)
1688 Lisp_Object
*varaddress
;
1690 staticvec
[staticidx
++] = varaddress
;
1691 if (staticidx
>= NSTATICS
)
1699 struct catchtag
*next
;
1700 #if 0 /* We don't need this for GC purposes */
1707 struct backtrace
*next
;
1708 Lisp_Object
*function
;
1709 Lisp_Object
*args
; /* Points to vector of args. */
1710 int nargs
; /* length of vector */
1711 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1715 /* Garbage collection! */
1717 /* Temporarily prevent garbage collection. */
1720 inhibit_garbage_collection ()
1722 int count
= specpdl_ptr
- specpdl
;
1724 int nbits
= min (VALBITS
, BITS_PER_INT
);
1726 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1728 specbind (Qgc_cons_threshold
, number
);
1733 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1734 "Reclaim storage for Lisp objects no longer needed.\n\
1735 Returns info on amount of space in use:\n\
1736 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1737 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1738 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1739 Garbage collection happens automatically if you cons more than\n\
1740 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1743 register struct gcpro
*tail
;
1744 register struct specbinding
*bind
;
1745 struct catchtag
*catch;
1746 struct handler
*handler
;
1747 register struct backtrace
*backlist
;
1748 register Lisp_Object tem
;
1749 char *omessage
= echo_area_glyphs
;
1750 Lisp_Object omessage_string
= echo_area_message
;
1751 int omessage_length
= echo_area_glyphs_length
;
1752 int oldmultibyte
= message_enable_multibyte
;
1753 char stack_top_variable
;
1755 struct gcpro gcpro1
;
1757 /* In case user calls debug_print during GC,
1758 don't let that cause a recursive GC. */
1759 consing_since_gc
= 0;
1761 GCPRO1 (omessage_string
);
1763 /* Save a copy of the contents of the stack, for debugging. */
1764 #if MAX_SAVE_STACK > 0
1765 if (NILP (Vpurify_flag
))
1767 i
= &stack_top_variable
- stack_bottom
;
1769 if (i
< MAX_SAVE_STACK
)
1771 if (stack_copy
== 0)
1772 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1773 else if (stack_copy_size
< i
)
1774 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1777 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1778 bcopy (stack_bottom
, stack_copy
, i
);
1780 bcopy (&stack_top_variable
, stack_copy
, i
);
1784 #endif /* MAX_SAVE_STACK > 0 */
1786 if (garbage_collection_messages
)
1787 message1_nolog ("Garbage collecting...");
1791 shrink_regexp_cache ();
1793 /* Don't keep undo information around forever. */
1795 register struct buffer
*nextb
= all_buffers
;
1799 /* If a buffer's undo list is Qt, that means that undo is
1800 turned off in that buffer. Calling truncate_undo_list on
1801 Qt tends to return NULL, which effectively turns undo back on.
1802 So don't call truncate_undo_list if undo_list is Qt. */
1803 if (! EQ (nextb
->undo_list
, Qt
))
1805 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1807 nextb
= nextb
->next
;
1813 /* clear_marks (); */
1815 /* In each "large string", set the MARKBIT of the size field.
1816 That enables mark_object to recognize them. */
1818 register struct string_block
*b
;
1819 for (b
= large_string_blocks
; b
; b
= b
->next
)
1820 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1823 /* Mark all the special slots that serve as the roots of accessibility.
1825 Usually the special slots to mark are contained in particular structures.
1826 Then we know no slot is marked twice because the structures don't overlap.
1827 In some cases, the structures point to the slots to be marked.
1828 For these, we use MARKBIT to avoid double marking of the slot. */
1830 for (i
= 0; i
< staticidx
; i
++)
1831 mark_object (staticvec
[i
]);
1832 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1833 for (i
= 0; i
< tail
->nvars
; i
++)
1834 if (!XMARKBIT (tail
->var
[i
]))
1836 mark_object (&tail
->var
[i
]);
1837 XMARK (tail
->var
[i
]);
1839 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1841 mark_object (&bind
->symbol
);
1842 mark_object (&bind
->old_value
);
1844 for (catch = catchlist
; catch; catch = catch->next
)
1846 mark_object (&catch->tag
);
1847 mark_object (&catch->val
);
1849 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1851 mark_object (&handler
->handler
);
1852 mark_object (&handler
->var
);
1854 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1856 if (!XMARKBIT (*backlist
->function
))
1858 mark_object (backlist
->function
);
1859 XMARK (*backlist
->function
);
1861 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1864 i
= backlist
->nargs
- 1;
1866 if (!XMARKBIT (backlist
->args
[i
]))
1868 mark_object (&backlist
->args
[i
]);
1869 XMARK (backlist
->args
[i
]);
1874 /* Look thru every buffer's undo list
1875 for elements that update markers that were not marked,
1878 register struct buffer
*nextb
= all_buffers
;
1882 /* If a buffer's undo list is Qt, that means that undo is
1883 turned off in that buffer. Calling truncate_undo_list on
1884 Qt tends to return NULL, which effectively turns undo back on.
1885 So don't call truncate_undo_list if undo_list is Qt. */
1886 if (! EQ (nextb
->undo_list
, Qt
))
1888 Lisp_Object tail
, prev
;
1889 tail
= nextb
->undo_list
;
1891 while (CONSP (tail
))
1893 if (GC_CONSP (XCONS (tail
)->car
)
1894 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1895 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1898 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1900 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1905 tail
= XCONS (tail
)->cdr
;
1910 nextb
= nextb
->next
;
1916 /* Clear the mark bits that we set in certain root slots. */
1918 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1919 for (i
= 0; i
< tail
->nvars
; i
++)
1920 XUNMARK (tail
->var
[i
]);
1921 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1923 XUNMARK (*backlist
->function
);
1924 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1927 i
= backlist
->nargs
- 1;
1929 XUNMARK (backlist
->args
[i
]);
1931 XUNMARK (buffer_defaults
.name
);
1932 XUNMARK (buffer_local_symbols
.name
);
1936 /* clear_marks (); */
1939 consing_since_gc
= 0;
1940 if (gc_cons_threshold
< 10000)
1941 gc_cons_threshold
= 10000;
1943 if (garbage_collection_messages
)
1945 if (STRINGP (omessage_string
))
1946 message3_nolog (omessage_string
, omessage_length
, oldmultibyte
);
1947 if (omessage
|| minibuf_level
> 0)
1948 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1950 message1_nolog ("Garbage collecting...done");
1954 return Fcons (Fcons (make_number (total_conses
),
1955 make_number (total_free_conses
)),
1956 Fcons (Fcons (make_number (total_symbols
),
1957 make_number (total_free_symbols
)),
1958 Fcons (Fcons (make_number (total_markers
),
1959 make_number (total_free_markers
)),
1960 Fcons (make_number (total_string_size
),
1961 Fcons (make_number (total_vector_size
),
1963 #ifdef LISP_FLOAT_TYPE
1964 (make_number (total_floats
),
1965 make_number (total_free_floats
)),
1966 #else /* not LISP_FLOAT_TYPE */
1967 (make_number (0), make_number (0)),
1968 #endif /* not LISP_FLOAT_TYPE */
1970 #ifdef USE_TEXT_PROPERTIES
1971 (make_number (total_intervals
),
1972 make_number (total_free_intervals
)),
1973 #else /* not USE_TEXT_PROPERTIES */
1974 (make_number (0), make_number (0)),
1975 #endif /* not USE_TEXT_PROPERTIES */
1983 /* Clear marks on all conses */
1985 register struct cons_block
*cblk
;
1986 register int lim
= cons_block_index
;
1988 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1991 for (i
= 0; i
< lim
; i
++)
1992 XUNMARK (cblk
->conses
[i
].car
);
1993 lim
= CONS_BLOCK_SIZE
;
1996 /* Clear marks on all symbols */
1998 register struct symbol_block
*sblk
;
1999 register int lim
= symbol_block_index
;
2001 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2004 for (i
= 0; i
< lim
; i
++)
2006 XUNMARK (sblk
->symbols
[i
].plist
);
2008 lim
= SYMBOL_BLOCK_SIZE
;
2011 /* Clear marks on all markers */
2013 register struct marker_block
*sblk
;
2014 register int lim
= marker_block_index
;
2016 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
2019 for (i
= 0; i
< lim
; i
++)
2020 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2021 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
2022 lim
= MARKER_BLOCK_SIZE
;
2025 /* Clear mark bits on all buffers */
2027 register struct buffer
*nextb
= all_buffers
;
2031 XUNMARK (nextb
->name
);
2032 nextb
= nextb
->next
;
2038 /* Mark Lisp objects in glyph matrix MATRIX. */
2041 mark_glyph_matrix (matrix
)
2042 struct glyph_matrix
*matrix
;
2044 struct glyph_row
*row
= matrix
->rows
;
2045 struct glyph_row
*end
= row
+ matrix
->nrows
;
2052 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
2054 struct glyph
*glyph
= row
->glyphs
[area
];
2055 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
2057 while (glyph
< end_glyph
)
2059 if (/* OBJECT Is zero for face extending glyphs, padding
2062 /* Marking the buffer itself should not be necessary. */
2063 && !BUFFERP (glyph
->object
))
2064 mark_object (&glyph
->object
);
2074 /* Mark Lisp faces in the face cache C. */
2078 struct face_cache
*c
;
2083 for (i
= 0; i
< c
->used
; ++i
)
2085 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
2089 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
2090 mark_object (&face
->lface
[j
]);
2091 mark_object (&face
->registry
);
2098 #ifdef HAVE_WINDOW_SYSTEM
2100 /* Mark Lisp objects in image IMG. */
2106 mark_object (&img
->spec
);
2108 if (!NILP (img
->data
.lisp_val
))
2109 mark_object (&img
->data
.lisp_val
);
2113 /* Mark Lisp objects in image cache of frame F. It's done this way so
2114 that we don't have to include xterm.h here. */
2117 mark_image_cache (f
)
2120 forall_images_in_image_cache (f
, mark_image
);
2123 #endif /* HAVE_X_WINDOWS */
2127 /* Mark reference to a Lisp_Object.
2128 If the object referred to has not been seen yet, recursively mark
2129 all the references contained in it.
2131 If the object referenced is a short string, the referencing slot
2132 is threaded into a chain of such slots, pointed to from
2133 the `size' field of the string. The actual string size
2134 lives in the last slot in the chain. We recognize the end
2135 because it is < (unsigned) STRING_BLOCK_SIZE. */
2137 #define LAST_MARKED_SIZE 500
2138 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
2139 int last_marked_index
;
2142 mark_object (argptr
)
2143 Lisp_Object
*argptr
;
2145 Lisp_Object
*objptr
= argptr
;
2146 register Lisp_Object obj
;
2153 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2154 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2157 last_marked
[last_marked_index
++] = objptr
;
2158 if (last_marked_index
== LAST_MARKED_SIZE
)
2159 last_marked_index
= 0;
2161 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2165 register struct Lisp_String
*ptr
= XSTRING (obj
);
2167 MARK_INTERVAL_TREE (ptr
->intervals
);
2168 if (ptr
->size
& MARKBIT
)
2169 /* A large string. Just set ARRAY_MARK_FLAG. */
2170 ptr
->size
|= ARRAY_MARK_FLAG
;
2173 /* A small string. Put this reference
2174 into the chain of references to it.
2175 If the address includes MARKBIT, put that bit elsewhere
2176 when we store OBJPTR into the size field. */
2178 if (XMARKBIT (*objptr
))
2180 XSETFASTINT (*objptr
, ptr
->size
);
2184 XSETFASTINT (*objptr
, ptr
->size
);
2186 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2188 ptr
->size
= (EMACS_INT
) objptr
;
2189 if (ptr
->size
& MARKBIT
)
2190 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2195 case Lisp_Vectorlike
:
2196 if (GC_BUFFERP (obj
))
2198 if (!XMARKBIT (XBUFFER (obj
)->name
))
2201 else if (GC_SUBRP (obj
))
2203 else if (GC_COMPILEDP (obj
))
2204 /* We could treat this just like a vector, but it is better
2205 to save the COMPILED_CONSTANTS element for last and avoid recursion
2208 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2209 register EMACS_INT size
= ptr
->size
;
2210 /* See comment above under Lisp_Vector. */
2211 struct Lisp_Vector
*volatile ptr1
= ptr
;
2214 if (size
& ARRAY_MARK_FLAG
)
2215 break; /* Already marked */
2216 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2217 size
&= PSEUDOVECTOR_SIZE_MASK
;
2218 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2220 if (i
!= COMPILED_CONSTANTS
)
2221 mark_object (&ptr1
->contents
[i
]);
2223 /* This cast should be unnecessary, but some Mips compiler complains
2224 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2225 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2228 else if (GC_FRAMEP (obj
))
2230 /* See comment above under Lisp_Vector for why this is volatile. */
2231 register struct frame
*volatile ptr
= XFRAME (obj
);
2232 register EMACS_INT size
= ptr
->size
;
2234 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2235 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2237 mark_object (&ptr
->name
);
2238 mark_object (&ptr
->icon_name
);
2239 mark_object (&ptr
->title
);
2240 mark_object (&ptr
->focus_frame
);
2241 mark_object (&ptr
->selected_window
);
2242 mark_object (&ptr
->minibuffer_window
);
2243 mark_object (&ptr
->param_alist
);
2244 mark_object (&ptr
->scroll_bars
);
2245 mark_object (&ptr
->condemned_scroll_bars
);
2246 mark_object (&ptr
->menu_bar_items
);
2247 mark_object (&ptr
->face_alist
);
2248 mark_object (&ptr
->menu_bar_vector
);
2249 mark_object (&ptr
->buffer_predicate
);
2250 mark_object (&ptr
->buffer_list
);
2251 mark_object (&ptr
->menu_bar_window
);
2252 mark_object (&ptr
->toolbar_window
);
2253 mark_face_cache (ptr
->face_cache
);
2254 #ifdef HAVE_WINDOW_SYSTEM
2255 mark_image_cache (ptr
);
2256 mark_object (&ptr
->desired_toolbar_items
);
2257 mark_object (&ptr
->current_toolbar_items
);
2258 mark_object (&ptr
->desired_toolbar_string
);
2259 mark_object (&ptr
->current_toolbar_string
);
2260 #endif /* HAVE_WINDOW_SYSTEM */
2262 else if (GC_BOOL_VECTOR_P (obj
))
2264 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2266 if (ptr
->size
& ARRAY_MARK_FLAG
)
2267 break; /* Already marked */
2268 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2270 else if (GC_WINDOWP (obj
))
2272 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2273 struct window
*w
= XWINDOW (obj
);
2274 register EMACS_INT size
= ptr
->size
;
2275 /* The reason we use ptr1 is to avoid an apparent hardware bug
2276 that happens occasionally on the FSF's HP 300s.
2277 The bug is that a2 gets clobbered by recursive calls to mark_object.
2278 The clobberage seems to happen during function entry,
2279 perhaps in the moveml instruction.
2280 Yes, this is a crock, but we have to do it. */
2281 struct Lisp_Vector
*volatile ptr1
= ptr
;
2284 /* Stop if already marked. */
2285 if (size
& ARRAY_MARK_FLAG
)
2289 ptr
->size
|= ARRAY_MARK_FLAG
;
2291 /* There is no Lisp data above The member CURRENT_MATRIX in
2292 struct WINDOW. Stop marking when that slot is reached. */
2294 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
2296 mark_object (&ptr1
->contents
[i
]);
2298 /* Mark glyphs for leaf windows. Marking window matrices is
2299 sufficient because frame matrices use the same glyph
2301 if (NILP (w
->hchild
)
2303 && w
->current_matrix
)
2305 mark_glyph_matrix (w
->current_matrix
);
2306 mark_glyph_matrix (w
->desired_matrix
);
2309 else if (GC_HASH_TABLE_P (obj
))
2311 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
2312 EMACS_INT size
= h
->size
;
2314 /* Stop if already marked. */
2315 if (size
& ARRAY_MARK_FLAG
)
2319 h
->size
|= ARRAY_MARK_FLAG
;
2321 /* Mark contents. */
2322 mark_object (&h
->test
);
2323 mark_object (&h
->weak
);
2324 mark_object (&h
->rehash_size
);
2325 mark_object (&h
->rehash_threshold
);
2326 mark_object (&h
->hash
);
2327 mark_object (&h
->next
);
2328 mark_object (&h
->index
);
2329 mark_object (&h
->user_hash_function
);
2330 mark_object (&h
->user_cmp_function
);
2332 /* If hash table is not weak, mark all keys and values.
2333 For weak tables, mark only the vector. */
2334 if (GC_NILP (h
->weak
))
2335 mark_object (&h
->key_and_value
);
2337 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
2342 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2343 register EMACS_INT size
= ptr
->size
;
2344 /* The reason we use ptr1 is to avoid an apparent hardware bug
2345 that happens occasionally on the FSF's HP 300s.
2346 The bug is that a2 gets clobbered by recursive calls to mark_object.
2347 The clobberage seems to happen during function entry,
2348 perhaps in the moveml instruction.
2349 Yes, this is a crock, but we have to do it. */
2350 struct Lisp_Vector
*volatile ptr1
= ptr
;
2353 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2354 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2355 if (size
& PSEUDOVECTOR_FLAG
)
2356 size
&= PSEUDOVECTOR_SIZE_MASK
;
2358 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2359 mark_object (&ptr1
->contents
[i
]);
2365 /* See comment above under Lisp_Vector for why this is volatile. */
2366 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2367 struct Lisp_Symbol
*ptrx
;
2369 if (XMARKBIT (ptr
->plist
)) break;
2371 mark_object ((Lisp_Object
*) &ptr
->value
);
2372 mark_object (&ptr
->function
);
2373 mark_object (&ptr
->plist
);
2374 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2375 mark_object ((Lisp_Object
*) &ptr
->name
);
2376 /* Note that we do not mark the obarray of the symbol.
2377 It is safe not to do so because nothing accesses that
2378 slot except to check whether it is nil. */
2382 /* For the benefit of the last_marked log. */
2383 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2384 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2385 XSETSYMBOL (obj
, ptrx
);
2386 /* We can't goto loop here because *objptr doesn't contain an
2387 actual Lisp_Object with valid datatype field. */
2394 switch (XMISCTYPE (obj
))
2396 case Lisp_Misc_Marker
:
2397 XMARK (XMARKER (obj
)->chain
);
2398 /* DO NOT mark thru the marker's chain.
2399 The buffer's markers chain does not preserve markers from gc;
2400 instead, markers are removed from the chain when freed by gc. */
2403 case Lisp_Misc_Buffer_Local_Value
:
2404 case Lisp_Misc_Some_Buffer_Local_Value
:
2406 register struct Lisp_Buffer_Local_Value
*ptr
2407 = XBUFFER_LOCAL_VALUE (obj
);
2408 if (XMARKBIT (ptr
->realvalue
)) break;
2409 XMARK (ptr
->realvalue
);
2410 /* If the cdr is nil, avoid recursion for the car. */
2411 if (EQ (ptr
->cdr
, Qnil
))
2413 objptr
= &ptr
->realvalue
;
2416 mark_object (&ptr
->realvalue
);
2417 mark_object (&ptr
->buffer
);
2418 mark_object (&ptr
->frame
);
2419 /* See comment above under Lisp_Vector for why not use ptr here. */
2420 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2424 case Lisp_Misc_Intfwd
:
2425 case Lisp_Misc_Boolfwd
:
2426 case Lisp_Misc_Objfwd
:
2427 case Lisp_Misc_Buffer_Objfwd
:
2428 case Lisp_Misc_Kboard_Objfwd
:
2429 /* Don't bother with Lisp_Buffer_Objfwd,
2430 since all markable slots in current buffer marked anyway. */
2431 /* Don't need to do Lisp_Objfwd, since the places they point
2432 are protected with staticpro. */
2435 case Lisp_Misc_Overlay
:
2437 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2438 if (!XMARKBIT (ptr
->plist
))
2441 mark_object (&ptr
->start
);
2442 mark_object (&ptr
->end
);
2443 objptr
= &ptr
->plist
;
2456 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2457 if (XMARKBIT (ptr
->car
)) break;
2459 /* If the cdr is nil, avoid recursion for the car. */
2460 if (EQ (ptr
->cdr
, Qnil
))
2465 mark_object (&ptr
->car
);
2466 /* See comment above under Lisp_Vector for why not use ptr here. */
2467 objptr
= &XCONS (obj
)->cdr
;
2471 #ifdef LISP_FLOAT_TYPE
2473 XMARK (XFLOAT (obj
)->type
);
2475 #endif /* LISP_FLOAT_TYPE */
2485 /* Mark the pointers in a buffer structure. */
2491 register struct buffer
*buffer
= XBUFFER (buf
);
2492 register Lisp_Object
*ptr
;
2493 Lisp_Object base_buffer
;
2495 /* This is the buffer's markbit */
2496 mark_object (&buffer
->name
);
2497 XMARK (buffer
->name
);
2499 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2501 if (CONSP (buffer
->undo_list
))
2504 tail
= buffer
->undo_list
;
2506 while (CONSP (tail
))
2508 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2510 if (XMARKBIT (ptr
->car
))
2513 if (GC_CONSP (ptr
->car
)
2514 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2515 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2517 XMARK (XCONS (ptr
->car
)->car
);
2518 mark_object (&XCONS (ptr
->car
)->cdr
);
2521 mark_object (&ptr
->car
);
2523 if (CONSP (ptr
->cdr
))
2529 mark_object (&XCONS (tail
)->cdr
);
2532 mark_object (&buffer
->undo_list
);
2535 mark_object (buffer
->syntax_table
);
2537 /* Mark the various string-pointers in the buffer object.
2538 Since the strings may be relocated, we must mark them
2539 in their actual slots. So gc_sweep must convert each slot
2540 back to an ordinary C pointer. */
2541 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2542 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2543 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2544 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2546 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2547 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2548 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2549 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2552 for (ptr
= &buffer
->name
+ 1;
2553 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2557 /* If this is an indirect buffer, mark its base buffer. */
2558 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2560 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2561 mark_buffer (base_buffer
);
2566 /* Mark the pointers in the kboard objects. */
2573 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2575 if (kb
->kbd_macro_buffer
)
2576 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2578 mark_object (&kb
->Voverriding_terminal_local_map
);
2579 mark_object (&kb
->Vlast_command
);
2580 mark_object (&kb
->Vreal_last_command
);
2581 mark_object (&kb
->Vprefix_arg
);
2582 mark_object (&kb
->Vlast_prefix_arg
);
2583 mark_object (&kb
->kbd_queue
);
2584 mark_object (&kb
->defining_kbd_macro
);
2585 mark_object (&kb
->Vlast_kbd_macro
);
2586 mark_object (&kb
->Vsystem_key_alist
);
2587 mark_object (&kb
->system_key_syms
);
2588 mark_object (&kb
->Vdefault_minibuffer_frame
);
2593 /* Value is non-zero if OBJ will survive the current GC because it's
2594 either marked or does not need to be marked to survive. */
2602 switch (XGCTYPE (obj
))
2609 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
2613 switch (XMISCTYPE (obj
))
2615 case Lisp_Misc_Marker
:
2616 survives_p
= XMARKBIT (obj
);
2619 case Lisp_Misc_Buffer_Local_Value
:
2620 case Lisp_Misc_Some_Buffer_Local_Value
:
2621 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2624 case Lisp_Misc_Intfwd
:
2625 case Lisp_Misc_Boolfwd
:
2626 case Lisp_Misc_Objfwd
:
2627 case Lisp_Misc_Buffer_Objfwd
:
2628 case Lisp_Misc_Kboard_Objfwd
:
2632 case Lisp_Misc_Overlay
:
2633 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
2643 struct Lisp_String
*s
= XSTRING (obj
);
2645 if (s
->size
& MARKBIT
)
2646 survives_p
= s
->size
& ARRAY_MARK_FLAG
;
2648 survives_p
= (s
->size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
;
2652 case Lisp_Vectorlike
:
2653 if (GC_BUFFERP (obj
))
2654 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
2655 else if (GC_SUBRP (obj
))
2658 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
2662 survives_p
= XMARKBIT (XCAR (obj
));
2665 #ifdef LISP_FLOAT_TYPE
2667 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
2669 #endif /* LISP_FLOAT_TYPE */
2680 /* Sweep: find all structures not marked, and free them. */
2685 /* Remove or mark entries in weak hash tables.
2686 This must be done before any object is unmarked. */
2687 sweep_weak_hash_tables ();
2689 total_string_size
= 0;
2692 /* Put all unmarked conses on free list */
2694 register struct cons_block
*cblk
;
2695 struct cons_block
**cprev
= &cons_block
;
2696 register int lim
= cons_block_index
;
2697 register int num_free
= 0, num_used
= 0;
2701 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2705 for (i
= 0; i
< lim
; i
++)
2706 if (!XMARKBIT (cblk
->conses
[i
].car
))
2709 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2710 cons_free_list
= &cblk
->conses
[i
];
2715 XUNMARK (cblk
->conses
[i
].car
);
2717 lim
= CONS_BLOCK_SIZE
;
2718 /* If this block contains only free conses and we have already
2719 seen more than two blocks worth of free conses then deallocate
2721 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2723 *cprev
= cblk
->next
;
2724 /* Unhook from the free list. */
2725 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2731 num_free
+= this_free
;
2732 cprev
= &cblk
->next
;
2735 total_conses
= num_used
;
2736 total_free_conses
= num_free
;
2739 #ifdef LISP_FLOAT_TYPE
2740 /* Put all unmarked floats on free list */
2742 register struct float_block
*fblk
;
2743 struct float_block
**fprev
= &float_block
;
2744 register int lim
= float_block_index
;
2745 register int num_free
= 0, num_used
= 0;
2747 float_free_list
= 0;
2749 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2753 for (i
= 0; i
< lim
; i
++)
2754 if (!XMARKBIT (fblk
->floats
[i
].type
))
2757 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2758 float_free_list
= &fblk
->floats
[i
];
2763 XUNMARK (fblk
->floats
[i
].type
);
2765 lim
= FLOAT_BLOCK_SIZE
;
2766 /* If this block contains only free floats and we have already
2767 seen more than two blocks worth of free floats then deallocate
2769 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2771 *fprev
= fblk
->next
;
2772 /* Unhook from the free list. */
2773 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2779 num_free
+= this_free
;
2780 fprev
= &fblk
->next
;
2783 total_floats
= num_used
;
2784 total_free_floats
= num_free
;
2786 #endif /* LISP_FLOAT_TYPE */
2788 #ifdef USE_TEXT_PROPERTIES
2789 /* Put all unmarked intervals on free list */
2791 register struct interval_block
*iblk
;
2792 struct interval_block
**iprev
= &interval_block
;
2793 register int lim
= interval_block_index
;
2794 register int num_free
= 0, num_used
= 0;
2796 interval_free_list
= 0;
2798 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2803 for (i
= 0; i
< lim
; i
++)
2805 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2807 iblk
->intervals
[i
].parent
= interval_free_list
;
2808 interval_free_list
= &iblk
->intervals
[i
];
2814 XUNMARK (iblk
->intervals
[i
].plist
);
2817 lim
= INTERVAL_BLOCK_SIZE
;
2818 /* If this block contains only free intervals and we have already
2819 seen more than two blocks worth of free intervals then
2820 deallocate this block. */
2821 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2823 *iprev
= iblk
->next
;
2824 /* Unhook from the free list. */
2825 interval_free_list
= iblk
->intervals
[0].parent
;
2827 n_interval_blocks
--;
2831 num_free
+= this_free
;
2832 iprev
= &iblk
->next
;
2835 total_intervals
= num_used
;
2836 total_free_intervals
= num_free
;
2838 #endif /* USE_TEXT_PROPERTIES */
2840 /* Put all unmarked symbols on free list */
2842 register struct symbol_block
*sblk
;
2843 struct symbol_block
**sprev
= &symbol_block
;
2844 register int lim
= symbol_block_index
;
2845 register int num_free
= 0, num_used
= 0;
2847 symbol_free_list
= 0;
2849 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2853 for (i
= 0; i
< lim
; i
++)
2854 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2856 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2857 symbol_free_list
= &sblk
->symbols
[i
];
2863 sblk
->symbols
[i
].name
2864 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2865 XUNMARK (sblk
->symbols
[i
].plist
);
2867 lim
= SYMBOL_BLOCK_SIZE
;
2868 /* If this block contains only free symbols and we have already
2869 seen more than two blocks worth of free symbols then deallocate
2871 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2873 *sprev
= sblk
->next
;
2874 /* Unhook from the free list. */
2875 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2881 num_free
+= this_free
;
2882 sprev
= &sblk
->next
;
2885 total_symbols
= num_used
;
2886 total_free_symbols
= num_free
;
2890 /* Put all unmarked misc's on free list.
2891 For a marker, first unchain it from the buffer it points into. */
2893 register struct marker_block
*mblk
;
2894 struct marker_block
**mprev
= &marker_block
;
2895 register int lim
= marker_block_index
;
2896 register int num_free
= 0, num_used
= 0;
2898 marker_free_list
= 0;
2900 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2904 EMACS_INT already_free
= -1;
2906 for (i
= 0; i
< lim
; i
++)
2908 Lisp_Object
*markword
;
2909 switch (mblk
->markers
[i
].u_marker
.type
)
2911 case Lisp_Misc_Marker
:
2912 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2914 case Lisp_Misc_Buffer_Local_Value
:
2915 case Lisp_Misc_Some_Buffer_Local_Value
:
2916 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2918 case Lisp_Misc_Overlay
:
2919 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2921 case Lisp_Misc_Free
:
2922 /* If the object was already free, keep it
2923 on the free list. */
2924 markword
= (Lisp_Object
*) &already_free
;
2930 if (markword
&& !XMARKBIT (*markword
))
2933 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2935 /* tem1 avoids Sun compiler bug */
2936 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2937 XSETMARKER (tem
, tem1
);
2938 unchain_marker (tem
);
2940 /* Set the type of the freed object to Lisp_Misc_Free.
2941 We could leave the type alone, since nobody checks it,
2942 but this might catch bugs faster. */
2943 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2944 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2945 marker_free_list
= &mblk
->markers
[i
];
2952 XUNMARK (*markword
);
2955 lim
= MARKER_BLOCK_SIZE
;
2956 /* If this block contains only free markers and we have already
2957 seen more than two blocks worth of free markers then deallocate
2959 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2961 *mprev
= mblk
->next
;
2962 /* Unhook from the free list. */
2963 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2969 num_free
+= this_free
;
2970 mprev
= &mblk
->next
;
2974 total_markers
= num_used
;
2975 total_free_markers
= num_free
;
2978 /* Free all unmarked buffers */
2980 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2983 if (!XMARKBIT (buffer
->name
))
2986 prev
->next
= buffer
->next
;
2988 all_buffers
= buffer
->next
;
2989 next
= buffer
->next
;
2995 XUNMARK (buffer
->name
);
2996 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2999 /* Each `struct Lisp_String *' was turned into a Lisp_Object
3000 for purposes of marking and relocation.
3001 Turn them back into C pointers now. */
3002 buffer
->upcase_table
3003 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
3004 buffer
->downcase_table
3005 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
3007 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
3008 buffer
->folding_sort_table
3009 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
3012 prev
= buffer
, buffer
= buffer
->next
;
3016 #endif /* standalone */
3018 /* Free all unmarked vectors */
3020 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
3021 total_vector_size
= 0;
3024 if (!(vector
->size
& ARRAY_MARK_FLAG
))
3027 if ((vector
->size
& (PSEUDOVECTOR_FLAG
| PVEC_HASH_TABLE
))
3028 == (PSEUDOVECTOR_FLAG
| PVEC_HASH_TABLE
))
3029 fprintf (stderr
, "Freeing hash table %p\n", vector
);
3032 prev
->next
= vector
->next
;
3034 all_vectors
= vector
->next
;
3035 next
= vector
->next
;
3043 vector
->size
&= ~ARRAY_MARK_FLAG
;
3044 if (vector
->size
& PSEUDOVECTOR_FLAG
)
3045 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
3047 total_vector_size
+= vector
->size
;
3048 prev
= vector
, vector
= vector
->next
;
3052 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
3054 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
3055 struct Lisp_String
*s
;
3059 s
= (struct Lisp_String
*) &sb
->chars
[0];
3060 if (s
->size
& ARRAY_MARK_FLAG
)
3062 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
3063 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
3064 UNMARK_BALANCE_INTERVALS (s
->intervals
);
3065 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
3066 prev
= sb
, sb
= sb
->next
;
3071 prev
->next
= sb
->next
;
3073 large_string_blocks
= sb
->next
;
3083 /* Compactify strings, relocate references, and free empty string blocks. */
3088 /* String block of old strings we are scanning. */
3089 register struct string_block
*from_sb
;
3090 /* A preceding string block (or maybe the same one)
3091 where we are copying the still-live strings to. */
3092 register struct string_block
*to_sb
;
3096 to_sb
= first_string_block
;
3099 /* Scan each existing string block sequentially, string by string. */
3100 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
3103 /* POS is the index of the next string in the block. */
3104 while (pos
< from_sb
->pos
)
3106 register struct Lisp_String
*nextstr
3107 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
3109 register struct Lisp_String
*newaddr
;
3110 register EMACS_INT size
= nextstr
->size
;
3111 EMACS_INT size_byte
= nextstr
->size_byte
;
3113 /* NEXTSTR is the old address of the next string.
3114 Just skip it if it isn't marked. */
3115 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
3117 /* It is marked, so its size field is really a chain of refs.
3118 Find the end of the chain, where the actual size lives. */
3119 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
3121 if (size
& DONT_COPY_FLAG
)
3122 size
^= MARKBIT
| DONT_COPY_FLAG
;
3123 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
3129 total_string_size
+= size_byte
;
3131 /* If it won't fit in TO_SB, close it out,
3132 and move to the next sb. Keep doing so until
3133 TO_SB reaches a large enough, empty enough string block.
3134 We know that TO_SB cannot advance past FROM_SB here
3135 since FROM_SB is large enough to contain this string.
3136 Any string blocks skipped here
3137 will be patched out and freed later. */
3138 while (to_pos
+ STRING_FULLSIZE (size_byte
)
3139 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
3141 to_sb
->pos
= to_pos
;
3142 to_sb
= to_sb
->next
;
3145 /* Compute new address of this string
3146 and update TO_POS for the space being used. */
3147 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
3148 to_pos
+= STRING_FULLSIZE (size_byte
);
3150 /* Copy the string itself to the new place. */
3151 if (nextstr
!= newaddr
)
3152 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
3154 /* Go through NEXTSTR's chain of references
3155 and make each slot in the chain point to
3156 the new address of this string. */
3157 size
= newaddr
->size
;
3158 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
3160 register Lisp_Object
*objptr
;
3161 if (size
& DONT_COPY_FLAG
)
3162 size
^= MARKBIT
| DONT_COPY_FLAG
;
3163 objptr
= (Lisp_Object
*)size
;
3165 size
= XFASTINT (*objptr
) & ~MARKBIT
;
3166 if (XMARKBIT (*objptr
))
3168 XSETSTRING (*objptr
, newaddr
);
3172 XSETSTRING (*objptr
, newaddr
);
3174 /* Store the actual size in the size field. */
3175 newaddr
->size
= size
;
3177 #ifdef USE_TEXT_PROPERTIES
3178 /* Now that the string has been relocated, rebalance its
3179 interval tree, and update the tree's parent pointer. */
3180 if (! NULL_INTERVAL_P (newaddr
->intervals
))
3182 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
3183 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
3186 #endif /* USE_TEXT_PROPERTIES */
3188 else if (size_byte
< 0)
3191 pos
+= STRING_FULLSIZE (size_byte
);
3195 /* Close out the last string block still used and free any that follow. */
3196 to_sb
->pos
= to_pos
;
3197 current_string_block
= to_sb
;
3199 from_sb
= to_sb
->next
;
3203 to_sb
= from_sb
->next
;
3204 lisp_free (from_sb
);
3209 /* Free any empty string blocks further back in the chain.
3210 This loop will never free first_string_block, but it is very
3211 unlikely that that one will become empty, so why bother checking? */
3213 from_sb
= first_string_block
;
3214 while (to_sb
= from_sb
->next
)
3216 if (to_sb
->pos
== 0)
3218 if (from_sb
->next
= to_sb
->next
)
3219 from_sb
->next
->prev
= from_sb
;
3228 /* Debugging aids. */
3230 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
3231 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
3232 This may be helpful in debugging Emacs's memory usage.\n\
3233 We divide the value by 1024 to make sure it fits in a Lisp integer.")
3238 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
3243 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
3244 "Return a list of counters that measure how much consing there has been.\n\
3245 Each of these counters increments for a certain kind of object.\n\
3246 The counters wrap around from the largest positive integer to zero.\n\
3247 Garbage collection does not decrease them.\n\
3248 The elements of the value are as follows:\n\
3249 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
3250 All are in units of 1 = one object consed\n\
3251 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
3253 MISCS include overlays, markers, and some internal types.\n\
3254 Frames, windows, buffers, and subprocesses count as vectors\n\
3255 (but the contents of a buffer's text do not count here).")
3258 Lisp_Object lisp_cons_cells_consed
;
3259 Lisp_Object lisp_floats_consed
;
3260 Lisp_Object lisp_vector_cells_consed
;
3261 Lisp_Object lisp_symbols_consed
;
3262 Lisp_Object lisp_string_chars_consed
;
3263 Lisp_Object lisp_misc_objects_consed
;
3264 Lisp_Object lisp_intervals_consed
;
3266 XSETINT (lisp_cons_cells_consed
,
3267 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3268 XSETINT (lisp_floats_consed
,
3269 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3270 XSETINT (lisp_vector_cells_consed
,
3271 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3272 XSETINT (lisp_symbols_consed
,
3273 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3274 XSETINT (lisp_string_chars_consed
,
3275 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3276 XSETINT (lisp_misc_objects_consed
,
3277 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3278 XSETINT (lisp_intervals_consed
,
3279 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3281 return Fcons (lisp_cons_cells_consed
,
3282 Fcons (lisp_floats_consed
,
3283 Fcons (lisp_vector_cells_consed
,
3284 Fcons (lisp_symbols_consed
,
3285 Fcons (lisp_string_chars_consed
,
3286 Fcons (lisp_misc_objects_consed
,
3287 Fcons (lisp_intervals_consed
,
3291 /* Initialization */
3296 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
3299 pure_size
= PURESIZE
;
3302 ignore_warnings
= 1;
3303 #ifdef DOUG_LEA_MALLOC
3304 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
3305 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
3306 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
3312 #ifdef LISP_FLOAT_TYPE
3314 #endif /* LISP_FLOAT_TYPE */
3318 malloc_hysteresis
= 32;
3320 malloc_hysteresis
= 0;
3323 spare_memory
= (char *) malloc (SPARE_MEMORY
);
3325 ignore_warnings
= 0;
3328 consing_since_gc
= 0;
3329 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
3330 #ifdef VIRT_ADDR_VARIES
3331 malloc_sbrk_unused
= 1<<22; /* A large number */
3332 malloc_sbrk_used
= 100000; /* as reasonable as any number */
3333 #endif /* VIRT_ADDR_VARIES */
3345 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
3346 "*Number of bytes of consing between garbage collections.\n\
3347 Garbage collection can happen automatically once this many bytes have been\n\
3348 allocated since the last garbage collection. All data types count.\n\n\
3349 Garbage collection happens automatically only when `eval' is called.\n\n\
3350 By binding this temporarily to a large number, you can effectively\n\
3351 prevent garbage collection during a part of the program.");
3353 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3354 "Number of bytes of sharable Lisp data allocated so far.");
3356 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3357 "Number of cons cells that have been consed so far.");
3359 DEFVAR_INT ("floats-consed", &floats_consed
,
3360 "Number of floats that have been consed so far.");
3362 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3363 "Number of vector cells that have been consed so far.");
3365 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3366 "Number of symbols that have been consed so far.");
3368 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3369 "Number of string characters that have been consed so far.");
3371 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3372 "Number of miscellaneous objects that have been consed so far.");
3374 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3375 "Number of intervals that have been consed so far.");
3378 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3379 "Number of bytes of unshared memory allocated in this session.");
3381 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3382 "Number of bytes of unshared memory remaining available in this session.");
3385 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3386 "Non-nil means loading Lisp code in order to dump an executable.\n\
3387 This means that certain objects should be allocated in shared (pure) space.");
3389 DEFVAR_INT ("undo-limit", &undo_limit
,
3390 "Keep no more undo information once it exceeds this size.\n\
3391 This limit is applied when garbage collection happens.\n\
3392 The size is counted as the number of bytes occupied,\n\
3393 which includes both saved text and other data.");
3396 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3397 "Don't keep more than this much size of undo information.\n\
3398 A command which pushes past this size is itself forgotten.\n\
3399 This limit is applied when garbage collection happens.\n\
3400 The size is counted as the number of bytes occupied,\n\
3401 which includes both saved text and other data.");
3402 undo_strong_limit
= 30000;
3404 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3405 "Non-nil means display messages at start and end of garbage collection.");
3406 garbage_collection_messages
= 0;
3408 /* We build this in advance because if we wait until we need it, we might
3409 not be able to allocate the memory to hold it. */
3411 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3412 staticpro (&memory_signal_data
);
3414 staticpro (&Qgc_cons_threshold
);
3415 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3417 staticpro (&Qchar_table_extra_slots
);
3418 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3423 defsubr (&Smake_byte_code
);
3424 defsubr (&Smake_list
);
3425 defsubr (&Smake_vector
);
3426 defsubr (&Smake_char_table
);
3427 defsubr (&Smake_string
);
3428 defsubr (&Smake_bool_vector
);
3429 defsubr (&Smake_symbol
);
3430 defsubr (&Smake_marker
);
3431 defsubr (&Spurecopy
);
3432 defsubr (&Sgarbage_collect
);
3433 defsubr (&Smemory_limit
);
3434 defsubr (&Smemory_use_counts
);