1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
21 /* Note that this declares bzero on OSF/1. How dumb. */
26 #include "intervals.h"
32 #include "blockinput.h"
36 #include "syssignal.h"
40 #ifdef DOUG_LEA_MALLOC
42 #define __malloc_size_t int
44 /* The following come from gmalloc.c. */
46 #if defined (__STDC__) && __STDC__
48 #define __malloc_size_t size_t
50 #define __malloc_size_t unsigned int
52 extern __malloc_size_t _bytes_used
;
53 extern int __malloc_extra_blocks
;
54 #endif /* !defined(DOUG_LEA_MALLOC) */
56 extern Lisp_Object Vhistory_length
;
58 #define max(A,B) ((A) > (B) ? (A) : (B))
59 #define min(A,B) ((A) < (B) ? (A) : (B))
61 /* Macro to verify that storage intended for Lisp objects is not
62 out of range to fit in the space for a pointer.
63 ADDRESS is the start of the block, and SIZE
64 is the amount of space within which objects can start. */
65 #define VALIDATE_LISP_STORAGE(address, size) \
69 XSETCONS (val, (char *) address + size); \
70 if ((char *) XCONS (val) != (char *) address + size) \
77 /* Value of _bytes_used, when spare_memory was freed. */
78 static __malloc_size_t bytes_used_when_full
;
80 /* Number of bytes of consing done since the last gc */
83 /* Count the amount of consing of various sorts of space. */
84 int cons_cells_consed
;
86 int vector_cells_consed
;
88 int string_chars_consed
;
89 int misc_objects_consed
;
92 /* Number of bytes of consing since gc before another gc should be done. */
93 int gc_cons_threshold
;
95 /* Nonzero during gc */
98 /* Nonzero means display messages at beginning and end of GC. */
99 int garbage_collection_messages
;
101 #ifndef VIRT_ADDR_VARIES
103 #endif /* VIRT_ADDR_VARIES */
104 int malloc_sbrk_used
;
106 #ifndef VIRT_ADDR_VARIES
108 #endif /* VIRT_ADDR_VARIES */
109 int malloc_sbrk_unused
;
111 /* Two limits controlling how much undo information to keep. */
113 int undo_strong_limit
;
115 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
116 int total_free_conses
, total_free_markers
, total_free_symbols
;
117 #ifdef LISP_FLOAT_TYPE
118 int total_free_floats
, total_floats
;
119 #endif /* LISP_FLOAT_TYPE */
121 /* Points to memory space allocated as "spare",
122 to be freed if we run out of memory. */
123 static char *spare_memory
;
125 /* Amount of spare memory to keep in reserve. */
126 #define SPARE_MEMORY (1 << 14)
128 /* Number of extra blocks malloc should get when it needs more core. */
129 static int malloc_hysteresis
;
131 /* Nonzero when malloc is called for allocating Lisp object space. */
132 int allocating_for_lisp
;
134 /* Non-nil means defun should do purecopy on the function definition */
135 Lisp_Object Vpurify_flag
;
138 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
139 #define PUREBEG (char *) pure
141 #define pure PURE_SEG_BITS /* Use shared memory segment */
142 #define PUREBEG (char *)PURE_SEG_BITS
144 /* This variable is used only by the XPNTR macro when HAVE_SHM is
145 defined. If we used the PURESIZE macro directly there, that would
146 make most of emacs dependent on puresize.h, which we don't want -
147 you should be able to change that without too much recompilation.
148 So map_in_data initializes pure_size, and the dependencies work
151 #endif /* not HAVE_SHM */
153 /* Index in pure at which next pure object will be allocated. */
156 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
157 char *pending_malloc_warning
;
159 /* Pre-computed signal argument for use when memory is exhausted. */
160 Lisp_Object memory_signal_data
;
162 /* Maximum amount of C stack to save when a GC happens. */
164 #ifndef MAX_SAVE_STACK
165 #define MAX_SAVE_STACK 16000
168 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
169 pointer to a Lisp_Object, when that pointer is viewed as an integer.
170 (On most machines, pointers are even, so we can use the low bit.
171 Word-addressable architectures may need to override this in the m-file.)
172 When linking references to small strings through the size field, we
173 use this slot to hold the bit that would otherwise be interpreted as
175 #ifndef DONT_COPY_FLAG
176 #define DONT_COPY_FLAG 1
177 #endif /* no DONT_COPY_FLAG */
179 /* Buffer in which we save a copy of the C stack at each GC. */
184 /* Non-zero means ignore malloc warnings. Set during initialization. */
187 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
189 static void mark_object (), mark_buffer (), mark_kboards ();
190 static void clear_marks (), gc_sweep ();
191 static void compact_strings ();
193 extern int message_enable_multibyte
;
195 /* Versions of malloc and realloc that print warnings as memory gets full. */
198 malloc_warning_1 (str
)
201 Fprinc (str
, Vstandard_output
);
202 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
203 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
204 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
208 /* malloc calls this if it finds we are near exhausting storage */
214 pending_malloc_warning
= str
;
218 display_malloc_warning ()
220 register Lisp_Object val
;
222 val
= build_string (pending_malloc_warning
);
223 pending_malloc_warning
= 0;
224 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
227 #ifdef DOUG_LEA_MALLOC
228 # define BYTES_USED (mallinfo ().arena)
230 # define BYTES_USED _bytes_used
233 /* Called if malloc returns zero */
238 #ifndef SYSTEM_MALLOC
239 bytes_used_when_full
= BYTES_USED
;
242 /* The first time we get here, free the spare memory. */
249 /* This used to call error, but if we've run out of memory, we could get
250 infinite recursion trying to build the string. */
252 Fsignal (Qnil
, memory_signal_data
);
255 /* Called if we can't allocate relocatable space for a buffer. */
258 buffer_memory_full ()
260 /* If buffers use the relocating allocator,
261 no need to free spare_memory, because we may have plenty of malloc
262 space left that we could get, and if we don't, the malloc that fails
263 will itself cause spare_memory to be freed.
264 If buffers don't use the relocating allocator,
265 treat this like any other failing malloc. */
271 /* This used to call error, but if we've run out of memory, we could get
272 infinite recursion trying to build the string. */
274 Fsignal (Qerror
, memory_signal_data
);
277 /* like malloc routines but check for no memory and block interrupt input. */
286 val
= (long *) malloc (size
);
289 if (!val
&& size
) memory_full ();
294 xrealloc (block
, size
)
301 /* We must call malloc explicitly when BLOCK is 0, since some
302 reallocs don't do this. */
304 val
= (long *) malloc (size
);
306 val
= (long *) realloc (block
, size
);
309 if (!val
&& size
) memory_full ();
323 /* Arranging to disable input signals while we're in malloc.
325 This only works with GNU malloc. To help out systems which can't
326 use GNU malloc, all the calls to malloc, realloc, and free
327 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
328 pairs; unfortunately, we have no idea what C library functions
329 might call malloc, so we can't really protect them unless you're
330 using GNU malloc. Fortunately, most of the major operating can use
333 #ifndef SYSTEM_MALLOC
334 extern void * (*__malloc_hook
) ();
335 static void * (*old_malloc_hook
) ();
336 extern void * (*__realloc_hook
) ();
337 static void * (*old_realloc_hook
) ();
338 extern void (*__free_hook
) ();
339 static void (*old_free_hook
) ();
341 /* This function is used as the hook for free to call. */
344 emacs_blocked_free (ptr
)
348 __free_hook
= old_free_hook
;
350 /* If we released our reserve (due to running out of memory),
351 and we have a fair amount free once again,
352 try to set aside another reserve in case we run out once more. */
353 if (spare_memory
== 0
354 /* Verify there is enough space that even with the malloc
355 hysteresis this call won't run out again.
356 The code here is correct as long as SPARE_MEMORY
357 is substantially larger than the block size malloc uses. */
358 && (bytes_used_when_full
359 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
360 spare_memory
= (char *) malloc (SPARE_MEMORY
);
362 __free_hook
= emacs_blocked_free
;
366 /* If we released our reserve (due to running out of memory),
367 and we have a fair amount free once again,
368 try to set aside another reserve in case we run out once more.
370 This is called when a relocatable block is freed in ralloc.c. */
373 refill_memory_reserve ()
375 if (spare_memory
== 0)
376 spare_memory
= (char *) malloc (SPARE_MEMORY
);
379 /* This function is the malloc hook that Emacs uses. */
382 emacs_blocked_malloc (size
)
388 __malloc_hook
= old_malloc_hook
;
389 #ifdef DOUG_LEA_MALLOC
390 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
392 __malloc_extra_blocks
= malloc_hysteresis
;
394 value
= (void *) malloc (size
);
395 __malloc_hook
= emacs_blocked_malloc
;
402 emacs_blocked_realloc (ptr
, size
)
409 __realloc_hook
= old_realloc_hook
;
410 value
= (void *) realloc (ptr
, size
);
411 __realloc_hook
= emacs_blocked_realloc
;
418 uninterrupt_malloc ()
420 old_free_hook
= __free_hook
;
421 __free_hook
= emacs_blocked_free
;
423 old_malloc_hook
= __malloc_hook
;
424 __malloc_hook
= emacs_blocked_malloc
;
426 old_realloc_hook
= __realloc_hook
;
427 __realloc_hook
= emacs_blocked_realloc
;
431 /* Interval allocation. */
433 #ifdef USE_TEXT_PROPERTIES
434 #define INTERVAL_BLOCK_SIZE \
435 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
437 struct interval_block
439 struct interval_block
*next
;
440 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
443 struct interval_block
*interval_block
;
444 static int interval_block_index
;
446 INTERVAL interval_free_list
;
451 allocating_for_lisp
= 1;
453 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
454 allocating_for_lisp
= 0;
455 interval_block
->next
= 0;
456 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
457 interval_block_index
= 0;
458 interval_free_list
= 0;
461 #define INIT_INTERVALS init_intervals ()
468 if (interval_free_list
)
470 val
= interval_free_list
;
471 interval_free_list
= interval_free_list
->parent
;
475 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
477 register struct interval_block
*newi
;
479 allocating_for_lisp
= 1;
480 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
482 allocating_for_lisp
= 0;
483 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
484 newi
->next
= interval_block
;
485 interval_block
= newi
;
486 interval_block_index
= 0;
488 val
= &interval_block
->intervals
[interval_block_index
++];
490 consing_since_gc
+= sizeof (struct interval
);
492 RESET_INTERVAL (val
);
496 static int total_free_intervals
, total_intervals
;
498 /* Mark the pointers of one interval. */
501 mark_interval (i
, dummy
)
505 if (XMARKBIT (i
->plist
))
507 mark_object (&i
->plist
);
512 mark_interval_tree (tree
)
513 register INTERVAL tree
;
515 /* No need to test if this tree has been marked already; this
516 function is always called through the MARK_INTERVAL_TREE macro,
517 which takes care of that. */
519 /* XMARK expands to an assignment; the LHS of an assignment can't be
521 XMARK (* (Lisp_Object
*) &tree
->parent
);
523 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
526 #define MARK_INTERVAL_TREE(i) \
528 if (!NULL_INTERVAL_P (i) \
529 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
530 mark_interval_tree (i); \
533 /* The oddity in the call to XUNMARK is necessary because XUNMARK
534 expands to an assignment to its argument, and most C compilers don't
535 support casts on the left operand of `='. */
536 #define UNMARK_BALANCE_INTERVALS(i) \
538 if (! NULL_INTERVAL_P (i)) \
540 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
541 (i) = balance_intervals (i); \
545 #else /* no interval use */
547 #define INIT_INTERVALS
549 #define UNMARK_BALANCE_INTERVALS(i)
550 #define MARK_INTERVAL_TREE(i)
552 #endif /* no interval use */
554 /* Floating point allocation. */
556 #ifdef LISP_FLOAT_TYPE
557 /* Allocation of float cells, just like conses */
558 /* We store float cells inside of float_blocks, allocating a new
559 float_block with malloc whenever necessary. Float cells reclaimed by
560 GC are put on a free list to be reallocated before allocating
561 any new float cells from the latest float_block.
563 Each float_block is just under 1020 bytes long,
564 since malloc really allocates in units of powers of two
565 and uses 4 bytes for its own overhead. */
567 #define FLOAT_BLOCK_SIZE \
568 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
572 struct float_block
*next
;
573 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
576 struct float_block
*float_block
;
577 int float_block_index
;
579 struct Lisp_Float
*float_free_list
;
584 allocating_for_lisp
= 1;
585 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
586 allocating_for_lisp
= 0;
587 float_block
->next
= 0;
588 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
589 float_block_index
= 0;
593 /* Explicitly free a float cell. */
595 struct Lisp_Float
*ptr
;
597 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
598 float_free_list
= ptr
;
602 make_float (float_value
)
605 register Lisp_Object val
;
609 /* We use the data field for chaining the free list
610 so that we won't use the same field that has the mark bit. */
611 XSETFLOAT (val
, float_free_list
);
612 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
616 if (float_block_index
== FLOAT_BLOCK_SIZE
)
618 register struct float_block
*new;
620 allocating_for_lisp
= 1;
621 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
622 allocating_for_lisp
= 0;
623 VALIDATE_LISP_STORAGE (new, sizeof *new);
624 new->next
= float_block
;
626 float_block_index
= 0;
628 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
630 XFLOAT (val
)->data
= float_value
;
631 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
632 consing_since_gc
+= sizeof (struct Lisp_Float
);
637 #endif /* LISP_FLOAT_TYPE */
639 /* Allocation of cons cells */
640 /* We store cons cells inside of cons_blocks, allocating a new
641 cons_block with malloc whenever necessary. Cons cells reclaimed by
642 GC are put on a free list to be reallocated before allocating
643 any new cons cells from the latest cons_block.
645 Each cons_block is just under 1020 bytes long,
646 since malloc really allocates in units of powers of two
647 and uses 4 bytes for its own overhead. */
649 #define CONS_BLOCK_SIZE \
650 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
654 struct cons_block
*next
;
655 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
658 struct cons_block
*cons_block
;
659 int cons_block_index
;
661 struct Lisp_Cons
*cons_free_list
;
666 allocating_for_lisp
= 1;
667 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
668 allocating_for_lisp
= 0;
669 cons_block
->next
= 0;
670 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
671 cons_block_index
= 0;
675 /* Explicitly free a cons cell. */
679 struct Lisp_Cons
*ptr
;
681 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
682 cons_free_list
= ptr
;
685 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
686 "Create a new cons, give it CAR and CDR as components, and return it.")
688 Lisp_Object car
, cdr
;
690 register Lisp_Object val
;
694 /* We use the cdr for chaining the free list
695 so that we won't use the same field that has the mark bit. */
696 XSETCONS (val
, cons_free_list
);
697 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
701 if (cons_block_index
== CONS_BLOCK_SIZE
)
703 register struct cons_block
*new;
704 allocating_for_lisp
= 1;
705 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
706 allocating_for_lisp
= 0;
707 VALIDATE_LISP_STORAGE (new, sizeof *new);
708 new->next
= cons_block
;
710 cons_block_index
= 0;
712 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
714 XCONS (val
)->car
= car
;
715 XCONS (val
)->cdr
= cdr
;
716 consing_since_gc
+= sizeof (struct Lisp_Cons
);
721 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
722 "Return a newly created list with specified arguments as elements.\n\
723 Any number of arguments, even zero arguments, are allowed.")
726 register Lisp_Object
*args
;
728 register Lisp_Object val
;
734 val
= Fcons (args
[nargs
], val
);
739 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
740 "Return a newly created list of length LENGTH, with each element being INIT.")
742 register Lisp_Object length
, init
;
744 register Lisp_Object val
;
747 CHECK_NATNUM (length
, 0);
748 size
= XFASTINT (length
);
752 val
= Fcons (init
, val
);
756 /* Allocation of vectors */
758 struct Lisp_Vector
*all_vectors
;
761 allocate_vectorlike (len
)
764 struct Lisp_Vector
*p
;
766 allocating_for_lisp
= 1;
767 #ifdef DOUG_LEA_MALLOC
768 /* Prevent mmap'ing the chunk (which is potentially very large). */
769 mallopt (M_MMAP_MAX
, 0);
771 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
772 + (len
- 1) * sizeof (Lisp_Object
));
773 #ifdef DOUG_LEA_MALLOC
774 /* Back to a reasonable maximum of mmap'ed areas. */
775 mallopt (M_MMAP_MAX
, 64);
777 allocating_for_lisp
= 0;
778 VALIDATE_LISP_STORAGE (p
, 0);
779 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
780 + (len
- 1) * sizeof (Lisp_Object
));
781 vector_cells_consed
+= len
;
783 p
->next
= all_vectors
;
788 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
789 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
790 See also the function `vector'.")
792 register Lisp_Object length
, init
;
795 register EMACS_INT sizei
;
797 register struct Lisp_Vector
*p
;
799 CHECK_NATNUM (length
, 0);
800 sizei
= XFASTINT (length
);
802 p
= allocate_vectorlike (sizei
);
804 for (index
= 0; index
< sizei
; index
++)
805 p
->contents
[index
] = init
;
807 XSETVECTOR (vector
, p
);
811 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
812 "Return a newly created char-table, with purpose PURPOSE.\n\
813 Each element is initialized to INIT, which defaults to nil.\n\
814 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
815 The property's value should be an integer between 0 and 10.")
817 register Lisp_Object purpose
, init
;
821 CHECK_SYMBOL (purpose
, 1);
822 n
= Fget (purpose
, Qchar_table_extra_slots
);
824 if (XINT (n
) < 0 || XINT (n
) > 10)
825 args_out_of_range (n
, Qnil
);
826 /* Add 2 to the size for the defalt and parent slots. */
827 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
829 XCHAR_TABLE (vector
)->top
= Qt
;
830 XCHAR_TABLE (vector
)->parent
= Qnil
;
831 XCHAR_TABLE (vector
)->purpose
= purpose
;
832 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
836 /* Return a newly created sub char table with default value DEFALT.
837 Since a sub char table does not appear as a top level Emacs Lisp
838 object, we don't need a Lisp interface to make it. */
841 make_sub_char_table (defalt
)
845 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
846 XCHAR_TABLE (vector
)->top
= Qnil
;
847 XCHAR_TABLE (vector
)->defalt
= defalt
;
848 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
852 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
853 "Return a newly created vector with specified arguments as elements.\n\
854 Any number of arguments, even zero arguments, are allowed.")
859 register Lisp_Object len
, val
;
861 register struct Lisp_Vector
*p
;
863 XSETFASTINT (len
, nargs
);
864 val
= Fmake_vector (len
, Qnil
);
866 for (index
= 0; index
< nargs
; index
++)
867 p
->contents
[index
] = args
[index
];
871 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
872 "Create a byte-code object with specified arguments as elements.\n\
873 The arguments should be the arglist, bytecode-string, constant vector,\n\
874 stack size, (optional) doc string, and (optional) interactive spec.\n\
875 The first four arguments are required; at most six have any\n\
881 register Lisp_Object len
, val
;
883 register struct Lisp_Vector
*p
;
885 XSETFASTINT (len
, nargs
);
886 if (!NILP (Vpurify_flag
))
887 val
= make_pure_vector ((EMACS_INT
) nargs
);
889 val
= Fmake_vector (len
, Qnil
);
891 for (index
= 0; index
< nargs
; index
++)
893 if (!NILP (Vpurify_flag
))
894 args
[index
] = Fpurecopy (args
[index
]);
895 p
->contents
[index
] = args
[index
];
897 XSETCOMPILED (val
, p
);
901 /* Allocation of symbols.
902 Just like allocation of conses!
904 Each symbol_block is just under 1020 bytes long,
905 since malloc really allocates in units of powers of two
906 and uses 4 bytes for its own overhead. */
908 #define SYMBOL_BLOCK_SIZE \
909 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
913 struct symbol_block
*next
;
914 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
917 struct symbol_block
*symbol_block
;
918 int symbol_block_index
;
920 struct Lisp_Symbol
*symbol_free_list
;
925 allocating_for_lisp
= 1;
926 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
927 allocating_for_lisp
= 0;
928 symbol_block
->next
= 0;
929 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
930 symbol_block_index
= 0;
931 symbol_free_list
= 0;
934 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
935 "Return a newly allocated uninterned symbol whose name is NAME.\n\
936 Its value and function definition are void, and its property list is nil.")
940 register Lisp_Object val
;
941 register struct Lisp_Symbol
*p
;
943 CHECK_STRING (name
, 0);
945 if (symbol_free_list
)
947 XSETSYMBOL (val
, symbol_free_list
);
948 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
952 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
954 struct symbol_block
*new;
955 allocating_for_lisp
= 1;
956 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
957 allocating_for_lisp
= 0;
958 VALIDATE_LISP_STORAGE (new, sizeof *new);
959 new->next
= symbol_block
;
961 symbol_block_index
= 0;
963 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
966 p
->name
= XSTRING (name
);
970 p
->function
= Qunbound
;
972 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
977 /* Allocation of markers and other objects that share that structure.
978 Works like allocation of conses. */
980 #define MARKER_BLOCK_SIZE \
981 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
985 struct marker_block
*next
;
986 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
989 struct marker_block
*marker_block
;
990 int marker_block_index
;
992 union Lisp_Misc
*marker_free_list
;
997 allocating_for_lisp
= 1;
998 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
999 allocating_for_lisp
= 0;
1000 marker_block
->next
= 0;
1001 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1002 marker_block_index
= 0;
1003 marker_free_list
= 0;
1006 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1012 if (marker_free_list
)
1014 XSETMISC (val
, marker_free_list
);
1015 marker_free_list
= marker_free_list
->u_free
.chain
;
1019 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1021 struct marker_block
*new;
1022 allocating_for_lisp
= 1;
1023 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
1024 allocating_for_lisp
= 0;
1025 VALIDATE_LISP_STORAGE (new, sizeof *new);
1026 new->next
= marker_block
;
1028 marker_block_index
= 0;
1030 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1032 consing_since_gc
+= sizeof (union Lisp_Misc
);
1033 misc_objects_consed
++;
1037 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1038 "Return a newly allocated marker which does not point at any place.")
1041 register Lisp_Object val
;
1042 register struct Lisp_Marker
*p
;
1044 val
= allocate_misc ();
1045 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1050 p
->insertion_type
= 0;
1054 /* Put MARKER back on the free list after using it temporarily. */
1057 free_marker (marker
)
1060 unchain_marker (marker
);
1062 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1063 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1064 marker_free_list
= XMISC (marker
);
1066 total_free_markers
++;
1069 /* Allocation of strings */
1071 /* Strings reside inside of string_blocks. The entire data of the string,
1072 both the size and the contents, live in part of the `chars' component of a string_block.
1073 The `pos' component is the index within `chars' of the first free byte.
1075 first_string_block points to the first string_block ever allocated.
1076 Each block points to the next one with its `next' field.
1077 The `prev' fields chain in reverse order.
1078 The last one allocated is the one currently being filled.
1079 current_string_block points to it.
1081 The string_blocks that hold individual large strings
1082 go in a separate chain, started by large_string_blocks. */
1085 /* String blocks contain this many useful bytes.
1086 8188 is power of 2, minus 4 for malloc overhead. */
1087 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1089 /* A string bigger than this gets its own specially-made string block
1090 if it doesn't fit in the current one. */
1091 #define STRING_BLOCK_OUTSIZE 1024
1093 struct string_block_head
1095 struct string_block
*next
, *prev
;
1101 struct string_block
*next
, *prev
;
1103 char chars
[STRING_BLOCK_SIZE
];
1106 /* This points to the string block we are now allocating strings. */
1108 struct string_block
*current_string_block
;
1110 /* This points to the oldest string block, the one that starts the chain. */
1112 struct string_block
*first_string_block
;
1114 /* Last string block in chain of those made for individual large strings. */
1116 struct string_block
*large_string_blocks
;
1118 /* If SIZE is the length of a string, this returns how many bytes
1119 the string occupies in a string_block (including padding). */
1121 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1123 #define PAD (sizeof (EMACS_INT))
1126 #define STRING_FULLSIZE(SIZE) \
1127 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1133 allocating_for_lisp
= 1;
1134 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1135 allocating_for_lisp
= 0;
1136 first_string_block
= current_string_block
;
1137 consing_since_gc
+= sizeof (struct string_block
);
1138 current_string_block
->next
= 0;
1139 current_string_block
->prev
= 0;
1140 current_string_block
->pos
= 0;
1141 large_string_blocks
= 0;
1144 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1145 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1146 Both LENGTH and INIT must be numbers.")
1148 Lisp_Object length
, init
;
1150 register Lisp_Object val
;
1151 register unsigned char *p
, *end
, c
;
1153 CHECK_NATNUM (length
, 0);
1154 CHECK_NUMBER (init
, 1);
1155 val
= make_uninit_string (XFASTINT (length
));
1157 p
= XSTRING (val
)->data
;
1158 end
= p
+ XSTRING (val
)->size
;
1165 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1166 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1167 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1169 Lisp_Object length
, init
;
1171 register Lisp_Object val
;
1172 struct Lisp_Bool_Vector
*p
;
1174 int length_in_chars
, length_in_elts
, bits_per_value
;
1176 CHECK_NATNUM (length
, 0);
1178 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1180 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1181 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1183 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1184 slot `size' of the struct Lisp_Bool_Vector. */
1185 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1186 p
= XBOOL_VECTOR (val
);
1187 /* Get rid of any bits that would cause confusion. */
1189 XSETBOOL_VECTOR (val
, p
);
1190 p
->size
= XFASTINT (length
);
1192 real_init
= (NILP (init
) ? 0 : -1);
1193 for (i
= 0; i
< length_in_chars
; i
++)
1194 p
->data
[i
] = real_init
;
1200 make_string (contents
, length
)
1204 register Lisp_Object val
;
1205 val
= make_uninit_string (length
);
1206 bcopy (contents
, XSTRING (val
)->data
, length
);
1214 return make_string (str
, strlen (str
));
1218 make_uninit_string (length
)
1221 register Lisp_Object val
;
1222 register int fullsize
= STRING_FULLSIZE (length
);
1224 if (length
< 0) abort ();
1226 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1227 /* This string can fit in the current string block */
1230 ((struct Lisp_String
*)
1231 (current_string_block
->chars
+ current_string_block
->pos
)));
1232 current_string_block
->pos
+= fullsize
;
1234 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1235 /* This string gets its own string block */
1237 register struct string_block
*new;
1238 allocating_for_lisp
= 1;
1239 #ifdef DOUG_LEA_MALLOC
1240 /* Prevent mmap'ing the chunk (which is potentially very large). */
1241 mallopt (M_MMAP_MAX
, 0);
1243 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1244 #ifdef DOUG_LEA_MALLOC
1245 /* Back to a reasonable maximum of mmap'ed areas. */
1246 mallopt (M_MMAP_MAX
, 64);
1248 allocating_for_lisp
= 0;
1249 VALIDATE_LISP_STORAGE (new, 0);
1250 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1251 new->pos
= fullsize
;
1252 new->next
= large_string_blocks
;
1253 large_string_blocks
= new;
1255 ((struct Lisp_String
*)
1256 ((struct string_block_head
*)new + 1)));
1259 /* Make a new current string block and start it off with this string */
1261 register struct string_block
*new;
1262 allocating_for_lisp
= 1;
1263 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1264 allocating_for_lisp
= 0;
1265 VALIDATE_LISP_STORAGE (new, sizeof *new);
1266 consing_since_gc
+= sizeof (struct string_block
);
1267 current_string_block
->next
= new;
1268 new->prev
= current_string_block
;
1270 current_string_block
= new;
1271 new->pos
= fullsize
;
1273 (struct Lisp_String
*) current_string_block
->chars
);
1276 string_chars_consed
+= fullsize
;
1277 XSTRING (val
)->size
= length
;
1278 XSTRING (val
)->data
[length
] = 0;
1279 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1284 /* Return a newly created vector or string with specified arguments as
1285 elements. If all the arguments are characters that can fit
1286 in a string of events, make a string; otherwise, make a vector.
1288 Any number of arguments, even zero arguments, are allowed. */
1291 make_event_array (nargs
, args
)
1297 for (i
= 0; i
< nargs
; i
++)
1298 /* The things that fit in a string
1299 are characters that are in 0...127,
1300 after discarding the meta bit and all the bits above it. */
1301 if (!INTEGERP (args
[i
])
1302 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1303 return Fvector (nargs
, args
);
1305 /* Since the loop exited, we know that all the things in it are
1306 characters, so we can make a string. */
1310 result
= Fmake_string (make_number (nargs
), make_number (0));
1311 for (i
= 0; i
< nargs
; i
++)
1313 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1314 /* Move the meta bit to the right place for a string char. */
1315 if (XINT (args
[i
]) & CHAR_META
)
1316 XSTRING (result
)->data
[i
] |= 0x80;
1323 /* Pure storage management. */
1325 /* Must get an error if pure storage is full,
1326 since if it cannot hold a large string
1327 it may be able to hold conses that point to that string;
1328 then the string is not protected from gc. */
1331 make_pure_string (data
, length
)
1335 register Lisp_Object
new;
1336 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1338 if (pureptr
+ size
> PURESIZE
)
1339 error ("Pure Lisp storage exhausted");
1340 XSETSTRING (new, PUREBEG
+ pureptr
);
1341 XSTRING (new)->size
= length
;
1342 bcopy (data
, XSTRING (new)->data
, length
);
1343 XSTRING (new)->data
[length
] = 0;
1345 /* We must give strings in pure storage some kind of interval. So we
1346 give them a null one. */
1347 #if defined (USE_TEXT_PROPERTIES)
1348 XSTRING (new)->intervals
= NULL_INTERVAL
;
1350 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1351 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1356 pure_cons (car
, cdr
)
1357 Lisp_Object car
, cdr
;
1359 register Lisp_Object
new;
1361 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1362 error ("Pure Lisp storage exhausted");
1363 XSETCONS (new, PUREBEG
+ pureptr
);
1364 pureptr
+= sizeof (struct Lisp_Cons
);
1365 XCONS (new)->car
= Fpurecopy (car
);
1366 XCONS (new)->cdr
= Fpurecopy (cdr
);
1370 #ifdef LISP_FLOAT_TYPE
1373 make_pure_float (num
)
1376 register Lisp_Object
new;
1378 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1379 (double) boundary. Some architectures (like the sparc) require
1380 this, and I suspect that floats are rare enough that it's no
1381 tragedy for those that do. */
1384 char *p
= PUREBEG
+ pureptr
;
1388 alignment
= __alignof (struct Lisp_Float
);
1390 alignment
= sizeof (struct Lisp_Float
);
1393 alignment
= sizeof (struct Lisp_Float
);
1395 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1396 pureptr
= p
- PUREBEG
;
1399 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1400 error ("Pure Lisp storage exhausted");
1401 XSETFLOAT (new, PUREBEG
+ pureptr
);
1402 pureptr
+= sizeof (struct Lisp_Float
);
1403 XFLOAT (new)->data
= num
;
1404 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1408 #endif /* LISP_FLOAT_TYPE */
1411 make_pure_vector (len
)
1414 register Lisp_Object
new;
1415 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1417 if (pureptr
+ size
> PURESIZE
)
1418 error ("Pure Lisp storage exhausted");
1420 XSETVECTOR (new, PUREBEG
+ pureptr
);
1422 XVECTOR (new)->size
= len
;
1426 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1427 "Make a copy of OBJECT in pure storage.\n\
1428 Recursively copies contents of vectors and cons cells.\n\
1429 Does not copy symbols.")
1431 register Lisp_Object obj
;
1433 if (NILP (Vpurify_flag
))
1436 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1437 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1441 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1442 #ifdef LISP_FLOAT_TYPE
1443 else if (FLOATP (obj
))
1444 return make_pure_float (XFLOAT (obj
)->data
);
1445 #endif /* LISP_FLOAT_TYPE */
1446 else if (STRINGP (obj
))
1447 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1448 else if (COMPILEDP (obj
) || VECTORP (obj
))
1450 register struct Lisp_Vector
*vec
;
1451 register int i
, size
;
1453 size
= XVECTOR (obj
)->size
;
1454 if (size
& PSEUDOVECTOR_FLAG
)
1455 size
&= PSEUDOVECTOR_SIZE_MASK
;
1456 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1457 for (i
= 0; i
< size
; i
++)
1458 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1459 if (COMPILEDP (obj
))
1460 XSETCOMPILED (obj
, vec
);
1462 XSETVECTOR (obj
, vec
);
1465 else if (MARKERP (obj
))
1466 error ("Attempt to copy a marker to pure storage");
1471 /* Recording what needs to be marked for gc. */
1473 struct gcpro
*gcprolist
;
1475 #define NSTATICS 768
1477 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1481 /* Put an entry in staticvec, pointing at the variable whose address is given */
1484 staticpro (varaddress
)
1485 Lisp_Object
*varaddress
;
1487 staticvec
[staticidx
++] = varaddress
;
1488 if (staticidx
>= NSTATICS
)
1496 struct catchtag
*next
;
1497 #if 0 /* We don't need this for GC purposes */
1504 struct backtrace
*next
;
1505 Lisp_Object
*function
;
1506 Lisp_Object
*args
; /* Points to vector of args. */
1507 int nargs
; /* length of vector */
1508 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1512 /* Garbage collection! */
1514 /* Temporarily prevent garbage collection. */
1517 inhibit_garbage_collection ()
1519 int count
= specpdl_ptr
- specpdl
;
1521 int nbits
= min (VALBITS
, BITS_PER_INT
);
1523 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1525 specbind (Qgc_cons_threshold
, number
);
1530 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1531 "Reclaim storage for Lisp objects no longer needed.\n\
1532 Returns info on amount of space in use:\n\
1533 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1534 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1535 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1536 Garbage collection happens automatically if you cons more than\n\
1537 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1540 register struct gcpro
*tail
;
1541 register struct specbinding
*bind
;
1542 struct catchtag
*catch;
1543 struct handler
*handler
;
1544 register struct backtrace
*backlist
;
1545 register Lisp_Object tem
;
1546 char *omessage
= echo_area_glyphs
;
1547 int omessage_length
= echo_area_glyphs_length
;
1548 int oldmultibyte
= message_enable_multibyte
;
1549 char stack_top_variable
;
1552 /* In case user calls debug_print during GC,
1553 don't let that cause a recursive GC. */
1554 consing_since_gc
= 0;
1556 /* Save a copy of the contents of the stack, for debugging. */
1557 #if MAX_SAVE_STACK > 0
1558 if (NILP (Vpurify_flag
))
1560 i
= &stack_top_variable
- stack_bottom
;
1562 if (i
< MAX_SAVE_STACK
)
1564 if (stack_copy
== 0)
1565 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1566 else if (stack_copy_size
< i
)
1567 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1570 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1571 bcopy (stack_bottom
, stack_copy
, i
);
1573 bcopy (&stack_top_variable
, stack_copy
, i
);
1577 #endif /* MAX_SAVE_STACK > 0 */
1579 if (garbage_collection_messages
)
1580 message1_nolog ("Garbage collecting...");
1582 /* Don't keep command history around forever. */
1583 if (NUMBERP (Vhistory_length
) && XINT (Vhistory_length
) > 0)
1585 tem
= Fnthcdr (Vhistory_length
, Vcommand_history
);
1587 XCONS (tem
)->cdr
= Qnil
;
1590 /* Likewise for undo information. */
1592 register struct buffer
*nextb
= all_buffers
;
1596 /* If a buffer's undo list is Qt, that means that undo is
1597 turned off in that buffer. Calling truncate_undo_list on
1598 Qt tends to return NULL, which effectively turns undo back on.
1599 So don't call truncate_undo_list if undo_list is Qt. */
1600 if (! EQ (nextb
->undo_list
, Qt
))
1602 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1604 nextb
= nextb
->next
;
1610 /* clear_marks (); */
1612 /* In each "large string", set the MARKBIT of the size field.
1613 That enables mark_object to recognize them. */
1615 register struct string_block
*b
;
1616 for (b
= large_string_blocks
; b
; b
= b
->next
)
1617 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1620 /* Mark all the special slots that serve as the roots of accessibility.
1622 Usually the special slots to mark are contained in particular structures.
1623 Then we know no slot is marked twice because the structures don't overlap.
1624 In some cases, the structures point to the slots to be marked.
1625 For these, we use MARKBIT to avoid double marking of the slot. */
1627 for (i
= 0; i
< staticidx
; i
++)
1628 mark_object (staticvec
[i
]);
1629 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1630 for (i
= 0; i
< tail
->nvars
; i
++)
1631 if (!XMARKBIT (tail
->var
[i
]))
1633 mark_object (&tail
->var
[i
]);
1634 XMARK (tail
->var
[i
]);
1636 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1638 mark_object (&bind
->symbol
);
1639 mark_object (&bind
->old_value
);
1641 for (catch = catchlist
; catch; catch = catch->next
)
1643 mark_object (&catch->tag
);
1644 mark_object (&catch->val
);
1646 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1648 mark_object (&handler
->handler
);
1649 mark_object (&handler
->var
);
1651 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1653 if (!XMARKBIT (*backlist
->function
))
1655 mark_object (backlist
->function
);
1656 XMARK (*backlist
->function
);
1658 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1661 i
= backlist
->nargs
- 1;
1663 if (!XMARKBIT (backlist
->args
[i
]))
1665 mark_object (&backlist
->args
[i
]);
1666 XMARK (backlist
->args
[i
]);
1673 /* Clear the mark bits that we set in certain root slots. */
1675 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1676 for (i
= 0; i
< tail
->nvars
; i
++)
1677 XUNMARK (tail
->var
[i
]);
1678 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1680 XUNMARK (*backlist
->function
);
1681 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1684 i
= backlist
->nargs
- 1;
1686 XUNMARK (backlist
->args
[i
]);
1688 XUNMARK (buffer_defaults
.name
);
1689 XUNMARK (buffer_local_symbols
.name
);
1691 /* clear_marks (); */
1694 consing_since_gc
= 0;
1695 if (gc_cons_threshold
< 10000)
1696 gc_cons_threshold
= 10000;
1698 if (garbage_collection_messages
)
1700 if (omessage
|| minibuf_level
> 0)
1701 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1703 message1_nolog ("Garbage collecting...done");
1706 return Fcons (Fcons (make_number (total_conses
),
1707 make_number (total_free_conses
)),
1708 Fcons (Fcons (make_number (total_symbols
),
1709 make_number (total_free_symbols
)),
1710 Fcons (Fcons (make_number (total_markers
),
1711 make_number (total_free_markers
)),
1712 Fcons (make_number (total_string_size
),
1713 Fcons (make_number (total_vector_size
),
1715 #ifdef LISP_FLOAT_TYPE
1716 (make_number (total_floats
),
1717 make_number (total_free_floats
)),
1718 #else /* not LISP_FLOAT_TYPE */
1719 (make_number (0), make_number (0)),
1720 #endif /* not LISP_FLOAT_TYPE */
1722 #ifdef USE_TEXT_PROPERTIES
1723 (make_number (total_intervals
),
1724 make_number (total_free_intervals
)),
1725 #else /* not USE_TEXT_PROPERTIES */
1726 (make_number (0), make_number (0)),
1727 #endif /* not USE_TEXT_PROPERTIES */
1735 /* Clear marks on all conses */
1737 register struct cons_block
*cblk
;
1738 register int lim
= cons_block_index
;
1740 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1743 for (i
= 0; i
< lim
; i
++)
1744 XUNMARK (cblk
->conses
[i
].car
);
1745 lim
= CONS_BLOCK_SIZE
;
1748 /* Clear marks on all symbols */
1750 register struct symbol_block
*sblk
;
1751 register int lim
= symbol_block_index
;
1753 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1756 for (i
= 0; i
< lim
; i
++)
1758 XUNMARK (sblk
->symbols
[i
].plist
);
1760 lim
= SYMBOL_BLOCK_SIZE
;
1763 /* Clear marks on all markers */
1765 register struct marker_block
*sblk
;
1766 register int lim
= marker_block_index
;
1768 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1771 for (i
= 0; i
< lim
; i
++)
1772 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1773 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1774 lim
= MARKER_BLOCK_SIZE
;
1777 /* Clear mark bits on all buffers */
1779 register struct buffer
*nextb
= all_buffers
;
1783 XUNMARK (nextb
->name
);
1784 nextb
= nextb
->next
;
1790 /* Mark reference to a Lisp_Object.
1791 If the object referred to has not been seen yet, recursively mark
1792 all the references contained in it.
1794 If the object referenced is a short string, the referencing slot
1795 is threaded into a chain of such slots, pointed to from
1796 the `size' field of the string. The actual string size
1797 lives in the last slot in the chain. We recognize the end
1798 because it is < (unsigned) STRING_BLOCK_SIZE. */
1800 #define LAST_MARKED_SIZE 500
1801 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1802 int last_marked_index
;
1805 mark_object (argptr
)
1806 Lisp_Object
*argptr
;
1808 Lisp_Object
*objptr
= argptr
;
1809 register Lisp_Object obj
;
1816 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1817 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1820 last_marked
[last_marked_index
++] = objptr
;
1821 if (last_marked_index
== LAST_MARKED_SIZE
)
1822 last_marked_index
= 0;
1824 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1828 register struct Lisp_String
*ptr
= XSTRING (obj
);
1830 MARK_INTERVAL_TREE (ptr
->intervals
);
1831 if (ptr
->size
& MARKBIT
)
1832 /* A large string. Just set ARRAY_MARK_FLAG. */
1833 ptr
->size
|= ARRAY_MARK_FLAG
;
1836 /* A small string. Put this reference
1837 into the chain of references to it.
1838 If the address includes MARKBIT, put that bit elsewhere
1839 when we store OBJPTR into the size field. */
1841 if (XMARKBIT (*objptr
))
1843 XSETFASTINT (*objptr
, ptr
->size
);
1847 XSETFASTINT (*objptr
, ptr
->size
);
1849 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1851 ptr
->size
= (EMACS_INT
) objptr
;
1852 if (ptr
->size
& MARKBIT
)
1853 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1858 case Lisp_Vectorlike
:
1859 if (GC_BUFFERP (obj
))
1861 if (!XMARKBIT (XBUFFER (obj
)->name
))
1864 else if (GC_SUBRP (obj
))
1866 else if (GC_COMPILEDP (obj
))
1867 /* We could treat this just like a vector, but it is better
1868 to save the COMPILED_CONSTANTS element for last and avoid recursion
1871 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1872 register EMACS_INT size
= ptr
->size
;
1873 /* See comment above under Lisp_Vector. */
1874 struct Lisp_Vector
*volatile ptr1
= ptr
;
1877 if (size
& ARRAY_MARK_FLAG
)
1878 break; /* Already marked */
1879 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1880 size
&= PSEUDOVECTOR_SIZE_MASK
;
1881 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1883 if (i
!= COMPILED_CONSTANTS
)
1884 mark_object (&ptr1
->contents
[i
]);
1886 /* This cast should be unnecessary, but some Mips compiler complains
1887 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1888 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1891 else if (GC_FRAMEP (obj
))
1893 /* See comment above under Lisp_Vector for why this is volatile. */
1894 register struct frame
*volatile ptr
= XFRAME (obj
);
1895 register EMACS_INT size
= ptr
->size
;
1897 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1898 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1900 mark_object (&ptr
->name
);
1901 mark_object (&ptr
->icon_name
);
1902 mark_object (&ptr
->title
);
1903 mark_object (&ptr
->focus_frame
);
1904 mark_object (&ptr
->selected_window
);
1905 mark_object (&ptr
->minibuffer_window
);
1906 mark_object (&ptr
->param_alist
);
1907 mark_object (&ptr
->scroll_bars
);
1908 mark_object (&ptr
->condemned_scroll_bars
);
1909 mark_object (&ptr
->menu_bar_items
);
1910 mark_object (&ptr
->face_alist
);
1911 mark_object (&ptr
->menu_bar_vector
);
1912 mark_object (&ptr
->buffer_predicate
);
1913 mark_object (&ptr
->buffer_list
);
1915 else if (GC_BOOL_VECTOR_P (obj
))
1917 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1919 if (ptr
->size
& ARRAY_MARK_FLAG
)
1920 break; /* Already marked */
1921 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1925 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1926 register EMACS_INT size
= ptr
->size
;
1927 /* The reason we use ptr1 is to avoid an apparent hardware bug
1928 that happens occasionally on the FSF's HP 300s.
1929 The bug is that a2 gets clobbered by recursive calls to mark_object.
1930 The clobberage seems to happen during function entry,
1931 perhaps in the moveml instruction.
1932 Yes, this is a crock, but we have to do it. */
1933 struct Lisp_Vector
*volatile ptr1
= ptr
;
1936 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1937 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1938 if (size
& PSEUDOVECTOR_FLAG
)
1939 size
&= PSEUDOVECTOR_SIZE_MASK
;
1940 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1941 mark_object (&ptr1
->contents
[i
]);
1947 /* See comment above under Lisp_Vector for why this is volatile. */
1948 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1949 struct Lisp_Symbol
*ptrx
;
1951 if (XMARKBIT (ptr
->plist
)) break;
1953 mark_object ((Lisp_Object
*) &ptr
->value
);
1954 mark_object (&ptr
->function
);
1955 mark_object (&ptr
->plist
);
1956 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1957 mark_object (&ptr
->name
);
1961 /* For the benefit of the last_marked log. */
1962 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1963 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1964 XSETSYMBOL (obj
, ptrx
);
1965 /* We can't goto loop here because *objptr doesn't contain an
1966 actual Lisp_Object with valid datatype field. */
1973 switch (XMISCTYPE (obj
))
1975 case Lisp_Misc_Marker
:
1976 XMARK (XMARKER (obj
)->chain
);
1977 /* DO NOT mark thru the marker's chain.
1978 The buffer's markers chain does not preserve markers from gc;
1979 instead, markers are removed from the chain when freed by gc. */
1982 case Lisp_Misc_Buffer_Local_Value
:
1983 case Lisp_Misc_Some_Buffer_Local_Value
:
1985 register struct Lisp_Buffer_Local_Value
*ptr
1986 = XBUFFER_LOCAL_VALUE (obj
);
1987 if (XMARKBIT (ptr
->car
)) break;
1989 /* If the cdr is nil, avoid recursion for the car. */
1990 if (EQ (ptr
->cdr
, Qnil
))
1995 mark_object (&ptr
->car
);
1996 /* See comment above under Lisp_Vector for why not use ptr here. */
1997 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2001 case Lisp_Misc_Intfwd
:
2002 case Lisp_Misc_Boolfwd
:
2003 case Lisp_Misc_Objfwd
:
2004 case Lisp_Misc_Buffer_Objfwd
:
2005 case Lisp_Misc_Kboard_Objfwd
:
2006 /* Don't bother with Lisp_Buffer_Objfwd,
2007 since all markable slots in current buffer marked anyway. */
2008 /* Don't need to do Lisp_Objfwd, since the places they point
2009 are protected with staticpro. */
2012 case Lisp_Misc_Overlay
:
2014 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2015 if (!XMARKBIT (ptr
->plist
))
2018 mark_object (&ptr
->start
);
2019 mark_object (&ptr
->end
);
2020 objptr
= &ptr
->plist
;
2033 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2034 if (XMARKBIT (ptr
->car
)) break;
2036 /* If the cdr is nil, avoid recursion for the car. */
2037 if (EQ (ptr
->cdr
, Qnil
))
2042 mark_object (&ptr
->car
);
2043 /* See comment above under Lisp_Vector for why not use ptr here. */
2044 objptr
= &XCONS (obj
)->cdr
;
2048 #ifdef LISP_FLOAT_TYPE
2050 XMARK (XFLOAT (obj
)->type
);
2052 #endif /* LISP_FLOAT_TYPE */
2062 /* Mark the pointers in a buffer structure. */
2068 register struct buffer
*buffer
= XBUFFER (buf
);
2069 register Lisp_Object
*ptr
;
2070 Lisp_Object base_buffer
;
2072 /* This is the buffer's markbit */
2073 mark_object (&buffer
->name
);
2074 XMARK (buffer
->name
);
2076 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2079 mark_object (buffer
->syntax_table
);
2081 /* Mark the various string-pointers in the buffer object.
2082 Since the strings may be relocated, we must mark them
2083 in their actual slots. So gc_sweep must convert each slot
2084 back to an ordinary C pointer. */
2085 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2086 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2087 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2088 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2090 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2091 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2092 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2093 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2096 for (ptr
= &buffer
->name
+ 1;
2097 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2101 /* If this is an indirect buffer, mark its base buffer. */
2102 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2104 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2105 mark_buffer (base_buffer
);
2110 /* Mark the pointers in the kboard objects. */
2117 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2119 if (kb
->kbd_macro_buffer
)
2120 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2122 mark_object (&kb
->Vprefix_arg
);
2123 mark_object (&kb
->kbd_queue
);
2124 mark_object (&kb
->Vlast_kbd_macro
);
2125 mark_object (&kb
->Vsystem_key_alist
);
2126 mark_object (&kb
->system_key_syms
);
2130 /* Sweep: find all structures not marked, and free them. */
2135 total_string_size
= 0;
2138 /* Put all unmarked conses on free list */
2140 register struct cons_block
*cblk
;
2141 struct cons_block
**cprev
= &cons_block
;
2142 register int lim
= cons_block_index
;
2143 register int num_free
= 0, num_used
= 0;
2147 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2151 for (i
= 0; i
< lim
; i
++)
2152 if (!XMARKBIT (cblk
->conses
[i
].car
))
2156 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2157 cons_free_list
= &cblk
->conses
[i
];
2162 XUNMARK (cblk
->conses
[i
].car
);
2164 lim
= CONS_BLOCK_SIZE
;
2165 /* If this block contains only free conses and we have already
2166 seen more than two blocks worth of free conses then deallocate
2168 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> 2*CONS_BLOCK_SIZE
)
2170 num_free
-= CONS_BLOCK_SIZE
;
2171 *cprev
= cblk
->next
;
2172 /* Unhook from the free list. */
2173 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2177 cprev
= &cblk
->next
;
2179 total_conses
= num_used
;
2180 total_free_conses
= num_free
;
2183 #ifdef LISP_FLOAT_TYPE
2184 /* Put all unmarked floats on free list */
2186 register struct float_block
*fblk
;
2187 struct float_block
**fprev
= &float_block
;
2188 register int lim
= float_block_index
;
2189 register int num_free
= 0, num_used
= 0;
2191 float_free_list
= 0;
2193 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2197 for (i
= 0; i
< lim
; i
++)
2198 if (!XMARKBIT (fblk
->floats
[i
].type
))
2202 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2203 float_free_list
= &fblk
->floats
[i
];
2208 XUNMARK (fblk
->floats
[i
].type
);
2210 lim
= FLOAT_BLOCK_SIZE
;
2211 /* If this block contains only free floats and we have already
2212 seen more than two blocks worth of free floats then deallocate
2214 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> 2*FLOAT_BLOCK_SIZE
)
2216 num_free
-= FLOAT_BLOCK_SIZE
;
2217 *fprev
= fblk
->next
;
2218 /* Unhook from the free list. */
2219 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2223 fprev
= &fblk
->next
;
2225 total_floats
= num_used
;
2226 total_free_floats
= num_free
;
2228 #endif /* LISP_FLOAT_TYPE */
2230 #ifdef USE_TEXT_PROPERTIES
2231 /* Put all unmarked intervals on free list */
2233 register struct interval_block
*iblk
;
2234 struct interval_block
**iprev
= &interval_block
;
2235 register int lim
= interval_block_index
;
2236 register int num_free
= 0, num_used
= 0;
2238 interval_free_list
= 0;
2240 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2245 for (i
= 0; i
< lim
; i
++)
2247 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2249 iblk
->intervals
[i
].parent
= interval_free_list
;
2250 interval_free_list
= &iblk
->intervals
[i
];
2257 XUNMARK (iblk
->intervals
[i
].plist
);
2260 lim
= INTERVAL_BLOCK_SIZE
;
2261 /* If this block contains only free intervals and we have already
2262 seen more than two blocks worth of free intervals then
2263 deallocate this block. */
2264 if (this_free
== INTERVAL_BLOCK_SIZE
2265 && num_free
> 2*INTERVAL_BLOCK_SIZE
)
2267 num_free
-= INTERVAL_BLOCK_SIZE
;
2268 *iprev
= iblk
->next
;
2269 /* Unhook from the free list. */
2270 interval_free_list
= iblk
->intervals
[0].parent
;
2274 iprev
= &iblk
->next
;
2276 total_intervals
= num_used
;
2277 total_free_intervals
= num_free
;
2279 #endif /* USE_TEXT_PROPERTIES */
2281 /* Put all unmarked symbols on free list */
2283 register struct symbol_block
*sblk
;
2284 struct symbol_block
**sprev
= &symbol_block
;
2285 register int lim
= symbol_block_index
;
2286 register int num_free
= 0, num_used
= 0;
2288 symbol_free_list
= 0;
2290 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2294 for (i
= 0; i
< lim
; i
++)
2295 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2297 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2298 symbol_free_list
= &sblk
->symbols
[i
];
2305 sblk
->symbols
[i
].name
2306 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2307 XUNMARK (sblk
->symbols
[i
].plist
);
2309 lim
= SYMBOL_BLOCK_SIZE
;
2310 /* If this block contains only free symbols and we have already
2311 seen more than two blocks worth of free symbols then deallocate
2313 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> 2*SYMBOL_BLOCK_SIZE
)
2315 num_free
-= SYMBOL_BLOCK_SIZE
;
2316 *sprev
= sblk
->next
;
2317 /* Unhook from the free list. */
2318 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2322 sprev
= &sblk
->next
;
2324 total_symbols
= num_used
;
2325 total_free_symbols
= num_free
;
2329 /* Put all unmarked markers on free list.
2330 Unchain each one first from the buffer it points into,
2331 but only if it's a real marker. */
2333 register struct marker_block
*mblk
;
2334 struct marker_block
**mprev
= &marker_block
;
2335 register int lim
= marker_block_index
;
2336 register int num_free
= 0, num_used
= 0;
2338 marker_free_list
= 0;
2340 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2344 EMACS_INT already_free
= -1;
2346 for (i
= 0; i
< lim
; i
++)
2348 Lisp_Object
*markword
;
2349 switch (mblk
->markers
[i
].u_marker
.type
)
2351 case Lisp_Misc_Marker
:
2352 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2354 case Lisp_Misc_Buffer_Local_Value
:
2355 case Lisp_Misc_Some_Buffer_Local_Value
:
2356 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2358 case Lisp_Misc_Overlay
:
2359 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2361 case Lisp_Misc_Free
:
2362 /* If the object was already free, keep it
2363 on the free list. */
2364 markword
= (Lisp_Object
*) &already_free
;
2370 if (markword
&& !XMARKBIT (*markword
))
2373 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2375 /* tem1 avoids Sun compiler bug */
2376 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2377 XSETMARKER (tem
, tem1
);
2378 unchain_marker (tem
);
2380 /* Set the type of the freed object to Lisp_Misc_Free.
2381 We could leave the type alone, since nobody checks it,
2382 but this might catch bugs faster. */
2383 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2384 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2385 marker_free_list
= &mblk
->markers
[i
];
2393 XUNMARK (*markword
);
2396 lim
= MARKER_BLOCK_SIZE
;
2397 /* If this block contains only free markers and we have already
2398 seen more than two blocks worth of free markers then deallocate
2400 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> 2*MARKER_BLOCK_SIZE
)
2402 num_free
-= MARKER_BLOCK_SIZE
;
2403 *mprev
= mblk
->next
;
2404 /* Unhook from the free list. */
2405 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2409 mprev
= &mblk
->next
;
2412 total_markers
= num_used
;
2413 total_free_markers
= num_free
;
2416 /* Free all unmarked buffers */
2418 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2421 if (!XMARKBIT (buffer
->name
))
2424 prev
->next
= buffer
->next
;
2426 all_buffers
= buffer
->next
;
2427 next
= buffer
->next
;
2433 XUNMARK (buffer
->name
);
2434 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2437 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2438 for purposes of marking and relocation.
2439 Turn them back into C pointers now. */
2440 buffer
->upcase_table
2441 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2442 buffer
->downcase_table
2443 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2445 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2446 buffer
->folding_sort_table
2447 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2450 prev
= buffer
, buffer
= buffer
->next
;
2454 #endif /* standalone */
2456 /* Free all unmarked vectors */
2458 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2459 total_vector_size
= 0;
2462 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2465 prev
->next
= vector
->next
;
2467 all_vectors
= vector
->next
;
2468 next
= vector
->next
;
2474 vector
->size
&= ~ARRAY_MARK_FLAG
;
2475 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2476 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2478 total_vector_size
+= vector
->size
;
2479 prev
= vector
, vector
= vector
->next
;
2483 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2485 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2486 struct Lisp_String
*s
;
2490 s
= (struct Lisp_String
*) &sb
->chars
[0];
2491 if (s
->size
& ARRAY_MARK_FLAG
)
2493 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2494 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2495 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2496 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2497 prev
= sb
, sb
= sb
->next
;
2502 prev
->next
= sb
->next
;
2504 large_string_blocks
= sb
->next
;
2513 /* Compactify strings, relocate references, and free empty string blocks. */
2518 /* String block of old strings we are scanning. */
2519 register struct string_block
*from_sb
;
2520 /* A preceding string block (or maybe the same one)
2521 where we are copying the still-live strings to. */
2522 register struct string_block
*to_sb
;
2526 to_sb
= first_string_block
;
2529 /* Scan each existing string block sequentially, string by string. */
2530 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2533 /* POS is the index of the next string in the block. */
2534 while (pos
< from_sb
->pos
)
2536 register struct Lisp_String
*nextstr
2537 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2539 register struct Lisp_String
*newaddr
;
2540 register EMACS_INT size
= nextstr
->size
;
2542 /* NEXTSTR is the old address of the next string.
2543 Just skip it if it isn't marked. */
2544 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2546 /* It is marked, so its size field is really a chain of refs.
2547 Find the end of the chain, where the actual size lives. */
2548 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2550 if (size
& DONT_COPY_FLAG
)
2551 size
^= MARKBIT
| DONT_COPY_FLAG
;
2552 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2555 total_string_size
+= size
;
2557 /* If it won't fit in TO_SB, close it out,
2558 and move to the next sb. Keep doing so until
2559 TO_SB reaches a large enough, empty enough string block.
2560 We know that TO_SB cannot advance past FROM_SB here
2561 since FROM_SB is large enough to contain this string.
2562 Any string blocks skipped here
2563 will be patched out and freed later. */
2564 while (to_pos
+ STRING_FULLSIZE (size
)
2565 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2567 to_sb
->pos
= to_pos
;
2568 to_sb
= to_sb
->next
;
2571 /* Compute new address of this string
2572 and update TO_POS for the space being used. */
2573 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2574 to_pos
+= STRING_FULLSIZE (size
);
2576 /* Copy the string itself to the new place. */
2577 if (nextstr
!= newaddr
)
2578 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2579 + INTERVAL_PTR_SIZE
);
2581 /* Go through NEXTSTR's chain of references
2582 and make each slot in the chain point to
2583 the new address of this string. */
2584 size
= newaddr
->size
;
2585 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2587 register Lisp_Object
*objptr
;
2588 if (size
& DONT_COPY_FLAG
)
2589 size
^= MARKBIT
| DONT_COPY_FLAG
;
2590 objptr
= (Lisp_Object
*)size
;
2592 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2593 if (XMARKBIT (*objptr
))
2595 XSETSTRING (*objptr
, newaddr
);
2599 XSETSTRING (*objptr
, newaddr
);
2601 /* Store the actual size in the size field. */
2602 newaddr
->size
= size
;
2604 #ifdef USE_TEXT_PROPERTIES
2605 /* Now that the string has been relocated, rebalance its
2606 interval tree, and update the tree's parent pointer. */
2607 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2609 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2610 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2613 #endif /* USE_TEXT_PROPERTIES */
2615 pos
+= STRING_FULLSIZE (size
);
2619 /* Close out the last string block still used and free any that follow. */
2620 to_sb
->pos
= to_pos
;
2621 current_string_block
= to_sb
;
2623 from_sb
= to_sb
->next
;
2627 to_sb
= from_sb
->next
;
2632 /* Free any empty string blocks further back in the chain.
2633 This loop will never free first_string_block, but it is very
2634 unlikely that that one will become empty, so why bother checking? */
2636 from_sb
= first_string_block
;
2637 while (to_sb
= from_sb
->next
)
2639 if (to_sb
->pos
== 0)
2641 if (from_sb
->next
= to_sb
->next
)
2642 from_sb
->next
->prev
= from_sb
;
2650 /* Debugging aids. */
2652 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2653 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2654 This may be helpful in debugging Emacs's memory usage.\n\
2655 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2660 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2665 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2666 "Return a list of counters that measure how much consing there has been.\n\
2667 Each of these counters increments for a certain kind of object.\n\
2668 The counters wrap around from the largest positive integer to zero.\n\
2669 Garbage collection does not decrease them.\n\
2670 The elements of the value are as follows:\n\
2671 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2672 All are in units of 1 = one object consed\n\
2673 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2675 MISCS include overlays, markers, and some internal types.\n\
2676 Frames, windows, buffers, and subprocesses count as vectors\n\
2677 (but the contents of a buffer's text do not count here).")
2680 Lisp_Object lisp_cons_cells_consed
;
2681 Lisp_Object lisp_floats_consed
;
2682 Lisp_Object lisp_vector_cells_consed
;
2683 Lisp_Object lisp_symbols_consed
;
2684 Lisp_Object lisp_string_chars_consed
;
2685 Lisp_Object lisp_misc_objects_consed
;
2686 Lisp_Object lisp_intervals_consed
;
2688 XSETINT (lisp_cons_cells_consed
,
2689 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2690 XSETINT (lisp_floats_consed
,
2691 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2692 XSETINT (lisp_vector_cells_consed
,
2693 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2694 XSETINT (lisp_symbols_consed
,
2695 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2696 XSETINT (lisp_string_chars_consed
,
2697 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2698 XSETINT (lisp_misc_objects_consed
,
2699 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2700 XSETINT (lisp_intervals_consed
,
2701 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2703 return Fcons (lisp_cons_cells_consed
,
2704 Fcons (lisp_floats_consed
,
2705 Fcons (lisp_vector_cells_consed
,
2706 Fcons (lisp_symbols_consed
,
2707 Fcons (lisp_string_chars_consed
,
2708 Fcons (lisp_misc_objects_consed
,
2709 Fcons (lisp_intervals_consed
,
2713 /* Initialization */
2717 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2720 pure_size
= PURESIZE
;
2723 ignore_warnings
= 1;
2724 #ifdef DOUG_LEA_MALLOC
2725 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2726 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2727 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2733 #ifdef LISP_FLOAT_TYPE
2735 #endif /* LISP_FLOAT_TYPE */
2739 malloc_hysteresis
= 32;
2741 malloc_hysteresis
= 0;
2744 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2746 ignore_warnings
= 0;
2749 consing_since_gc
= 0;
2750 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2751 #ifdef VIRT_ADDR_VARIES
2752 malloc_sbrk_unused
= 1<<22; /* A large number */
2753 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2754 #endif /* VIRT_ADDR_VARIES */
2765 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2766 "*Number of bytes of consing between garbage collections.\n\
2767 Garbage collection can happen automatically once this many bytes have been\n\
2768 allocated since the last garbage collection. All data types count.\n\n\
2769 Garbage collection happens automatically only when `eval' is called.\n\n\
2770 By binding this temporarily to a large number, you can effectively\n\
2771 prevent garbage collection during a part of the program.");
2773 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2774 "Number of bytes of sharable Lisp data allocated so far.");
2776 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2777 "Number of cons cells that have been consed so far.");
2779 DEFVAR_INT ("floats-consed", &floats_consed
,
2780 "Number of floats that have been consed so far.");
2782 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2783 "Number of vector cells that have been consed so far.");
2785 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2786 "Number of symbols that have been consed so far.");
2788 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2789 "Number of string characters that have been consed so far.");
2791 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2792 "Number of miscellaneous objects that have been consed so far.");
2794 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2795 "Number of intervals that have been consed so far.");
2798 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2799 "Number of bytes of unshared memory allocated in this session.");
2801 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2802 "Number of bytes of unshared memory remaining available in this session.");
2805 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2806 "Non-nil means loading Lisp code in order to dump an executable.\n\
2807 This means that certain objects should be allocated in shared (pure) space.");
2809 DEFVAR_INT ("undo-limit", &undo_limit
,
2810 "Keep no more undo information once it exceeds this size.\n\
2811 This limit is applied when garbage collection happens.\n\
2812 The size is counted as the number of bytes occupied,\n\
2813 which includes both saved text and other data.");
2816 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2817 "Don't keep more than this much size of undo information.\n\
2818 A command which pushes past this size is itself forgotten.\n\
2819 This limit is applied when garbage collection happens.\n\
2820 The size is counted as the number of bytes occupied,\n\
2821 which includes both saved text and other data.");
2822 undo_strong_limit
= 30000;
2824 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2825 "Non-nil means display messages at start and end of garbage collection.");
2826 garbage_collection_messages
= 0;
2828 /* We build this in advance because if we wait until we need it, we might
2829 not be able to allocate the memory to hold it. */
2831 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2832 staticpro (&memory_signal_data
);
2834 staticpro (&Qgc_cons_threshold
);
2835 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2837 staticpro (&Qchar_table_extra_slots
);
2838 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2843 defsubr (&Smake_byte_code
);
2844 defsubr (&Smake_list
);
2845 defsubr (&Smake_vector
);
2846 defsubr (&Smake_char_table
);
2847 defsubr (&Smake_string
);
2848 defsubr (&Smake_bool_vector
);
2849 defsubr (&Smake_symbol
);
2850 defsubr (&Smake_marker
);
2851 defsubr (&Spurecopy
);
2852 defsubr (&Sgarbage_collect
);
2853 defsubr (&Smemory_limit
);
2854 defsubr (&Smemory_use_counts
);