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"
37 #include "syssignal.h"
41 #ifdef DOUG_LEA_MALLOC
43 #define __malloc_size_t int
45 /* The following come from gmalloc.c. */
47 #if defined (__STDC__) && __STDC__
49 #define __malloc_size_t size_t
51 #define __malloc_size_t unsigned int
53 extern __malloc_size_t _bytes_used
;
54 extern int __malloc_extra_blocks
;
55 #endif /* !defined(DOUG_LEA_MALLOC) */
57 extern Lisp_Object Vhistory_length
;
59 #define max(A,B) ((A) > (B) ? (A) : (B))
60 #define min(A,B) ((A) < (B) ? (A) : (B))
62 /* Macro to verify that storage intended for Lisp objects is not
63 out of range to fit in the space for a pointer.
64 ADDRESS is the start of the block, and SIZE
65 is the amount of space within which objects can start. */
66 #define VALIDATE_LISP_STORAGE(address, size) \
70 XSETCONS (val, (char *) address + size); \
71 if ((char *) XCONS (val) != (char *) address + size) \
78 /* Value of _bytes_used, when spare_memory was freed. */
79 static __malloc_size_t bytes_used_when_full
;
81 /* Number of bytes of consing done since the last gc */
84 /* Count the amount of consing of various sorts of space. */
85 int cons_cells_consed
;
87 int vector_cells_consed
;
89 int string_chars_consed
;
90 int misc_objects_consed
;
93 /* Number of bytes of consing since gc before another gc should be done. */
94 int gc_cons_threshold
;
96 /* Nonzero during gc */
99 /* Nonzero means display messages at beginning and end of GC. */
100 int garbage_collection_messages
;
102 #ifndef VIRT_ADDR_VARIES
104 #endif /* VIRT_ADDR_VARIES */
105 int malloc_sbrk_used
;
107 #ifndef VIRT_ADDR_VARIES
109 #endif /* VIRT_ADDR_VARIES */
110 int malloc_sbrk_unused
;
112 /* Two limits controlling how much undo information to keep. */
114 int undo_strong_limit
;
116 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
117 int total_free_conses
, total_free_markers
, total_free_symbols
;
118 #ifdef LISP_FLOAT_TYPE
119 int total_free_floats
, total_floats
;
120 #endif /* LISP_FLOAT_TYPE */
122 /* Points to memory space allocated as "spare",
123 to be freed if we run out of memory. */
124 static char *spare_memory
;
126 /* Amount of spare memory to keep in reserve. */
127 #define SPARE_MEMORY (1 << 14)
129 /* Number of extra blocks malloc should get when it needs more core. */
130 static int malloc_hysteresis
;
132 /* Nonzero when malloc is called for allocating Lisp object space. */
133 int allocating_for_lisp
;
135 /* Non-nil means defun should do purecopy on the function definition */
136 Lisp_Object Vpurify_flag
;
139 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
140 #define PUREBEG (char *) pure
142 #define pure PURE_SEG_BITS /* Use shared memory segment */
143 #define PUREBEG (char *)PURE_SEG_BITS
145 /* This variable is used only by the XPNTR macro when HAVE_SHM is
146 defined. If we used the PURESIZE macro directly there, that would
147 make most of emacs dependent on puresize.h, which we don't want -
148 you should be able to change that without too much recompilation.
149 So map_in_data initializes pure_size, and the dependencies work
152 #endif /* not HAVE_SHM */
154 /* Index in pure at which next pure object will be allocated. */
157 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
158 char *pending_malloc_warning
;
160 /* Pre-computed signal argument for use when memory is exhausted. */
161 Lisp_Object memory_signal_data
;
163 /* Maximum amount of C stack to save when a GC happens. */
165 #ifndef MAX_SAVE_STACK
166 #define MAX_SAVE_STACK 16000
169 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
170 pointer to a Lisp_Object, when that pointer is viewed as an integer.
171 (On most machines, pointers are even, so we can use the low bit.
172 Word-addressable architectures may need to override this in the m-file.)
173 When linking references to small strings through the size field, we
174 use this slot to hold the bit that would otherwise be interpreted as
176 #ifndef DONT_COPY_FLAG
177 #define DONT_COPY_FLAG 1
178 #endif /* no DONT_COPY_FLAG */
180 /* Buffer in which we save a copy of the C stack at each GC. */
185 /* Non-zero means ignore malloc warnings. Set during initialization. */
188 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
190 static void mark_object (), mark_buffer (), mark_kboards ();
191 static void clear_marks (), gc_sweep ();
192 static void compact_strings ();
194 extern int message_enable_multibyte
;
196 /* Versions of malloc and realloc that print warnings as memory gets full. */
199 malloc_warning_1 (str
)
202 Fprinc (str
, Vstandard_output
);
203 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
204 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
205 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
209 /* malloc calls this if it finds we are near exhausting storage */
215 pending_malloc_warning
= str
;
219 display_malloc_warning ()
221 register Lisp_Object val
;
223 val
= build_string (pending_malloc_warning
);
224 pending_malloc_warning
= 0;
225 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
228 #ifdef DOUG_LEA_MALLOC
229 # define BYTES_USED (mallinfo ().arena)
231 # define BYTES_USED _bytes_used
234 /* Called if malloc returns zero */
239 #ifndef SYSTEM_MALLOC
240 bytes_used_when_full
= BYTES_USED
;
243 /* The first time we get here, free the spare memory. */
250 /* This used to call error, but if we've run out of memory, we could get
251 infinite recursion trying to build the string. */
253 Fsignal (Qnil
, memory_signal_data
);
256 /* Called if we can't allocate relocatable space for a buffer. */
259 buffer_memory_full ()
261 /* If buffers use the relocating allocator,
262 no need to free spare_memory, because we may have plenty of malloc
263 space left that we could get, and if we don't, the malloc that fails
264 will itself cause spare_memory to be freed.
265 If buffers don't use the relocating allocator,
266 treat this like any other failing malloc. */
272 /* This used to call error, but if we've run out of memory, we could get
273 infinite recursion trying to build the string. */
275 Fsignal (Qerror
, memory_signal_data
);
278 /* like malloc routines but check for no memory and block interrupt input. */
287 val
= (long *) malloc (size
);
290 if (!val
&& size
) memory_full ();
295 xrealloc (block
, size
)
302 /* We must call malloc explicitly when BLOCK is 0, since some
303 reallocs don't do this. */
305 val
= (long *) malloc (size
);
307 val
= (long *) realloc (block
, size
);
310 if (!val
&& size
) memory_full ();
324 /* Arranging to disable input signals while we're in malloc.
326 This only works with GNU malloc. To help out systems which can't
327 use GNU malloc, all the calls to malloc, realloc, and free
328 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
329 pairs; unfortunately, we have no idea what C library functions
330 might call malloc, so we can't really protect them unless you're
331 using GNU malloc. Fortunately, most of the major operating can use
334 #ifndef SYSTEM_MALLOC
335 extern void * (*__malloc_hook
) ();
336 static void * (*old_malloc_hook
) ();
337 extern void * (*__realloc_hook
) ();
338 static void * (*old_realloc_hook
) ();
339 extern void (*__free_hook
) ();
340 static void (*old_free_hook
) ();
342 /* This function is used as the hook for free to call. */
345 emacs_blocked_free (ptr
)
349 __free_hook
= old_free_hook
;
351 /* If we released our reserve (due to running out of memory),
352 and we have a fair amount free once again,
353 try to set aside another reserve in case we run out once more. */
354 if (spare_memory
== 0
355 /* Verify there is enough space that even with the malloc
356 hysteresis this call won't run out again.
357 The code here is correct as long as SPARE_MEMORY
358 is substantially larger than the block size malloc uses. */
359 && (bytes_used_when_full
360 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
361 spare_memory
= (char *) malloc (SPARE_MEMORY
);
363 __free_hook
= emacs_blocked_free
;
367 /* If we released our reserve (due to running out of memory),
368 and we have a fair amount free once again,
369 try to set aside another reserve in case we run out once more.
371 This is called when a relocatable block is freed in ralloc.c. */
374 refill_memory_reserve ()
376 if (spare_memory
== 0)
377 spare_memory
= (char *) malloc (SPARE_MEMORY
);
380 /* This function is the malloc hook that Emacs uses. */
383 emacs_blocked_malloc (size
)
389 __malloc_hook
= old_malloc_hook
;
390 #ifdef DOUG_LEA_MALLOC
391 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
393 __malloc_extra_blocks
= malloc_hysteresis
;
395 value
= (void *) malloc (size
);
396 __malloc_hook
= emacs_blocked_malloc
;
403 emacs_blocked_realloc (ptr
, size
)
410 __realloc_hook
= old_realloc_hook
;
411 value
= (void *) realloc (ptr
, size
);
412 __realloc_hook
= emacs_blocked_realloc
;
419 uninterrupt_malloc ()
421 old_free_hook
= __free_hook
;
422 __free_hook
= emacs_blocked_free
;
424 old_malloc_hook
= __malloc_hook
;
425 __malloc_hook
= emacs_blocked_malloc
;
427 old_realloc_hook
= __realloc_hook
;
428 __realloc_hook
= emacs_blocked_realloc
;
432 /* Interval allocation. */
434 #ifdef USE_TEXT_PROPERTIES
435 #define INTERVAL_BLOCK_SIZE \
436 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
438 struct interval_block
440 struct interval_block
*next
;
441 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
444 struct interval_block
*interval_block
;
445 static int interval_block_index
;
447 INTERVAL interval_free_list
;
452 allocating_for_lisp
= 1;
454 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
455 allocating_for_lisp
= 0;
456 interval_block
->next
= 0;
457 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
458 interval_block_index
= 0;
459 interval_free_list
= 0;
462 #define INIT_INTERVALS init_intervals ()
469 if (interval_free_list
)
471 val
= interval_free_list
;
472 interval_free_list
= interval_free_list
->parent
;
476 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
478 register struct interval_block
*newi
;
480 allocating_for_lisp
= 1;
481 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
483 allocating_for_lisp
= 0;
484 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
485 newi
->next
= interval_block
;
486 interval_block
= newi
;
487 interval_block_index
= 0;
489 val
= &interval_block
->intervals
[interval_block_index
++];
491 consing_since_gc
+= sizeof (struct interval
);
493 RESET_INTERVAL (val
);
497 static int total_free_intervals
, total_intervals
;
499 /* Mark the pointers of one interval. */
502 mark_interval (i
, dummy
)
506 if (XMARKBIT (i
->plist
))
508 mark_object (&i
->plist
);
513 mark_interval_tree (tree
)
514 register INTERVAL tree
;
516 /* No need to test if this tree has been marked already; this
517 function is always called through the MARK_INTERVAL_TREE macro,
518 which takes care of that. */
520 /* XMARK expands to an assignment; the LHS of an assignment can't be
522 XMARK (* (Lisp_Object
*) &tree
->parent
);
524 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
527 #define MARK_INTERVAL_TREE(i) \
529 if (!NULL_INTERVAL_P (i) \
530 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
531 mark_interval_tree (i); \
534 /* The oddity in the call to XUNMARK is necessary because XUNMARK
535 expands to an assignment to its argument, and most C compilers don't
536 support casts on the left operand of `='. */
537 #define UNMARK_BALANCE_INTERVALS(i) \
539 if (! NULL_INTERVAL_P (i)) \
541 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
542 (i) = balance_intervals (i); \
546 #else /* no interval use */
548 #define INIT_INTERVALS
550 #define UNMARK_BALANCE_INTERVALS(i)
551 #define MARK_INTERVAL_TREE(i)
553 #endif /* no interval use */
555 /* Floating point allocation. */
557 #ifdef LISP_FLOAT_TYPE
558 /* Allocation of float cells, just like conses */
559 /* We store float cells inside of float_blocks, allocating a new
560 float_block with malloc whenever necessary. Float cells reclaimed by
561 GC are put on a free list to be reallocated before allocating
562 any new float cells from the latest float_block.
564 Each float_block is just under 1020 bytes long,
565 since malloc really allocates in units of powers of two
566 and uses 4 bytes for its own overhead. */
568 #define FLOAT_BLOCK_SIZE \
569 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
573 struct float_block
*next
;
574 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
577 struct float_block
*float_block
;
578 int float_block_index
;
580 struct Lisp_Float
*float_free_list
;
585 allocating_for_lisp
= 1;
586 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
587 allocating_for_lisp
= 0;
588 float_block
->next
= 0;
589 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
590 float_block_index
= 0;
594 /* Explicitly free a float cell. */
596 struct Lisp_Float
*ptr
;
598 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
599 float_free_list
= ptr
;
603 make_float (float_value
)
606 register Lisp_Object val
;
610 /* We use the data field for chaining the free list
611 so that we won't use the same field that has the mark bit. */
612 XSETFLOAT (val
, float_free_list
);
613 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
617 if (float_block_index
== FLOAT_BLOCK_SIZE
)
619 register struct float_block
*new;
621 allocating_for_lisp
= 1;
622 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
623 allocating_for_lisp
= 0;
624 VALIDATE_LISP_STORAGE (new, sizeof *new);
625 new->next
= float_block
;
627 float_block_index
= 0;
629 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
631 XFLOAT (val
)->data
= float_value
;
632 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
633 consing_since_gc
+= sizeof (struct Lisp_Float
);
638 #endif /* LISP_FLOAT_TYPE */
640 /* Allocation of cons cells */
641 /* We store cons cells inside of cons_blocks, allocating a new
642 cons_block with malloc whenever necessary. Cons cells reclaimed by
643 GC are put on a free list to be reallocated before allocating
644 any new cons cells from the latest cons_block.
646 Each cons_block is just under 1020 bytes long,
647 since malloc really allocates in units of powers of two
648 and uses 4 bytes for its own overhead. */
650 #define CONS_BLOCK_SIZE \
651 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
655 struct cons_block
*next
;
656 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
659 struct cons_block
*cons_block
;
660 int cons_block_index
;
662 struct Lisp_Cons
*cons_free_list
;
667 allocating_for_lisp
= 1;
668 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
669 allocating_for_lisp
= 0;
670 cons_block
->next
= 0;
671 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
672 cons_block_index
= 0;
676 /* Explicitly free a cons cell. */
680 struct Lisp_Cons
*ptr
;
682 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
683 cons_free_list
= ptr
;
686 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
687 "Create a new cons, give it CAR and CDR as components, and return it.")
689 Lisp_Object car
, cdr
;
691 register Lisp_Object val
;
695 /* We use the cdr for chaining the free list
696 so that we won't use the same field that has the mark bit. */
697 XSETCONS (val
, cons_free_list
);
698 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
702 if (cons_block_index
== CONS_BLOCK_SIZE
)
704 register struct cons_block
*new;
705 allocating_for_lisp
= 1;
706 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
707 allocating_for_lisp
= 0;
708 VALIDATE_LISP_STORAGE (new, sizeof *new);
709 new->next
= cons_block
;
711 cons_block_index
= 0;
713 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
715 XCONS (val
)->car
= car
;
716 XCONS (val
)->cdr
= cdr
;
717 consing_since_gc
+= sizeof (struct Lisp_Cons
);
722 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
723 "Return a newly created list with specified arguments as elements.\n\
724 Any number of arguments, even zero arguments, are allowed.")
727 register Lisp_Object
*args
;
729 register Lisp_Object val
;
735 val
= Fcons (args
[nargs
], val
);
740 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
741 "Return a newly created list of length LENGTH, with each element being INIT.")
743 register Lisp_Object length
, init
;
745 register Lisp_Object val
;
748 CHECK_NATNUM (length
, 0);
749 size
= XFASTINT (length
);
753 val
= Fcons (init
, val
);
757 /* Allocation of vectors */
759 struct Lisp_Vector
*all_vectors
;
762 allocate_vectorlike (len
)
765 struct Lisp_Vector
*p
;
767 allocating_for_lisp
= 1;
768 #ifdef DOUG_LEA_MALLOC
769 /* Prevent mmap'ing the chunk (which is potentially very large). */
770 mallopt (M_MMAP_MAX
, 0);
772 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
773 + (len
- 1) * sizeof (Lisp_Object
));
774 #ifdef DOUG_LEA_MALLOC
775 /* Back to a reasonable maximum of mmap'ed areas. */
776 mallopt (M_MMAP_MAX
, 64);
778 allocating_for_lisp
= 0;
779 VALIDATE_LISP_STORAGE (p
, 0);
780 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
781 + (len
- 1) * sizeof (Lisp_Object
));
782 vector_cells_consed
+= len
;
784 p
->next
= all_vectors
;
789 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
790 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
791 See also the function `vector'.")
793 register Lisp_Object length
, init
;
796 register EMACS_INT sizei
;
798 register struct Lisp_Vector
*p
;
800 CHECK_NATNUM (length
, 0);
801 sizei
= XFASTINT (length
);
803 p
= allocate_vectorlike (sizei
);
805 for (index
= 0; index
< sizei
; index
++)
806 p
->contents
[index
] = init
;
808 XSETVECTOR (vector
, p
);
812 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
813 "Return a newly created char-table, with purpose PURPOSE.\n\
814 Each element is initialized to INIT, which defaults to nil.\n\
815 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
816 The property's value should be an integer between 0 and 10.")
818 register Lisp_Object purpose
, init
;
822 CHECK_SYMBOL (purpose
, 1);
823 n
= Fget (purpose
, Qchar_table_extra_slots
);
825 if (XINT (n
) < 0 || XINT (n
) > 10)
826 args_out_of_range (n
, Qnil
);
827 /* Add 2 to the size for the defalt and parent slots. */
828 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
830 XCHAR_TABLE (vector
)->top
= Qt
;
831 XCHAR_TABLE (vector
)->parent
= Qnil
;
832 XCHAR_TABLE (vector
)->purpose
= purpose
;
833 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
837 /* Return a newly created sub char table with default value DEFALT.
838 Since a sub char table does not appear as a top level Emacs Lisp
839 object, we don't need a Lisp interface to make it. */
842 make_sub_char_table (defalt
)
846 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
847 XCHAR_TABLE (vector
)->top
= Qnil
;
848 XCHAR_TABLE (vector
)->defalt
= defalt
;
849 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
853 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
854 "Return a newly created vector with specified arguments as elements.\n\
855 Any number of arguments, even zero arguments, are allowed.")
860 register Lisp_Object len
, val
;
862 register struct Lisp_Vector
*p
;
864 XSETFASTINT (len
, nargs
);
865 val
= Fmake_vector (len
, Qnil
);
867 for (index
= 0; index
< nargs
; index
++)
868 p
->contents
[index
] = args
[index
];
872 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
873 "Create a byte-code object with specified arguments as elements.\n\
874 The arguments should be the arglist, bytecode-string, constant vector,\n\
875 stack size, (optional) doc string, and (optional) interactive spec.\n\
876 The first four arguments are required; at most six have any\n\
882 register Lisp_Object len
, val
;
884 register struct Lisp_Vector
*p
;
886 XSETFASTINT (len
, nargs
);
887 if (!NILP (Vpurify_flag
))
888 val
= make_pure_vector ((EMACS_INT
) nargs
);
890 val
= Fmake_vector (len
, Qnil
);
892 for (index
= 0; index
< nargs
; index
++)
894 if (!NILP (Vpurify_flag
))
895 args
[index
] = Fpurecopy (args
[index
]);
896 p
->contents
[index
] = args
[index
];
898 XSETCOMPILED (val
, p
);
902 /* Allocation of symbols.
903 Just like allocation of conses!
905 Each symbol_block is just under 1020 bytes long,
906 since malloc really allocates in units of powers of two
907 and uses 4 bytes for its own overhead. */
909 #define SYMBOL_BLOCK_SIZE \
910 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
914 struct symbol_block
*next
;
915 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
918 struct symbol_block
*symbol_block
;
919 int symbol_block_index
;
921 struct Lisp_Symbol
*symbol_free_list
;
926 allocating_for_lisp
= 1;
927 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
928 allocating_for_lisp
= 0;
929 symbol_block
->next
= 0;
930 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
931 symbol_block_index
= 0;
932 symbol_free_list
= 0;
935 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
936 "Return a newly allocated uninterned symbol whose name is NAME.\n\
937 Its value and function definition are void, and its property list is nil.")
941 register Lisp_Object val
;
942 register struct Lisp_Symbol
*p
;
944 CHECK_STRING (name
, 0);
946 if (symbol_free_list
)
948 XSETSYMBOL (val
, symbol_free_list
);
949 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
953 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
955 struct symbol_block
*new;
956 allocating_for_lisp
= 1;
957 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
958 allocating_for_lisp
= 0;
959 VALIDATE_LISP_STORAGE (new, sizeof *new);
960 new->next
= symbol_block
;
962 symbol_block_index
= 0;
964 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
967 p
->name
= XSTRING (name
);
971 p
->function
= Qunbound
;
973 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
978 /* Allocation of markers and other objects that share that structure.
979 Works like allocation of conses. */
981 #define MARKER_BLOCK_SIZE \
982 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
986 struct marker_block
*next
;
987 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
990 struct marker_block
*marker_block
;
991 int marker_block_index
;
993 union Lisp_Misc
*marker_free_list
;
998 allocating_for_lisp
= 1;
999 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
1000 allocating_for_lisp
= 0;
1001 marker_block
->next
= 0;
1002 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1003 marker_block_index
= 0;
1004 marker_free_list
= 0;
1007 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1013 if (marker_free_list
)
1015 XSETMISC (val
, marker_free_list
);
1016 marker_free_list
= marker_free_list
->u_free
.chain
;
1020 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1022 struct marker_block
*new;
1023 allocating_for_lisp
= 1;
1024 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
1025 allocating_for_lisp
= 0;
1026 VALIDATE_LISP_STORAGE (new, sizeof *new);
1027 new->next
= marker_block
;
1029 marker_block_index
= 0;
1031 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1033 consing_since_gc
+= sizeof (union Lisp_Misc
);
1034 misc_objects_consed
++;
1038 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1039 "Return a newly allocated marker which does not point at any place.")
1042 register Lisp_Object val
;
1043 register struct Lisp_Marker
*p
;
1045 val
= allocate_misc ();
1046 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1052 p
->insertion_type
= 0;
1056 /* Put MARKER back on the free list after using it temporarily. */
1059 free_marker (marker
)
1062 unchain_marker (marker
);
1064 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1065 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1066 marker_free_list
= XMISC (marker
);
1068 total_free_markers
++;
1071 /* Allocation of strings */
1073 /* Strings reside inside of string_blocks. The entire data of the string,
1074 both the size and the contents, live in part of the `chars' component of a string_block.
1075 The `pos' component is the index within `chars' of the first free byte.
1077 first_string_block points to the first string_block ever allocated.
1078 Each block points to the next one with its `next' field.
1079 The `prev' fields chain in reverse order.
1080 The last one allocated is the one currently being filled.
1081 current_string_block points to it.
1083 The string_blocks that hold individual large strings
1084 go in a separate chain, started by large_string_blocks. */
1087 /* String blocks contain this many useful bytes.
1088 8188 is power of 2, minus 4 for malloc overhead. */
1089 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1091 /* A string bigger than this gets its own specially-made string block
1092 if it doesn't fit in the current one. */
1093 #define STRING_BLOCK_OUTSIZE 1024
1095 struct string_block_head
1097 struct string_block
*next
, *prev
;
1103 struct string_block
*next
, *prev
;
1105 char chars
[STRING_BLOCK_SIZE
];
1108 /* This points to the string block we are now allocating strings. */
1110 struct string_block
*current_string_block
;
1112 /* This points to the oldest string block, the one that starts the chain. */
1114 struct string_block
*first_string_block
;
1116 /* Last string block in chain of those made for individual large strings. */
1118 struct string_block
*large_string_blocks
;
1120 /* If SIZE is the length of a string, this returns how many bytes
1121 the string occupies in a string_block (including padding). */
1123 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1124 & ~(STRING_PAD - 1))
1125 /* Add 1 for the null terminator,
1126 and add STRING_PAD - 1 as part of rounding up. */
1128 #define STRING_PAD (sizeof (EMACS_INT))
1129 /* Size of the stuff in the string not including its data. */
1130 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1133 #define STRING_FULLSIZE(SIZE) \
1134 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1140 allocating_for_lisp
= 1;
1141 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1142 allocating_for_lisp
= 0;
1143 first_string_block
= current_string_block
;
1144 consing_since_gc
+= sizeof (struct string_block
);
1145 current_string_block
->next
= 0;
1146 current_string_block
->prev
= 0;
1147 current_string_block
->pos
= 0;
1148 large_string_blocks
= 0;
1151 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1152 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1153 Both LENGTH and INIT must be numbers.")
1155 Lisp_Object length
, init
;
1157 register Lisp_Object val
;
1158 register unsigned char *p
, *end
, c
;
1160 CHECK_NATNUM (length
, 0);
1161 CHECK_NUMBER (init
, 1);
1162 val
= make_uninit_string (XFASTINT (length
));
1164 p
= XSTRING (val
)->data
;
1165 end
= p
+ XSTRING (val
)->size
;
1172 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1173 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1174 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1176 Lisp_Object length
, init
;
1178 register Lisp_Object val
;
1179 struct Lisp_Bool_Vector
*p
;
1181 int length_in_chars
, length_in_elts
, bits_per_value
;
1183 CHECK_NATNUM (length
, 0);
1185 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1187 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1188 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1190 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1191 slot `size' of the struct Lisp_Bool_Vector. */
1192 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1193 p
= XBOOL_VECTOR (val
);
1194 /* Get rid of any bits that would cause confusion. */
1196 XSETBOOL_VECTOR (val
, p
);
1197 p
->size
= XFASTINT (length
);
1199 real_init
= (NILP (init
) ? 0 : -1);
1200 for (i
= 0; i
< length_in_chars
; i
++)
1201 p
->data
[i
] = real_init
;
1206 /* Make a string from NBYTES bytes at CONTENTS,
1207 and compute the number of characters from the contents. */
1210 make_string (contents
, nbytes
)
1214 register Lisp_Object val
;
1215 int nchars
= chars_in_text (contents
, nbytes
);
1216 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1217 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1221 /* Make a string from LENGTH bytes at CONTENTS,
1222 assuming each byte is a character. */
1225 make_unibyte_string (contents
, length
)
1229 register Lisp_Object val
;
1230 val
= make_uninit_string (length
);
1231 bcopy (contents
, XSTRING (val
)->data
, length
);
1235 /* Make a string from NCHARS characters occupying NBYTES bytes at CONTENTS. */
1238 make_multibyte_string (contents
, nchars
, nbytes
)
1242 register Lisp_Object val
;
1243 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1244 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1248 /* Make a string from the data at STR,
1249 treating it as multibyte if the data warrants. */
1255 return make_string (str
, strlen (str
));
1259 make_uninit_string (length
)
1262 return make_uninit_multibyte_string (length
, length
);
1266 make_uninit_multibyte_string (length
, length_byte
)
1267 int length
, length_byte
;
1269 register Lisp_Object val
;
1270 register int fullsize
= STRING_FULLSIZE (length_byte
);
1272 if (length
< 0) abort ();
1274 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1275 /* This string can fit in the current string block */
1278 ((struct Lisp_String
*)
1279 (current_string_block
->chars
+ current_string_block
->pos
)));
1280 current_string_block
->pos
+= fullsize
;
1282 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1283 /* This string gets its own string block */
1285 register struct string_block
*new;
1286 allocating_for_lisp
= 1;
1287 #ifdef DOUG_LEA_MALLOC
1288 /* Prevent mmap'ing the chunk (which is potentially very large). */
1289 mallopt (M_MMAP_MAX
, 0);
1291 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1292 #ifdef DOUG_LEA_MALLOC
1293 /* Back to a reasonable maximum of mmap'ed areas. */
1294 mallopt (M_MMAP_MAX
, 64);
1296 allocating_for_lisp
= 0;
1297 VALIDATE_LISP_STORAGE (new, 0);
1298 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1299 new->pos
= fullsize
;
1300 new->next
= large_string_blocks
;
1301 large_string_blocks
= new;
1303 ((struct Lisp_String
*)
1304 ((struct string_block_head
*)new + 1)));
1307 /* Make a new current string block and start it off with this string */
1309 register struct string_block
*new;
1310 allocating_for_lisp
= 1;
1311 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1312 allocating_for_lisp
= 0;
1313 VALIDATE_LISP_STORAGE (new, sizeof *new);
1314 consing_since_gc
+= sizeof (struct string_block
);
1315 current_string_block
->next
= new;
1316 new->prev
= current_string_block
;
1318 current_string_block
= new;
1319 new->pos
= fullsize
;
1321 (struct Lisp_String
*) current_string_block
->chars
);
1324 string_chars_consed
+= fullsize
;
1325 XSTRING (val
)->size
= length
;
1326 XSTRING (val
)->size_byte
= length_byte
;
1327 XSTRING (val
)->data
[length_byte
] = 0;
1328 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1333 /* Return a newly created vector or string with specified arguments as
1334 elements. If all the arguments are characters that can fit
1335 in a string of events, make a string; otherwise, make a vector.
1337 Any number of arguments, even zero arguments, are allowed. */
1340 make_event_array (nargs
, args
)
1346 for (i
= 0; i
< nargs
; i
++)
1347 /* The things that fit in a string
1348 are characters that are in 0...127,
1349 after discarding the meta bit and all the bits above it. */
1350 if (!INTEGERP (args
[i
])
1351 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1352 return Fvector (nargs
, args
);
1354 /* Since the loop exited, we know that all the things in it are
1355 characters, so we can make a string. */
1359 result
= Fmake_string (make_number (nargs
), make_number (0));
1360 for (i
= 0; i
< nargs
; i
++)
1362 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1363 /* Move the meta bit to the right place for a string char. */
1364 if (XINT (args
[i
]) & CHAR_META
)
1365 XSTRING (result
)->data
[i
] |= 0x80;
1372 /* Pure storage management. */
1374 /* Must get an error if pure storage is full,
1375 since if it cannot hold a large string
1376 it may be able to hold conses that point to that string;
1377 then the string is not protected from gc. */
1380 make_pure_string (data
, length
, length_byte
)
1385 register Lisp_Object
new;
1386 register int size
= STRING_FULLSIZE (length_byte
);
1388 if (pureptr
+ size
> PURESIZE
)
1389 error ("Pure Lisp storage exhausted");
1390 XSETSTRING (new, PUREBEG
+ pureptr
);
1391 XSTRING (new)->size
= length
;
1392 XSTRING (new)->size_byte
= length_byte
;
1393 bcopy (data
, XSTRING (new)->data
, length_byte
);
1394 XSTRING (new)->data
[length_byte
] = 0;
1396 /* We must give strings in pure storage some kind of interval. So we
1397 give them a null one. */
1398 #if defined (USE_TEXT_PROPERTIES)
1399 XSTRING (new)->intervals
= NULL_INTERVAL
;
1406 pure_cons (car
, cdr
)
1407 Lisp_Object car
, cdr
;
1409 register Lisp_Object
new;
1411 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1412 error ("Pure Lisp storage exhausted");
1413 XSETCONS (new, PUREBEG
+ pureptr
);
1414 pureptr
+= sizeof (struct Lisp_Cons
);
1415 XCONS (new)->car
= Fpurecopy (car
);
1416 XCONS (new)->cdr
= Fpurecopy (cdr
);
1420 #ifdef LISP_FLOAT_TYPE
1423 make_pure_float (num
)
1426 register Lisp_Object
new;
1428 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1429 (double) boundary. Some architectures (like the sparc) require
1430 this, and I suspect that floats are rare enough that it's no
1431 tragedy for those that do. */
1434 char *p
= PUREBEG
+ pureptr
;
1438 alignment
= __alignof (struct Lisp_Float
);
1440 alignment
= sizeof (struct Lisp_Float
);
1443 alignment
= sizeof (struct Lisp_Float
);
1445 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1446 pureptr
= p
- PUREBEG
;
1449 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1450 error ("Pure Lisp storage exhausted");
1451 XSETFLOAT (new, PUREBEG
+ pureptr
);
1452 pureptr
+= sizeof (struct Lisp_Float
);
1453 XFLOAT (new)->data
= num
;
1454 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1458 #endif /* LISP_FLOAT_TYPE */
1461 make_pure_vector (len
)
1464 register Lisp_Object
new;
1465 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1467 if (pureptr
+ size
> PURESIZE
)
1468 error ("Pure Lisp storage exhausted");
1470 XSETVECTOR (new, PUREBEG
+ pureptr
);
1472 XVECTOR (new)->size
= len
;
1476 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1477 "Make a copy of OBJECT in pure storage.\n\
1478 Recursively copies contents of vectors and cons cells.\n\
1479 Does not copy symbols.")
1481 register Lisp_Object obj
;
1483 if (NILP (Vpurify_flag
))
1486 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1487 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1491 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1492 #ifdef LISP_FLOAT_TYPE
1493 else if (FLOATP (obj
))
1494 return make_pure_float (XFLOAT (obj
)->data
);
1495 #endif /* LISP_FLOAT_TYPE */
1496 else if (STRINGP (obj
))
1497 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1498 XSTRING (obj
)->size_byte
);
1499 else if (COMPILEDP (obj
) || VECTORP (obj
))
1501 register struct Lisp_Vector
*vec
;
1502 register int i
, size
;
1504 size
= XVECTOR (obj
)->size
;
1505 if (size
& PSEUDOVECTOR_FLAG
)
1506 size
&= PSEUDOVECTOR_SIZE_MASK
;
1507 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1508 for (i
= 0; i
< size
; i
++)
1509 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1510 if (COMPILEDP (obj
))
1511 XSETCOMPILED (obj
, vec
);
1513 XSETVECTOR (obj
, vec
);
1516 else if (MARKERP (obj
))
1517 error ("Attempt to copy a marker to pure storage");
1522 /* Recording what needs to be marked for gc. */
1524 struct gcpro
*gcprolist
;
1526 #define NSTATICS 768
1528 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1532 /* Put an entry in staticvec, pointing at the variable whose address is given */
1535 staticpro (varaddress
)
1536 Lisp_Object
*varaddress
;
1538 staticvec
[staticidx
++] = varaddress
;
1539 if (staticidx
>= NSTATICS
)
1547 struct catchtag
*next
;
1548 #if 0 /* We don't need this for GC purposes */
1555 struct backtrace
*next
;
1556 Lisp_Object
*function
;
1557 Lisp_Object
*args
; /* Points to vector of args. */
1558 int nargs
; /* length of vector */
1559 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1563 /* Garbage collection! */
1565 /* Temporarily prevent garbage collection. */
1568 inhibit_garbage_collection ()
1570 int count
= specpdl_ptr
- specpdl
;
1572 int nbits
= min (VALBITS
, BITS_PER_INT
);
1574 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1576 specbind (Qgc_cons_threshold
, number
);
1581 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1582 "Reclaim storage for Lisp objects no longer needed.\n\
1583 Returns info on amount of space in use:\n\
1584 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1585 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1586 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1587 Garbage collection happens automatically if you cons more than\n\
1588 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1591 register struct gcpro
*tail
;
1592 register struct specbinding
*bind
;
1593 struct catchtag
*catch;
1594 struct handler
*handler
;
1595 register struct backtrace
*backlist
;
1596 register Lisp_Object tem
;
1597 char *omessage
= echo_area_glyphs
;
1598 int omessage_length
= echo_area_glyphs_length
;
1599 int oldmultibyte
= message_enable_multibyte
;
1600 char stack_top_variable
;
1603 /* In case user calls debug_print during GC,
1604 don't let that cause a recursive GC. */
1605 consing_since_gc
= 0;
1607 /* Save a copy of the contents of the stack, for debugging. */
1608 #if MAX_SAVE_STACK > 0
1609 if (NILP (Vpurify_flag
))
1611 i
= &stack_top_variable
- stack_bottom
;
1613 if (i
< MAX_SAVE_STACK
)
1615 if (stack_copy
== 0)
1616 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1617 else if (stack_copy_size
< i
)
1618 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1621 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1622 bcopy (stack_bottom
, stack_copy
, i
);
1624 bcopy (&stack_top_variable
, stack_copy
, i
);
1628 #endif /* MAX_SAVE_STACK > 0 */
1630 if (garbage_collection_messages
)
1631 message1_nolog ("Garbage collecting...");
1633 /* Don't keep command history around forever. */
1634 if (NUMBERP (Vhistory_length
) && XINT (Vhistory_length
) > 0)
1636 tem
= Fnthcdr (Vhistory_length
, Vcommand_history
);
1638 XCONS (tem
)->cdr
= Qnil
;
1641 /* Likewise for undo information. */
1643 register struct buffer
*nextb
= all_buffers
;
1647 /* If a buffer's undo list is Qt, that means that undo is
1648 turned off in that buffer. Calling truncate_undo_list on
1649 Qt tends to return NULL, which effectively turns undo back on.
1650 So don't call truncate_undo_list if undo_list is Qt. */
1651 if (! EQ (nextb
->undo_list
, Qt
))
1653 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1655 nextb
= nextb
->next
;
1661 /* clear_marks (); */
1663 /* In each "large string", set the MARKBIT of the size field.
1664 That enables mark_object to recognize them. */
1666 register struct string_block
*b
;
1667 for (b
= large_string_blocks
; b
; b
= b
->next
)
1668 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1671 /* Mark all the special slots that serve as the roots of accessibility.
1673 Usually the special slots to mark are contained in particular structures.
1674 Then we know no slot is marked twice because the structures don't overlap.
1675 In some cases, the structures point to the slots to be marked.
1676 For these, we use MARKBIT to avoid double marking of the slot. */
1678 for (i
= 0; i
< staticidx
; i
++)
1679 mark_object (staticvec
[i
]);
1680 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1681 for (i
= 0; i
< tail
->nvars
; i
++)
1682 if (!XMARKBIT (tail
->var
[i
]))
1684 mark_object (&tail
->var
[i
]);
1685 XMARK (tail
->var
[i
]);
1687 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1689 mark_object (&bind
->symbol
);
1690 mark_object (&bind
->old_value
);
1692 for (catch = catchlist
; catch; catch = catch->next
)
1694 mark_object (&catch->tag
);
1695 mark_object (&catch->val
);
1697 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1699 mark_object (&handler
->handler
);
1700 mark_object (&handler
->var
);
1702 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1704 if (!XMARKBIT (*backlist
->function
))
1706 mark_object (backlist
->function
);
1707 XMARK (*backlist
->function
);
1709 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1712 i
= backlist
->nargs
- 1;
1714 if (!XMARKBIT (backlist
->args
[i
]))
1716 mark_object (&backlist
->args
[i
]);
1717 XMARK (backlist
->args
[i
]);
1724 /* Clear the mark bits that we set in certain root slots. */
1726 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1727 for (i
= 0; i
< tail
->nvars
; i
++)
1728 XUNMARK (tail
->var
[i
]);
1729 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1731 XUNMARK (*backlist
->function
);
1732 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1735 i
= backlist
->nargs
- 1;
1737 XUNMARK (backlist
->args
[i
]);
1739 XUNMARK (buffer_defaults
.name
);
1740 XUNMARK (buffer_local_symbols
.name
);
1742 /* clear_marks (); */
1745 consing_since_gc
= 0;
1746 if (gc_cons_threshold
< 10000)
1747 gc_cons_threshold
= 10000;
1749 if (garbage_collection_messages
)
1751 if (omessage
|| minibuf_level
> 0)
1752 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1754 message1_nolog ("Garbage collecting...done");
1757 return Fcons (Fcons (make_number (total_conses
),
1758 make_number (total_free_conses
)),
1759 Fcons (Fcons (make_number (total_symbols
),
1760 make_number (total_free_symbols
)),
1761 Fcons (Fcons (make_number (total_markers
),
1762 make_number (total_free_markers
)),
1763 Fcons (make_number (total_string_size
),
1764 Fcons (make_number (total_vector_size
),
1766 #ifdef LISP_FLOAT_TYPE
1767 (make_number (total_floats
),
1768 make_number (total_free_floats
)),
1769 #else /* not LISP_FLOAT_TYPE */
1770 (make_number (0), make_number (0)),
1771 #endif /* not LISP_FLOAT_TYPE */
1773 #ifdef USE_TEXT_PROPERTIES
1774 (make_number (total_intervals
),
1775 make_number (total_free_intervals
)),
1776 #else /* not USE_TEXT_PROPERTIES */
1777 (make_number (0), make_number (0)),
1778 #endif /* not USE_TEXT_PROPERTIES */
1786 /* Clear marks on all conses */
1788 register struct cons_block
*cblk
;
1789 register int lim
= cons_block_index
;
1791 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1794 for (i
= 0; i
< lim
; i
++)
1795 XUNMARK (cblk
->conses
[i
].car
);
1796 lim
= CONS_BLOCK_SIZE
;
1799 /* Clear marks on all symbols */
1801 register struct symbol_block
*sblk
;
1802 register int lim
= symbol_block_index
;
1804 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1807 for (i
= 0; i
< lim
; i
++)
1809 XUNMARK (sblk
->symbols
[i
].plist
);
1811 lim
= SYMBOL_BLOCK_SIZE
;
1814 /* Clear marks on all markers */
1816 register struct marker_block
*sblk
;
1817 register int lim
= marker_block_index
;
1819 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1822 for (i
= 0; i
< lim
; i
++)
1823 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1824 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1825 lim
= MARKER_BLOCK_SIZE
;
1828 /* Clear mark bits on all buffers */
1830 register struct buffer
*nextb
= all_buffers
;
1834 XUNMARK (nextb
->name
);
1835 nextb
= nextb
->next
;
1841 /* Mark reference to a Lisp_Object.
1842 If the object referred to has not been seen yet, recursively mark
1843 all the references contained in it.
1845 If the object referenced is a short string, the referencing slot
1846 is threaded into a chain of such slots, pointed to from
1847 the `size' field of the string. The actual string size
1848 lives in the last slot in the chain. We recognize the end
1849 because it is < (unsigned) STRING_BLOCK_SIZE. */
1851 #define LAST_MARKED_SIZE 500
1852 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1853 int last_marked_index
;
1856 mark_object (argptr
)
1857 Lisp_Object
*argptr
;
1859 Lisp_Object
*objptr
= argptr
;
1860 register Lisp_Object obj
;
1867 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1868 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1871 last_marked
[last_marked_index
++] = objptr
;
1872 if (last_marked_index
== LAST_MARKED_SIZE
)
1873 last_marked_index
= 0;
1875 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1879 register struct Lisp_String
*ptr
= XSTRING (obj
);
1881 MARK_INTERVAL_TREE (ptr
->intervals
);
1882 if (ptr
->size
& MARKBIT
)
1883 /* A large string. Just set ARRAY_MARK_FLAG. */
1884 ptr
->size
|= ARRAY_MARK_FLAG
;
1887 /* A small string. Put this reference
1888 into the chain of references to it.
1889 If the address includes MARKBIT, put that bit elsewhere
1890 when we store OBJPTR into the size field. */
1892 if (XMARKBIT (*objptr
))
1894 XSETFASTINT (*objptr
, ptr
->size
);
1898 XSETFASTINT (*objptr
, ptr
->size
);
1900 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1902 ptr
->size
= (EMACS_INT
) objptr
;
1903 if (ptr
->size
& MARKBIT
)
1904 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1909 case Lisp_Vectorlike
:
1910 if (GC_BUFFERP (obj
))
1912 if (!XMARKBIT (XBUFFER (obj
)->name
))
1915 else if (GC_SUBRP (obj
))
1917 else if (GC_COMPILEDP (obj
))
1918 /* We could treat this just like a vector, but it is better
1919 to save the COMPILED_CONSTANTS element for last and avoid recursion
1922 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1923 register EMACS_INT size
= ptr
->size
;
1924 /* See comment above under Lisp_Vector. */
1925 struct Lisp_Vector
*volatile ptr1
= ptr
;
1928 if (size
& ARRAY_MARK_FLAG
)
1929 break; /* Already marked */
1930 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1931 size
&= PSEUDOVECTOR_SIZE_MASK
;
1932 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1934 if (i
!= COMPILED_CONSTANTS
)
1935 mark_object (&ptr1
->contents
[i
]);
1937 /* This cast should be unnecessary, but some Mips compiler complains
1938 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1939 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1942 else if (GC_FRAMEP (obj
))
1944 /* See comment above under Lisp_Vector for why this is volatile. */
1945 register struct frame
*volatile ptr
= XFRAME (obj
);
1946 register EMACS_INT size
= ptr
->size
;
1948 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1949 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1951 mark_object (&ptr
->name
);
1952 mark_object (&ptr
->icon_name
);
1953 mark_object (&ptr
->title
);
1954 mark_object (&ptr
->focus_frame
);
1955 mark_object (&ptr
->selected_window
);
1956 mark_object (&ptr
->minibuffer_window
);
1957 mark_object (&ptr
->param_alist
);
1958 mark_object (&ptr
->scroll_bars
);
1959 mark_object (&ptr
->condemned_scroll_bars
);
1960 mark_object (&ptr
->menu_bar_items
);
1961 mark_object (&ptr
->face_alist
);
1962 mark_object (&ptr
->menu_bar_vector
);
1963 mark_object (&ptr
->buffer_predicate
);
1964 mark_object (&ptr
->buffer_list
);
1966 else if (GC_BOOL_VECTOR_P (obj
))
1968 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1970 if (ptr
->size
& ARRAY_MARK_FLAG
)
1971 break; /* Already marked */
1972 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1976 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1977 register EMACS_INT size
= ptr
->size
;
1978 /* The reason we use ptr1 is to avoid an apparent hardware bug
1979 that happens occasionally on the FSF's HP 300s.
1980 The bug is that a2 gets clobbered by recursive calls to mark_object.
1981 The clobberage seems to happen during function entry,
1982 perhaps in the moveml instruction.
1983 Yes, this is a crock, but we have to do it. */
1984 struct Lisp_Vector
*volatile ptr1
= ptr
;
1987 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1988 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1989 if (size
& PSEUDOVECTOR_FLAG
)
1990 size
&= PSEUDOVECTOR_SIZE_MASK
;
1991 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1992 mark_object (&ptr1
->contents
[i
]);
1998 /* See comment above under Lisp_Vector for why this is volatile. */
1999 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2000 struct Lisp_Symbol
*ptrx
;
2002 if (XMARKBIT (ptr
->plist
)) break;
2004 mark_object ((Lisp_Object
*) &ptr
->value
);
2005 mark_object (&ptr
->function
);
2006 mark_object (&ptr
->plist
);
2007 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2008 mark_object (&ptr
->name
);
2012 /* For the benefit of the last_marked log. */
2013 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2014 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2015 XSETSYMBOL (obj
, ptrx
);
2016 /* We can't goto loop here because *objptr doesn't contain an
2017 actual Lisp_Object with valid datatype field. */
2024 switch (XMISCTYPE (obj
))
2026 case Lisp_Misc_Marker
:
2027 XMARK (XMARKER (obj
)->chain
);
2028 /* DO NOT mark thru the marker's chain.
2029 The buffer's markers chain does not preserve markers from gc;
2030 instead, markers are removed from the chain when freed by gc. */
2033 case Lisp_Misc_Buffer_Local_Value
:
2034 case Lisp_Misc_Some_Buffer_Local_Value
:
2036 register struct Lisp_Buffer_Local_Value
*ptr
2037 = XBUFFER_LOCAL_VALUE (obj
);
2038 if (XMARKBIT (ptr
->car
)) break;
2040 /* If the cdr is nil, avoid recursion for the car. */
2041 if (EQ (ptr
->cdr
, Qnil
))
2046 mark_object (&ptr
->car
);
2047 /* See comment above under Lisp_Vector for why not use ptr here. */
2048 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2052 case Lisp_Misc_Intfwd
:
2053 case Lisp_Misc_Boolfwd
:
2054 case Lisp_Misc_Objfwd
:
2055 case Lisp_Misc_Buffer_Objfwd
:
2056 case Lisp_Misc_Kboard_Objfwd
:
2057 /* Don't bother with Lisp_Buffer_Objfwd,
2058 since all markable slots in current buffer marked anyway. */
2059 /* Don't need to do Lisp_Objfwd, since the places they point
2060 are protected with staticpro. */
2063 case Lisp_Misc_Overlay
:
2065 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2066 if (!XMARKBIT (ptr
->plist
))
2069 mark_object (&ptr
->start
);
2070 mark_object (&ptr
->end
);
2071 objptr
= &ptr
->plist
;
2084 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2085 if (XMARKBIT (ptr
->car
)) break;
2087 /* If the cdr is nil, avoid recursion for the car. */
2088 if (EQ (ptr
->cdr
, Qnil
))
2093 mark_object (&ptr
->car
);
2094 /* See comment above under Lisp_Vector for why not use ptr here. */
2095 objptr
= &XCONS (obj
)->cdr
;
2099 #ifdef LISP_FLOAT_TYPE
2101 XMARK (XFLOAT (obj
)->type
);
2103 #endif /* LISP_FLOAT_TYPE */
2113 /* Mark the pointers in a buffer structure. */
2119 register struct buffer
*buffer
= XBUFFER (buf
);
2120 register Lisp_Object
*ptr
;
2121 Lisp_Object base_buffer
;
2123 /* This is the buffer's markbit */
2124 mark_object (&buffer
->name
);
2125 XMARK (buffer
->name
);
2127 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2130 mark_object (buffer
->syntax_table
);
2132 /* Mark the various string-pointers in the buffer object.
2133 Since the strings may be relocated, we must mark them
2134 in their actual slots. So gc_sweep must convert each slot
2135 back to an ordinary C pointer. */
2136 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2137 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2138 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2139 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2141 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2142 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2143 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2144 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2147 for (ptr
= &buffer
->name
+ 1;
2148 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2152 /* If this is an indirect buffer, mark its base buffer. */
2153 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2155 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2156 mark_buffer (base_buffer
);
2161 /* Mark the pointers in the kboard objects. */
2168 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2170 if (kb
->kbd_macro_buffer
)
2171 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2173 mark_object (&kb
->Vprefix_arg
);
2174 mark_object (&kb
->kbd_queue
);
2175 mark_object (&kb
->Vlast_kbd_macro
);
2176 mark_object (&kb
->Vsystem_key_alist
);
2177 mark_object (&kb
->system_key_syms
);
2181 /* Sweep: find all structures not marked, and free them. */
2186 total_string_size
= 0;
2189 /* Put all unmarked conses on free list */
2191 register struct cons_block
*cblk
;
2192 struct cons_block
**cprev
= &cons_block
;
2193 register int lim
= cons_block_index
;
2194 register int num_free
= 0, num_used
= 0;
2198 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2202 for (i
= 0; i
< lim
; i
++)
2203 if (!XMARKBIT (cblk
->conses
[i
].car
))
2207 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2208 cons_free_list
= &cblk
->conses
[i
];
2213 XUNMARK (cblk
->conses
[i
].car
);
2215 lim
= CONS_BLOCK_SIZE
;
2216 /* If this block contains only free conses and we have already
2217 seen more than two blocks worth of free conses then deallocate
2219 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> 2*CONS_BLOCK_SIZE
)
2221 num_free
-= CONS_BLOCK_SIZE
;
2222 *cprev
= cblk
->next
;
2223 /* Unhook from the free list. */
2224 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2228 cprev
= &cblk
->next
;
2230 total_conses
= num_used
;
2231 total_free_conses
= num_free
;
2234 #ifdef LISP_FLOAT_TYPE
2235 /* Put all unmarked floats on free list */
2237 register struct float_block
*fblk
;
2238 struct float_block
**fprev
= &float_block
;
2239 register int lim
= float_block_index
;
2240 register int num_free
= 0, num_used
= 0;
2242 float_free_list
= 0;
2244 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2248 for (i
= 0; i
< lim
; i
++)
2249 if (!XMARKBIT (fblk
->floats
[i
].type
))
2253 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2254 float_free_list
= &fblk
->floats
[i
];
2259 XUNMARK (fblk
->floats
[i
].type
);
2261 lim
= FLOAT_BLOCK_SIZE
;
2262 /* If this block contains only free floats and we have already
2263 seen more than two blocks worth of free floats then deallocate
2265 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> 2*FLOAT_BLOCK_SIZE
)
2267 num_free
-= FLOAT_BLOCK_SIZE
;
2268 *fprev
= fblk
->next
;
2269 /* Unhook from the free list. */
2270 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2274 fprev
= &fblk
->next
;
2276 total_floats
= num_used
;
2277 total_free_floats
= num_free
;
2279 #endif /* LISP_FLOAT_TYPE */
2281 #ifdef USE_TEXT_PROPERTIES
2282 /* Put all unmarked intervals on free list */
2284 register struct interval_block
*iblk
;
2285 struct interval_block
**iprev
= &interval_block
;
2286 register int lim
= interval_block_index
;
2287 register int num_free
= 0, num_used
= 0;
2289 interval_free_list
= 0;
2291 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2296 for (i
= 0; i
< lim
; i
++)
2298 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2300 iblk
->intervals
[i
].parent
= interval_free_list
;
2301 interval_free_list
= &iblk
->intervals
[i
];
2308 XUNMARK (iblk
->intervals
[i
].plist
);
2311 lim
= INTERVAL_BLOCK_SIZE
;
2312 /* If this block contains only free intervals and we have already
2313 seen more than two blocks worth of free intervals then
2314 deallocate this block. */
2315 if (this_free
== INTERVAL_BLOCK_SIZE
2316 && num_free
> 2*INTERVAL_BLOCK_SIZE
)
2318 num_free
-= INTERVAL_BLOCK_SIZE
;
2319 *iprev
= iblk
->next
;
2320 /* Unhook from the free list. */
2321 interval_free_list
= iblk
->intervals
[0].parent
;
2325 iprev
= &iblk
->next
;
2327 total_intervals
= num_used
;
2328 total_free_intervals
= num_free
;
2330 #endif /* USE_TEXT_PROPERTIES */
2332 /* Put all unmarked symbols on free list */
2334 register struct symbol_block
*sblk
;
2335 struct symbol_block
**sprev
= &symbol_block
;
2336 register int lim
= symbol_block_index
;
2337 register int num_free
= 0, num_used
= 0;
2339 symbol_free_list
= 0;
2341 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2345 for (i
= 0; i
< lim
; i
++)
2346 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2348 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2349 symbol_free_list
= &sblk
->symbols
[i
];
2356 sblk
->symbols
[i
].name
2357 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2358 XUNMARK (sblk
->symbols
[i
].plist
);
2360 lim
= SYMBOL_BLOCK_SIZE
;
2361 /* If this block contains only free symbols and we have already
2362 seen more than two blocks worth of free symbols then deallocate
2364 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> 2*SYMBOL_BLOCK_SIZE
)
2366 num_free
-= SYMBOL_BLOCK_SIZE
;
2367 *sprev
= sblk
->next
;
2368 /* Unhook from the free list. */
2369 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2373 sprev
= &sblk
->next
;
2375 total_symbols
= num_used
;
2376 total_free_symbols
= num_free
;
2380 /* Put all unmarked markers on free list.
2381 Unchain each one first from the buffer it points into,
2382 but only if it's a real marker. */
2384 register struct marker_block
*mblk
;
2385 struct marker_block
**mprev
= &marker_block
;
2386 register int lim
= marker_block_index
;
2387 register int num_free
= 0, num_used
= 0;
2389 marker_free_list
= 0;
2391 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2395 EMACS_INT already_free
= -1;
2397 for (i
= 0; i
< lim
; i
++)
2399 Lisp_Object
*markword
;
2400 switch (mblk
->markers
[i
].u_marker
.type
)
2402 case Lisp_Misc_Marker
:
2403 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2405 case Lisp_Misc_Buffer_Local_Value
:
2406 case Lisp_Misc_Some_Buffer_Local_Value
:
2407 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2409 case Lisp_Misc_Overlay
:
2410 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2412 case Lisp_Misc_Free
:
2413 /* If the object was already free, keep it
2414 on the free list. */
2415 markword
= (Lisp_Object
*) &already_free
;
2421 if (markword
&& !XMARKBIT (*markword
))
2424 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2426 /* tem1 avoids Sun compiler bug */
2427 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2428 XSETMARKER (tem
, tem1
);
2429 unchain_marker (tem
);
2431 /* Set the type of the freed object to Lisp_Misc_Free.
2432 We could leave the type alone, since nobody checks it,
2433 but this might catch bugs faster. */
2434 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2435 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2436 marker_free_list
= &mblk
->markers
[i
];
2444 XUNMARK (*markword
);
2447 lim
= MARKER_BLOCK_SIZE
;
2448 /* If this block contains only free markers and we have already
2449 seen more than two blocks worth of free markers then deallocate
2451 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> 2*MARKER_BLOCK_SIZE
)
2453 num_free
-= MARKER_BLOCK_SIZE
;
2454 *mprev
= mblk
->next
;
2455 /* Unhook from the free list. */
2456 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2460 mprev
= &mblk
->next
;
2463 total_markers
= num_used
;
2464 total_free_markers
= num_free
;
2467 /* Free all unmarked buffers */
2469 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2472 if (!XMARKBIT (buffer
->name
))
2475 prev
->next
= buffer
->next
;
2477 all_buffers
= buffer
->next
;
2478 next
= buffer
->next
;
2484 XUNMARK (buffer
->name
);
2485 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2488 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2489 for purposes of marking and relocation.
2490 Turn them back into C pointers now. */
2491 buffer
->upcase_table
2492 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2493 buffer
->downcase_table
2494 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2496 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2497 buffer
->folding_sort_table
2498 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2501 prev
= buffer
, buffer
= buffer
->next
;
2505 #endif /* standalone */
2507 /* Free all unmarked vectors */
2509 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2510 total_vector_size
= 0;
2513 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2516 prev
->next
= vector
->next
;
2518 all_vectors
= vector
->next
;
2519 next
= vector
->next
;
2525 vector
->size
&= ~ARRAY_MARK_FLAG
;
2526 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2527 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2529 total_vector_size
+= vector
->size
;
2530 prev
= vector
, vector
= vector
->next
;
2534 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2536 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2537 struct Lisp_String
*s
;
2541 s
= (struct Lisp_String
*) &sb
->chars
[0];
2542 if (s
->size
& ARRAY_MARK_FLAG
)
2544 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2545 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2546 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2547 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2548 prev
= sb
, sb
= sb
->next
;
2553 prev
->next
= sb
->next
;
2555 large_string_blocks
= sb
->next
;
2564 /* Compactify strings, relocate references, and free empty string blocks. */
2569 /* String block of old strings we are scanning. */
2570 register struct string_block
*from_sb
;
2571 /* A preceding string block (or maybe the same one)
2572 where we are copying the still-live strings to. */
2573 register struct string_block
*to_sb
;
2577 to_sb
= first_string_block
;
2580 /* Scan each existing string block sequentially, string by string. */
2581 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2584 /* POS is the index of the next string in the block. */
2585 while (pos
< from_sb
->pos
)
2587 register struct Lisp_String
*nextstr
2588 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2590 register struct Lisp_String
*newaddr
;
2591 register EMACS_INT size
= nextstr
->size
;
2592 EMACS_INT size_byte
= nextstr
->size_byte
;
2594 /* NEXTSTR is the old address of the next string.
2595 Just skip it if it isn't marked. */
2596 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2598 /* It is marked, so its size field is really a chain of refs.
2599 Find the end of the chain, where the actual size lives. */
2600 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2602 if (size
& DONT_COPY_FLAG
)
2603 size
^= MARKBIT
| DONT_COPY_FLAG
;
2604 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2607 total_string_size
+= size_byte
;
2609 /* If it won't fit in TO_SB, close it out,
2610 and move to the next sb. Keep doing so until
2611 TO_SB reaches a large enough, empty enough string block.
2612 We know that TO_SB cannot advance past FROM_SB here
2613 since FROM_SB is large enough to contain this string.
2614 Any string blocks skipped here
2615 will be patched out and freed later. */
2616 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2617 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2619 to_sb
->pos
= to_pos
;
2620 to_sb
= to_sb
->next
;
2623 /* Compute new address of this string
2624 and update TO_POS for the space being used. */
2625 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2626 to_pos
+= STRING_FULLSIZE (size_byte
);
2628 /* Copy the string itself to the new place. */
2629 if (nextstr
!= newaddr
)
2630 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2632 /* Go through NEXTSTR's chain of references
2633 and make each slot in the chain point to
2634 the new address of this string. */
2635 size
= newaddr
->size
;
2636 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2638 register Lisp_Object
*objptr
;
2639 if (size
& DONT_COPY_FLAG
)
2640 size
^= MARKBIT
| DONT_COPY_FLAG
;
2641 objptr
= (Lisp_Object
*)size
;
2643 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2644 if (XMARKBIT (*objptr
))
2646 XSETSTRING (*objptr
, newaddr
);
2650 XSETSTRING (*objptr
, newaddr
);
2652 /* Store the actual size in the size field. */
2653 newaddr
->size
= size
;
2655 #ifdef USE_TEXT_PROPERTIES
2656 /* Now that the string has been relocated, rebalance its
2657 interval tree, and update the tree's parent pointer. */
2658 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2660 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2661 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2664 #endif /* USE_TEXT_PROPERTIES */
2666 pos
+= STRING_FULLSIZE (size_byte
);
2670 /* Close out the last string block still used and free any that follow. */
2671 to_sb
->pos
= to_pos
;
2672 current_string_block
= to_sb
;
2674 from_sb
= to_sb
->next
;
2678 to_sb
= from_sb
->next
;
2683 /* Free any empty string blocks further back in the chain.
2684 This loop will never free first_string_block, but it is very
2685 unlikely that that one will become empty, so why bother checking? */
2687 from_sb
= first_string_block
;
2688 while (to_sb
= from_sb
->next
)
2690 if (to_sb
->pos
== 0)
2692 if (from_sb
->next
= to_sb
->next
)
2693 from_sb
->next
->prev
= from_sb
;
2701 /* Debugging aids. */
2703 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2704 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2705 This may be helpful in debugging Emacs's memory usage.\n\
2706 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2711 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2716 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2717 "Return a list of counters that measure how much consing there has been.\n\
2718 Each of these counters increments for a certain kind of object.\n\
2719 The counters wrap around from the largest positive integer to zero.\n\
2720 Garbage collection does not decrease them.\n\
2721 The elements of the value are as follows:\n\
2722 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2723 All are in units of 1 = one object consed\n\
2724 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2726 MISCS include overlays, markers, and some internal types.\n\
2727 Frames, windows, buffers, and subprocesses count as vectors\n\
2728 (but the contents of a buffer's text do not count here).")
2731 Lisp_Object lisp_cons_cells_consed
;
2732 Lisp_Object lisp_floats_consed
;
2733 Lisp_Object lisp_vector_cells_consed
;
2734 Lisp_Object lisp_symbols_consed
;
2735 Lisp_Object lisp_string_chars_consed
;
2736 Lisp_Object lisp_misc_objects_consed
;
2737 Lisp_Object lisp_intervals_consed
;
2739 XSETINT (lisp_cons_cells_consed
,
2740 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2741 XSETINT (lisp_floats_consed
,
2742 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2743 XSETINT (lisp_vector_cells_consed
,
2744 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2745 XSETINT (lisp_symbols_consed
,
2746 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2747 XSETINT (lisp_string_chars_consed
,
2748 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2749 XSETINT (lisp_misc_objects_consed
,
2750 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2751 XSETINT (lisp_intervals_consed
,
2752 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2754 return Fcons (lisp_cons_cells_consed
,
2755 Fcons (lisp_floats_consed
,
2756 Fcons (lisp_vector_cells_consed
,
2757 Fcons (lisp_symbols_consed
,
2758 Fcons (lisp_string_chars_consed
,
2759 Fcons (lisp_misc_objects_consed
,
2760 Fcons (lisp_intervals_consed
,
2764 /* Initialization */
2768 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2771 pure_size
= PURESIZE
;
2774 ignore_warnings
= 1;
2775 #ifdef DOUG_LEA_MALLOC
2776 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2777 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2778 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2784 #ifdef LISP_FLOAT_TYPE
2786 #endif /* LISP_FLOAT_TYPE */
2790 malloc_hysteresis
= 32;
2792 malloc_hysteresis
= 0;
2795 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2797 ignore_warnings
= 0;
2800 consing_since_gc
= 0;
2801 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2802 #ifdef VIRT_ADDR_VARIES
2803 malloc_sbrk_unused
= 1<<22; /* A large number */
2804 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2805 #endif /* VIRT_ADDR_VARIES */
2816 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2817 "*Number of bytes of consing between garbage collections.\n\
2818 Garbage collection can happen automatically once this many bytes have been\n\
2819 allocated since the last garbage collection. All data types count.\n\n\
2820 Garbage collection happens automatically only when `eval' is called.\n\n\
2821 By binding this temporarily to a large number, you can effectively\n\
2822 prevent garbage collection during a part of the program.");
2824 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2825 "Number of bytes of sharable Lisp data allocated so far.");
2827 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2828 "Number of cons cells that have been consed so far.");
2830 DEFVAR_INT ("floats-consed", &floats_consed
,
2831 "Number of floats that have been consed so far.");
2833 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2834 "Number of vector cells that have been consed so far.");
2836 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2837 "Number of symbols that have been consed so far.");
2839 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2840 "Number of string characters that have been consed so far.");
2842 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2843 "Number of miscellaneous objects that have been consed so far.");
2845 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2846 "Number of intervals that have been consed so far.");
2849 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2850 "Number of bytes of unshared memory allocated in this session.");
2852 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2853 "Number of bytes of unshared memory remaining available in this session.");
2856 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2857 "Non-nil means loading Lisp code in order to dump an executable.\n\
2858 This means that certain objects should be allocated in shared (pure) space.");
2860 DEFVAR_INT ("undo-limit", &undo_limit
,
2861 "Keep no more undo information once it exceeds this size.\n\
2862 This limit is applied when garbage collection happens.\n\
2863 The size is counted as the number of bytes occupied,\n\
2864 which includes both saved text and other data.");
2867 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2868 "Don't keep more than this much size of undo information.\n\
2869 A command which pushes past this size is itself forgotten.\n\
2870 This limit is applied when garbage collection happens.\n\
2871 The size is counted as the number of bytes occupied,\n\
2872 which includes both saved text and other data.");
2873 undo_strong_limit
= 30000;
2875 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2876 "Non-nil means display messages at start and end of garbage collection.");
2877 garbage_collection_messages
= 0;
2879 /* We build this in advance because if we wait until we need it, we might
2880 not be able to allocate the memory to hold it. */
2882 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2883 staticpro (&memory_signal_data
);
2885 staticpro (&Qgc_cons_threshold
);
2886 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2888 staticpro (&Qchar_table_extra_slots
);
2889 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2894 defsubr (&Smake_byte_code
);
2895 defsubr (&Smake_list
);
2896 defsubr (&Smake_vector
);
2897 defsubr (&Smake_char_table
);
2898 defsubr (&Smake_string
);
2899 defsubr (&Smake_bool_vector
);
2900 defsubr (&Smake_symbol
);
2901 defsubr (&Smake_marker
);
2902 defsubr (&Spurecopy
);
2903 defsubr (&Sgarbage_collect
);
2904 defsubr (&Smemory_limit
);
2905 defsubr (&Smemory_use_counts
);