1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 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 /* The following come from gmalloc.c. */
42 #if defined (__STDC__) && __STDC__
44 #define __malloc_size_t size_t
46 #define __malloc_size_t unsigned int
48 extern __malloc_size_t _bytes_used
;
49 extern int __malloc_extra_blocks
;
51 extern Lisp_Object Vhistory_length
;
53 #define max(A,B) ((A) > (B) ? (A) : (B))
54 #define min(A,B) ((A) < (B) ? (A) : (B))
56 /* Macro to verify that storage intended for Lisp objects is not
57 out of range to fit in the space for a pointer.
58 ADDRESS is the start of the block, and SIZE
59 is the amount of space within which objects can start. */
60 #define VALIDATE_LISP_STORAGE(address, size) \
64 XSETCONS (val, (char *) address + size); \
65 if ((char *) XCONS (val) != (char *) address + size) \
72 /* Value of _bytes_used, when spare_memory was freed. */
73 static __malloc_size_t bytes_used_when_full
;
75 /* Number of bytes of consing done since the last gc */
78 /* Count the amount of consing of various sorts of space. */
79 int cons_cells_consed
;
81 int vector_cells_consed
;
83 int string_chars_consed
;
84 int misc_objects_consed
;
87 /* Number of bytes of consing since gc before another gc should be done. */
88 int gc_cons_threshold
;
90 /* Nonzero during gc */
93 /* Nonzero means display messages at beginning and end of GC. */
94 int garbage_collection_messages
;
96 #ifndef VIRT_ADDR_VARIES
98 #endif /* VIRT_ADDR_VARIES */
101 #ifndef VIRT_ADDR_VARIES
103 #endif /* VIRT_ADDR_VARIES */
104 int malloc_sbrk_unused
;
106 /* Two limits controlling how much undo information to keep. */
108 int undo_strong_limit
;
110 /* Points to memory space allocated as "spare",
111 to be freed if we run out of memory. */
112 static char *spare_memory
;
114 /* Amount of spare memory to keep in reserve. */
115 #define SPARE_MEMORY (1 << 14)
117 /* Number of extra blocks malloc should get when it needs more core. */
118 static int malloc_hysteresis
;
120 /* Nonzero when malloc is called for allocating Lisp object space. */
121 int allocating_for_lisp
;
123 /* Non-nil means defun should do purecopy on the function definition */
124 Lisp_Object Vpurify_flag
;
127 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
128 #define PUREBEG (char *) pure
130 #define pure PURE_SEG_BITS /* Use shared memory segment */
131 #define PUREBEG (char *)PURE_SEG_BITS
133 /* This variable is used only by the XPNTR macro when HAVE_SHM is
134 defined. If we used the PURESIZE macro directly there, that would
135 make most of emacs dependent on puresize.h, which we don't want -
136 you should be able to change that without too much recompilation.
137 So map_in_data initializes pure_size, and the dependencies work
140 #endif /* not HAVE_SHM */
142 /* Index in pure at which next pure object will be allocated. */
145 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
146 char *pending_malloc_warning
;
148 /* Pre-computed signal argument for use when memory is exhausted. */
149 Lisp_Object memory_signal_data
;
151 /* Maximum amount of C stack to save when a GC happens. */
153 #ifndef MAX_SAVE_STACK
154 #define MAX_SAVE_STACK 16000
157 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
158 pointer to a Lisp_Object, when that pointer is viewed as an integer.
159 (On most machines, pointers are even, so we can use the low bit.
160 Word-addressable architectures may need to override this in the m-file.)
161 When linking references to small strings through the size field, we
162 use this slot to hold the bit that would otherwise be interpreted as
164 #ifndef DONT_COPY_FLAG
165 #define DONT_COPY_FLAG 1
166 #endif /* no DONT_COPY_FLAG */
168 /* Buffer in which we save a copy of the C stack at each GC. */
173 /* Non-zero means ignore malloc warnings. Set during initialization. */
176 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
178 static void mark_object (), mark_buffer (), mark_kboards ();
179 static void clear_marks (), gc_sweep ();
180 static void compact_strings ();
182 /* Versions of malloc and realloc that print warnings as memory gets full. */
185 malloc_warning_1 (str
)
188 Fprinc (str
, Vstandard_output
);
189 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
190 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
191 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
195 /* malloc calls this if it finds we are near exhausting storage */
199 pending_malloc_warning
= str
;
202 display_malloc_warning ()
204 register Lisp_Object val
;
206 val
= build_string (pending_malloc_warning
);
207 pending_malloc_warning
= 0;
208 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
211 /* Called if malloc returns zero */
215 #ifndef SYSTEM_MALLOC
216 bytes_used_when_full
= _bytes_used
;
219 /* The first time we get here, free the spare memory. */
226 /* This used to call error, but if we've run out of memory, we could get
227 infinite recursion trying to build the string. */
229 Fsignal (Qerror
, memory_signal_data
);
232 /* Called if we can't allocate relocatable space for a buffer. */
235 buffer_memory_full ()
237 /* If buffers use the relocating allocator,
238 no need to free spare_memory, because we may have plenty of malloc
239 space left that we could get, and if we don't, the malloc that fails
240 will itself cause spare_memory to be freed.
241 If buffers don't use the relocating allocator,
242 treat this like any other failing malloc. */
248 /* This used to call error, but if we've run out of memory, we could get
249 infinite recursion trying to build the string. */
251 Fsignal (Qerror
, memory_signal_data
);
254 /* like malloc routines but check for no memory and block interrupt input. */
263 val
= (long *) malloc (size
);
266 if (!val
&& size
) memory_full ();
271 xrealloc (block
, size
)
278 /* We must call malloc explicitly when BLOCK is 0, since some
279 reallocs don't do this. */
281 val
= (long *) malloc (size
);
283 val
= (long *) realloc (block
, size
);
286 if (!val
&& size
) memory_full ();
300 /* Arranging to disable input signals while we're in malloc.
302 This only works with GNU malloc. To help out systems which can't
303 use GNU malloc, all the calls to malloc, realloc, and free
304 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
305 pairs; unfortunately, we have no idea what C library functions
306 might call malloc, so we can't really protect them unless you're
307 using GNU malloc. Fortunately, most of the major operating can use
310 #ifndef SYSTEM_MALLOC
311 extern void * (*__malloc_hook
) ();
312 static void * (*old_malloc_hook
) ();
313 extern void * (*__realloc_hook
) ();
314 static void * (*old_realloc_hook
) ();
315 extern void (*__free_hook
) ();
316 static void (*old_free_hook
) ();
318 /* This function is used as the hook for free to call. */
321 emacs_blocked_free (ptr
)
325 __free_hook
= old_free_hook
;
327 /* If we released our reserve (due to running out of memory),
328 and we have a fair amount free once again,
329 try to set aside another reserve in case we run out once more. */
330 if (spare_memory
== 0
331 /* Verify there is enough space that even with the malloc
332 hysteresis this call won't run out again.
333 The code here is correct as long as SPARE_MEMORY
334 is substantially larger than the block size malloc uses. */
335 && (bytes_used_when_full
336 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
337 spare_memory
= (char *) malloc (SPARE_MEMORY
);
339 __free_hook
= emacs_blocked_free
;
343 /* If we released our reserve (due to running out of memory),
344 and we have a fair amount free once again,
345 try to set aside another reserve in case we run out once more.
347 This is called when a relocatable block is freed in ralloc.c. */
350 refill_memory_reserve ()
352 if (spare_memory
== 0)
353 spare_memory
= (char *) malloc (SPARE_MEMORY
);
356 /* This function is the malloc hook that Emacs uses. */
359 emacs_blocked_malloc (size
)
365 __malloc_hook
= old_malloc_hook
;
366 __malloc_extra_blocks
= malloc_hysteresis
;
367 value
= (void *) malloc (size
);
368 __malloc_hook
= emacs_blocked_malloc
;
375 emacs_blocked_realloc (ptr
, size
)
382 __realloc_hook
= old_realloc_hook
;
383 value
= (void *) realloc (ptr
, size
);
384 __realloc_hook
= emacs_blocked_realloc
;
391 uninterrupt_malloc ()
393 old_free_hook
= __free_hook
;
394 __free_hook
= emacs_blocked_free
;
396 old_malloc_hook
= __malloc_hook
;
397 __malloc_hook
= emacs_blocked_malloc
;
399 old_realloc_hook
= __realloc_hook
;
400 __realloc_hook
= emacs_blocked_realloc
;
404 /* Interval allocation. */
406 #ifdef USE_TEXT_PROPERTIES
407 #define INTERVAL_BLOCK_SIZE \
408 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
410 struct interval_block
412 struct interval_block
*next
;
413 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
416 struct interval_block
*interval_block
;
417 static int interval_block_index
;
419 INTERVAL interval_free_list
;
424 allocating_for_lisp
= 1;
426 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
427 allocating_for_lisp
= 0;
428 interval_block
->next
= 0;
429 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
430 interval_block_index
= 0;
431 interval_free_list
= 0;
434 #define INIT_INTERVALS init_intervals ()
441 if (interval_free_list
)
443 val
= interval_free_list
;
444 interval_free_list
= interval_free_list
->parent
;
448 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
450 register struct interval_block
*newi
;
452 allocating_for_lisp
= 1;
453 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
455 allocating_for_lisp
= 0;
456 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
457 newi
->next
= interval_block
;
458 interval_block
= newi
;
459 interval_block_index
= 0;
461 val
= &interval_block
->intervals
[interval_block_index
++];
463 consing_since_gc
+= sizeof (struct interval
);
465 RESET_INTERVAL (val
);
469 static int total_free_intervals
, total_intervals
;
471 /* Mark the pointers of one interval. */
474 mark_interval (i
, dummy
)
478 if (XMARKBIT (i
->plist
))
480 mark_object (&i
->plist
);
485 mark_interval_tree (tree
)
486 register INTERVAL tree
;
488 /* No need to test if this tree has been marked already; this
489 function is always called through the MARK_INTERVAL_TREE macro,
490 which takes care of that. */
492 /* XMARK expands to an assignment; the LHS of an assignment can't be
494 XMARK (* (Lisp_Object
*) &tree
->parent
);
496 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
499 #define MARK_INTERVAL_TREE(i) \
501 if (!NULL_INTERVAL_P (i) \
502 && ! XMARKBIT ((Lisp_Object) i->parent)) \
503 mark_interval_tree (i); \
506 /* The oddity in the call to XUNMARK is necessary because XUNMARK
507 expands to an assignment to its argument, and most C compilers don't
508 support casts on the left operand of `='. */
509 #define UNMARK_BALANCE_INTERVALS(i) \
511 if (! NULL_INTERVAL_P (i)) \
513 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
514 (i) = balance_intervals (i); \
518 #else /* no interval use */
520 #define INIT_INTERVALS
522 #define UNMARK_BALANCE_INTERVALS(i)
523 #define MARK_INTERVAL_TREE(i)
525 #endif /* no interval use */
527 /* Floating point allocation. */
529 #ifdef LISP_FLOAT_TYPE
530 /* Allocation of float cells, just like conses */
531 /* We store float cells inside of float_blocks, allocating a new
532 float_block with malloc whenever necessary. Float cells reclaimed by
533 GC are put on a free list to be reallocated before allocating
534 any new float cells from the latest float_block.
536 Each float_block is just under 1020 bytes long,
537 since malloc really allocates in units of powers of two
538 and uses 4 bytes for its own overhead. */
540 #define FLOAT_BLOCK_SIZE \
541 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
545 struct float_block
*next
;
546 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
549 struct float_block
*float_block
;
550 int float_block_index
;
552 struct Lisp_Float
*float_free_list
;
557 allocating_for_lisp
= 1;
558 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
559 allocating_for_lisp
= 0;
560 float_block
->next
= 0;
561 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
562 float_block_index
= 0;
566 /* Explicitly free a float cell. */
568 struct Lisp_Float
*ptr
;
570 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
571 float_free_list
= ptr
;
575 make_float (float_value
)
578 register Lisp_Object val
;
582 XSETFLOAT (val
, float_free_list
);
583 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
587 if (float_block_index
== FLOAT_BLOCK_SIZE
)
589 register struct float_block
*new;
591 allocating_for_lisp
= 1;
592 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
593 allocating_for_lisp
= 0;
594 VALIDATE_LISP_STORAGE (new, sizeof *new);
595 new->next
= float_block
;
597 float_block_index
= 0;
599 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
601 XFLOAT (val
)->data
= float_value
;
602 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
603 consing_since_gc
+= sizeof (struct Lisp_Float
);
608 #endif /* LISP_FLOAT_TYPE */
610 /* Allocation of cons cells */
611 /* We store cons cells inside of cons_blocks, allocating a new
612 cons_block with malloc whenever necessary. Cons cells reclaimed by
613 GC are put on a free list to be reallocated before allocating
614 any new cons cells from the latest cons_block.
616 Each cons_block is just under 1020 bytes long,
617 since malloc really allocates in units of powers of two
618 and uses 4 bytes for its own overhead. */
620 #define CONS_BLOCK_SIZE \
621 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
625 struct cons_block
*next
;
626 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
629 struct cons_block
*cons_block
;
630 int cons_block_index
;
632 struct Lisp_Cons
*cons_free_list
;
637 allocating_for_lisp
= 1;
638 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
639 allocating_for_lisp
= 0;
640 cons_block
->next
= 0;
641 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
642 cons_block_index
= 0;
646 /* Explicitly free a cons cell. */
648 struct Lisp_Cons
*ptr
;
650 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
651 cons_free_list
= ptr
;
654 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
655 "Create a new cons, give it CAR and CDR as components, and return it.")
657 Lisp_Object car
, cdr
;
659 register Lisp_Object val
;
663 XSETCONS (val
, cons_free_list
);
664 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
668 if (cons_block_index
== CONS_BLOCK_SIZE
)
670 register struct cons_block
*new;
671 allocating_for_lisp
= 1;
672 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
673 allocating_for_lisp
= 0;
674 VALIDATE_LISP_STORAGE (new, sizeof *new);
675 new->next
= cons_block
;
677 cons_block_index
= 0;
679 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
681 XCONS (val
)->car
= car
;
682 XCONS (val
)->cdr
= cdr
;
683 consing_since_gc
+= sizeof (struct Lisp_Cons
);
688 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
689 "Return a newly created list with specified arguments as elements.\n\
690 Any number of arguments, even zero arguments, are allowed.")
693 register Lisp_Object
*args
;
695 register Lisp_Object val
;
701 val
= Fcons (args
[nargs
], val
);
706 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
707 "Return a newly created list of length LENGTH, with each element being INIT.")
709 register Lisp_Object length
, init
;
711 register Lisp_Object val
;
714 CHECK_NATNUM (length
, 0);
715 size
= XFASTINT (length
);
719 val
= Fcons (init
, val
);
723 /* Allocation of vectors */
725 struct Lisp_Vector
*all_vectors
;
728 allocate_vectorlike (len
)
731 struct Lisp_Vector
*p
;
733 allocating_for_lisp
= 1;
734 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
735 + (len
- 1) * sizeof (Lisp_Object
));
736 allocating_for_lisp
= 0;
737 VALIDATE_LISP_STORAGE (p
, 0);
738 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
739 + (len
- 1) * sizeof (Lisp_Object
));
740 vector_cells_consed
+= len
;
742 p
->next
= all_vectors
;
747 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
748 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
749 See also the function `vector'.")
751 register Lisp_Object length
, init
;
754 register EMACS_INT sizei
;
756 register struct Lisp_Vector
*p
;
758 CHECK_NATNUM (length
, 0);
759 sizei
= XFASTINT (length
);
761 p
= allocate_vectorlike (sizei
);
763 for (index
= 0; index
< sizei
; index
++)
764 p
->contents
[index
] = init
;
766 XSETVECTOR (vector
, p
);
770 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
771 "Return a newly created char-table, with purpose PURPOSE.\n\
772 Each element is initialized to INIT, which defaults to nil.\n\
773 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
774 The property's value should be an integer between 0 and 10.")
776 register Lisp_Object purpose
, init
;
780 CHECK_SYMBOL (purpose
, 1);
781 /* For a deeper char-table, PURPOSE can be nil. */
782 n
= NILP (purpose
) ? 0 : Fget (purpose
, Qchar_table_extra_slots
);
784 if (XINT (n
) < 0 || XINT (n
) > 10)
785 args_out_of_range (n
, Qnil
);
786 /* Add 2 to the size for the defalt and parent slots. */
787 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
789 XCHAR_TABLE (vector
)->parent
= Qnil
;
790 XCHAR_TABLE (vector
)->purpose
= purpose
;
791 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
795 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
796 "Return a newly created vector with specified arguments as elements.\n\
797 Any number of arguments, even zero arguments, are allowed.")
802 register Lisp_Object len
, val
;
804 register struct Lisp_Vector
*p
;
806 XSETFASTINT (len
, nargs
);
807 val
= Fmake_vector (len
, Qnil
);
809 for (index
= 0; index
< nargs
; index
++)
810 p
->contents
[index
] = args
[index
];
814 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
815 "Create a byte-code object with specified arguments as elements.\n\
816 The arguments should be the arglist, bytecode-string, constant vector,\n\
817 stack size, (optional) doc string, and (optional) interactive spec.\n\
818 The first four arguments are required; at most six have any\n\
824 register Lisp_Object len
, val
;
826 register struct Lisp_Vector
*p
;
828 XSETFASTINT (len
, nargs
);
829 if (!NILP (Vpurify_flag
))
830 val
= make_pure_vector ((EMACS_INT
) nargs
);
832 val
= Fmake_vector (len
, Qnil
);
834 for (index
= 0; index
< nargs
; index
++)
836 if (!NILP (Vpurify_flag
))
837 args
[index
] = Fpurecopy (args
[index
]);
838 p
->contents
[index
] = args
[index
];
840 XSETCOMPILED (val
, val
);
844 /* Allocation of symbols.
845 Just like allocation of conses!
847 Each symbol_block is just under 1020 bytes long,
848 since malloc really allocates in units of powers of two
849 and uses 4 bytes for its own overhead. */
851 #define SYMBOL_BLOCK_SIZE \
852 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
856 struct symbol_block
*next
;
857 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
860 struct symbol_block
*symbol_block
;
861 int symbol_block_index
;
863 struct Lisp_Symbol
*symbol_free_list
;
868 allocating_for_lisp
= 1;
869 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
870 allocating_for_lisp
= 0;
871 symbol_block
->next
= 0;
872 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
873 symbol_block_index
= 0;
874 symbol_free_list
= 0;
877 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
878 "Return a newly allocated uninterned symbol whose name is NAME.\n\
879 Its value and function definition are void, and its property list is nil.")
883 register Lisp_Object val
;
884 register struct Lisp_Symbol
*p
;
886 CHECK_STRING (name
, 0);
888 if (symbol_free_list
)
890 XSETSYMBOL (val
, symbol_free_list
);
891 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
895 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
897 struct symbol_block
*new;
898 allocating_for_lisp
= 1;
899 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
900 allocating_for_lisp
= 0;
901 VALIDATE_LISP_STORAGE (new, sizeof *new);
902 new->next
= symbol_block
;
904 symbol_block_index
= 0;
906 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
909 p
->name
= XSTRING (name
);
913 p
->function
= Qunbound
;
915 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
920 /* Allocation of markers and other objects that share that structure.
921 Works like allocation of conses. */
923 #define MARKER_BLOCK_SIZE \
924 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
928 struct marker_block
*next
;
929 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
932 struct marker_block
*marker_block
;
933 int marker_block_index
;
935 union Lisp_Misc
*marker_free_list
;
940 allocating_for_lisp
= 1;
941 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
942 allocating_for_lisp
= 0;
943 marker_block
->next
= 0;
944 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
945 marker_block_index
= 0;
946 marker_free_list
= 0;
949 /* Return a newly allocated Lisp_Misc object, with no substructure. */
955 if (marker_free_list
)
957 XSETMISC (val
, marker_free_list
);
958 marker_free_list
= marker_free_list
->u_free
.chain
;
962 if (marker_block_index
== MARKER_BLOCK_SIZE
)
964 struct marker_block
*new;
965 allocating_for_lisp
= 1;
966 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
967 allocating_for_lisp
= 0;
968 VALIDATE_LISP_STORAGE (new, sizeof *new);
969 new->next
= marker_block
;
971 marker_block_index
= 0;
973 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
975 consing_since_gc
+= sizeof (union Lisp_Misc
);
976 misc_objects_consed
++;
980 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
981 "Return a newly allocated marker which does not point at any place.")
984 register Lisp_Object val
;
985 register struct Lisp_Marker
*p
;
987 val
= allocate_misc ();
988 XMISCTYPE (val
) = Lisp_Misc_Marker
;
993 p
->insertion_type
= 0;
997 /* Allocation of strings */
999 /* Strings reside inside of string_blocks. The entire data of the string,
1000 both the size and the contents, live in part of the `chars' component of a string_block.
1001 The `pos' component is the index within `chars' of the first free byte.
1003 first_string_block points to the first string_block ever allocated.
1004 Each block points to the next one with its `next' field.
1005 The `prev' fields chain in reverse order.
1006 The last one allocated is the one currently being filled.
1007 current_string_block points to it.
1009 The string_blocks that hold individual large strings
1010 go in a separate chain, started by large_string_blocks. */
1013 /* String blocks contain this many useful bytes.
1014 8188 is power of 2, minus 4 for malloc overhead. */
1015 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1017 /* A string bigger than this gets its own specially-made string block
1018 if it doesn't fit in the current one. */
1019 #define STRING_BLOCK_OUTSIZE 1024
1021 struct string_block_head
1023 struct string_block
*next
, *prev
;
1029 struct string_block
*next
, *prev
;
1031 char chars
[STRING_BLOCK_SIZE
];
1034 /* This points to the string block we are now allocating strings. */
1036 struct string_block
*current_string_block
;
1038 /* This points to the oldest string block, the one that starts the chain. */
1040 struct string_block
*first_string_block
;
1042 /* Last string block in chain of those made for individual large strings. */
1044 struct string_block
*large_string_blocks
;
1046 /* If SIZE is the length of a string, this returns how many bytes
1047 the string occupies in a string_block (including padding). */
1049 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1051 #define PAD (sizeof (EMACS_INT))
1054 #define STRING_FULLSIZE(SIZE) \
1055 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1061 allocating_for_lisp
= 1;
1062 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1063 allocating_for_lisp
= 0;
1064 first_string_block
= current_string_block
;
1065 consing_since_gc
+= sizeof (struct string_block
);
1066 current_string_block
->next
= 0;
1067 current_string_block
->prev
= 0;
1068 current_string_block
->pos
= 0;
1069 large_string_blocks
= 0;
1072 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1073 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1074 Both LENGTH and INIT must be numbers.")
1076 Lisp_Object length
, init
;
1078 register Lisp_Object val
;
1079 register unsigned char *p
, *end
, c
;
1081 CHECK_NATNUM (length
, 0);
1082 CHECK_NUMBER (init
, 1);
1083 val
= make_uninit_string (XFASTINT (length
));
1085 p
= XSTRING (val
)->data
;
1086 end
= p
+ XSTRING (val
)->size
;
1093 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1094 "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\
1095 Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.")
1097 Lisp_Object length
, init
;
1099 register Lisp_Object val
;
1100 struct Lisp_Bool_Vector
*p
;
1102 int length_in_chars
, length_in_elts
, bits_per_value
;
1104 CHECK_NATNUM (length
, 0);
1106 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1108 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1109 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1111 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1112 slot `size' of the struct Lisp_Bool_Vector. */
1113 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1114 p
= XBOOL_VECTOR (val
);
1115 /* Get rid of any bits that would cause confusion. */
1117 XSETBOOL_VECTOR (val
, p
);
1118 p
->size
= XFASTINT (length
);
1120 real_init
= (NILP (init
) ? 0 : -1);
1121 for (i
= 0; i
< length_in_chars
; i
++)
1122 p
->data
[i
] = real_init
;
1128 make_string (contents
, length
)
1132 register Lisp_Object val
;
1133 val
= make_uninit_string (length
);
1134 bcopy (contents
, XSTRING (val
)->data
, length
);
1142 return make_string (str
, strlen (str
));
1146 make_uninit_string (length
)
1149 register Lisp_Object val
;
1150 register int fullsize
= STRING_FULLSIZE (length
);
1152 if (length
< 0) abort ();
1154 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1155 /* This string can fit in the current string block */
1158 ((struct Lisp_String
*)
1159 (current_string_block
->chars
+ current_string_block
->pos
)));
1160 current_string_block
->pos
+= fullsize
;
1162 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1163 /* This string gets its own string block */
1165 register struct string_block
*new;
1166 allocating_for_lisp
= 1;
1167 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1168 allocating_for_lisp
= 0;
1169 VALIDATE_LISP_STORAGE (new, 0);
1170 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1171 new->pos
= fullsize
;
1172 new->next
= large_string_blocks
;
1173 large_string_blocks
= new;
1175 ((struct Lisp_String
*)
1176 ((struct string_block_head
*)new + 1)));
1179 /* Make a new current string block and start it off with this string */
1181 register struct string_block
*new;
1182 allocating_for_lisp
= 1;
1183 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1184 allocating_for_lisp
= 0;
1185 VALIDATE_LISP_STORAGE (new, sizeof *new);
1186 consing_since_gc
+= sizeof (struct string_block
);
1187 current_string_block
->next
= new;
1188 new->prev
= current_string_block
;
1190 current_string_block
= new;
1191 new->pos
= fullsize
;
1193 (struct Lisp_String
*) current_string_block
->chars
);
1196 string_chars_consed
+= fullsize
;
1197 XSTRING (val
)->size
= length
;
1198 XSTRING (val
)->data
[length
] = 0;
1199 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1204 /* Return a newly created vector or string with specified arguments as
1205 elements. If all the arguments are characters that can fit
1206 in a string of events, make a string; otherwise, make a vector.
1208 Any number of arguments, even zero arguments, are allowed. */
1211 make_event_array (nargs
, args
)
1217 for (i
= 0; i
< nargs
; i
++)
1218 /* The things that fit in a string
1219 are characters that are in 0...127,
1220 after discarding the meta bit and all the bits above it. */
1221 if (!INTEGERP (args
[i
])
1222 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1223 return Fvector (nargs
, args
);
1225 /* Since the loop exited, we know that all the things in it are
1226 characters, so we can make a string. */
1230 result
= Fmake_string (nargs
, make_number (0));
1231 for (i
= 0; i
< nargs
; i
++)
1233 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1234 /* Move the meta bit to the right place for a string char. */
1235 if (XINT (args
[i
]) & CHAR_META
)
1236 XSTRING (result
)->data
[i
] |= 0x80;
1243 /* Pure storage management. */
1245 /* Must get an error if pure storage is full,
1246 since if it cannot hold a large string
1247 it may be able to hold conses that point to that string;
1248 then the string is not protected from gc. */
1251 make_pure_string (data
, length
)
1255 register Lisp_Object
new;
1256 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1258 if (pureptr
+ size
> PURESIZE
)
1259 error ("Pure Lisp storage exhausted");
1260 XSETSTRING (new, PUREBEG
+ pureptr
);
1261 XSTRING (new)->size
= length
;
1262 bcopy (data
, XSTRING (new)->data
, length
);
1263 XSTRING (new)->data
[length
] = 0;
1265 /* We must give strings in pure storage some kind of interval. So we
1266 give them a null one. */
1267 #if defined (USE_TEXT_PROPERTIES)
1268 XSTRING (new)->intervals
= NULL_INTERVAL
;
1270 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1271 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1276 pure_cons (car
, cdr
)
1277 Lisp_Object car
, cdr
;
1279 register Lisp_Object
new;
1281 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1282 error ("Pure Lisp storage exhausted");
1283 XSETCONS (new, PUREBEG
+ pureptr
);
1284 pureptr
+= sizeof (struct Lisp_Cons
);
1285 XCONS (new)->car
= Fpurecopy (car
);
1286 XCONS (new)->cdr
= Fpurecopy (cdr
);
1290 #ifdef LISP_FLOAT_TYPE
1293 make_pure_float (num
)
1296 register Lisp_Object
new;
1298 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1299 (double) boundary. Some architectures (like the sparc) require
1300 this, and I suspect that floats are rare enough that it's no
1301 tragedy for those that do. */
1304 char *p
= PUREBEG
+ pureptr
;
1308 alignment
= __alignof (struct Lisp_Float
);
1310 alignment
= sizeof (struct Lisp_Float
);
1313 alignment
= sizeof (struct Lisp_Float
);
1315 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1316 pureptr
= p
- PUREBEG
;
1319 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1320 error ("Pure Lisp storage exhausted");
1321 XSETFLOAT (new, PUREBEG
+ pureptr
);
1322 pureptr
+= sizeof (struct Lisp_Float
);
1323 XFLOAT (new)->data
= num
;
1324 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1328 #endif /* LISP_FLOAT_TYPE */
1331 make_pure_vector (len
)
1334 register Lisp_Object
new;
1335 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1337 if (pureptr
+ size
> PURESIZE
)
1338 error ("Pure Lisp storage exhausted");
1340 XSETVECTOR (new, PUREBEG
+ pureptr
);
1342 XVECTOR (new)->size
= len
;
1346 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1347 "Make a copy of OBJECT in pure storage.\n\
1348 Recursively copies contents of vectors and cons cells.\n\
1349 Does not copy symbols.")
1351 register Lisp_Object obj
;
1353 if (NILP (Vpurify_flag
))
1356 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1357 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1361 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1362 #ifdef LISP_FLOAT_TYPE
1363 else if (FLOATP (obj
))
1364 return make_pure_float (XFLOAT (obj
)->data
);
1365 #endif /* LISP_FLOAT_TYPE */
1366 else if (STRINGP (obj
))
1367 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1368 else if (COMPILEDP (obj
) || VECTORP (obj
))
1370 register struct Lisp_Vector
*vec
;
1371 register int i
, size
;
1373 size
= XVECTOR (obj
)->size
;
1374 if (size
& PSEUDOVECTOR_FLAG
)
1375 size
&= PSEUDOVECTOR_SIZE_MASK
;
1376 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1377 for (i
= 0; i
< size
; i
++)
1378 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1379 if (COMPILEDP (obj
))
1380 XSETCOMPILED (obj
, vec
);
1382 XSETVECTOR (obj
, vec
);
1385 else if (MARKERP (obj
))
1386 error ("Attempt to copy a marker to pure storage");
1391 /* Recording what needs to be marked for gc. */
1393 struct gcpro
*gcprolist
;
1395 #define NSTATICS 768
1397 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1401 /* Put an entry in staticvec, pointing at the variable whose address is given */
1404 staticpro (varaddress
)
1405 Lisp_Object
*varaddress
;
1407 staticvec
[staticidx
++] = varaddress
;
1408 if (staticidx
>= NSTATICS
)
1416 struct catchtag
*next
;
1417 /* jmp_buf jmp; /* We don't need this for GC purposes */
1422 struct backtrace
*next
;
1423 Lisp_Object
*function
;
1424 Lisp_Object
*args
; /* Points to vector of args. */
1425 int nargs
; /* length of vector */
1426 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1430 /* Garbage collection! */
1432 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1433 int total_free_conses
, total_free_markers
, total_free_symbols
;
1434 #ifdef LISP_FLOAT_TYPE
1435 int total_free_floats
, total_floats
;
1436 #endif /* LISP_FLOAT_TYPE */
1438 /* Temporarily prevent garbage collection. */
1441 inhibit_garbage_collection ()
1443 int count
= specpdl_ptr
- specpdl
;
1445 int nbits
= min (VALBITS
, BITS_PER_INT
);
1447 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1449 specbind (Qgc_cons_threshold
, number
);
1454 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1455 "Reclaim storage for Lisp objects no longer needed.\n\
1456 Returns info on amount of space in use:\n\
1457 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1458 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1459 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1460 Garbage collection happens automatically if you cons more than\n\
1461 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1464 register struct gcpro
*tail
;
1465 register struct specbinding
*bind
;
1466 struct catchtag
*catch;
1467 struct handler
*handler
;
1468 register struct backtrace
*backlist
;
1469 register Lisp_Object tem
;
1470 char *omessage
= echo_area_glyphs
;
1471 int omessage_length
= echo_area_glyphs_length
;
1472 char stack_top_variable
;
1475 /* In case user calls debug_print during GC,
1476 don't let that cause a recursive GC. */
1477 consing_since_gc
= 0;
1479 /* Save a copy of the contents of the stack, for debugging. */
1480 #if MAX_SAVE_STACK > 0
1481 if (NILP (Vpurify_flag
))
1483 i
= &stack_top_variable
- stack_bottom
;
1485 if (i
< MAX_SAVE_STACK
)
1487 if (stack_copy
== 0)
1488 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1489 else if (stack_copy_size
< i
)
1490 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1493 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1494 bcopy (stack_bottom
, stack_copy
, i
);
1496 bcopy (&stack_top_variable
, stack_copy
, i
);
1500 #endif /* MAX_SAVE_STACK > 0 */
1502 if (garbage_collection_messages
)
1503 message1_nolog ("Garbage collecting...");
1505 /* Don't keep command history around forever. */
1506 if (NUMBERP (Vhistory_length
) && XINT (Vhistory_length
) > 0)
1508 tem
= Fnthcdr (Vhistory_length
, Vcommand_history
);
1510 XCONS (tem
)->cdr
= Qnil
;
1513 /* Likewise for undo information. */
1515 register struct buffer
*nextb
= all_buffers
;
1519 /* If a buffer's undo list is Qt, that means that undo is
1520 turned off in that buffer. Calling truncate_undo_list on
1521 Qt tends to return NULL, which effectively turns undo back on.
1522 So don't call truncate_undo_list if undo_list is Qt. */
1523 if (! EQ (nextb
->undo_list
, Qt
))
1525 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1527 nextb
= nextb
->next
;
1533 /* clear_marks (); */
1535 /* In each "large string", set the MARKBIT of the size field.
1536 That enables mark_object to recognize them. */
1538 register struct string_block
*b
;
1539 for (b
= large_string_blocks
; b
; b
= b
->next
)
1540 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1543 /* Mark all the special slots that serve as the roots of accessibility.
1545 Usually the special slots to mark are contained in particular structures.
1546 Then we know no slot is marked twice because the structures don't overlap.
1547 In some cases, the structures point to the slots to be marked.
1548 For these, we use MARKBIT to avoid double marking of the slot. */
1550 for (i
= 0; i
< staticidx
; i
++)
1551 mark_object (staticvec
[i
]);
1552 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1553 for (i
= 0; i
< tail
->nvars
; i
++)
1554 if (!XMARKBIT (tail
->var
[i
]))
1556 mark_object (&tail
->var
[i
]);
1557 XMARK (tail
->var
[i
]);
1559 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1561 mark_object (&bind
->symbol
);
1562 mark_object (&bind
->old_value
);
1564 for (catch = catchlist
; catch; catch = catch->next
)
1566 mark_object (&catch->tag
);
1567 mark_object (&catch->val
);
1569 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1571 mark_object (&handler
->handler
);
1572 mark_object (&handler
->var
);
1574 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1576 if (!XMARKBIT (*backlist
->function
))
1578 mark_object (backlist
->function
);
1579 XMARK (*backlist
->function
);
1581 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1584 i
= backlist
->nargs
- 1;
1586 if (!XMARKBIT (backlist
->args
[i
]))
1588 mark_object (&backlist
->args
[i
]);
1589 XMARK (backlist
->args
[i
]);
1596 /* Clear the mark bits that we set in certain root slots. */
1598 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1599 for (i
= 0; i
< tail
->nvars
; i
++)
1600 XUNMARK (tail
->var
[i
]);
1601 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1603 XUNMARK (*backlist
->function
);
1604 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1607 i
= backlist
->nargs
- 1;
1609 XUNMARK (backlist
->args
[i
]);
1611 XUNMARK (buffer_defaults
.name
);
1612 XUNMARK (buffer_local_symbols
.name
);
1614 /* clear_marks (); */
1617 consing_since_gc
= 0;
1618 if (gc_cons_threshold
< 10000)
1619 gc_cons_threshold
= 10000;
1621 if (garbage_collection_messages
)
1623 if (omessage
|| minibuf_level
> 0)
1624 message2_nolog (omessage
, omessage_length
);
1626 message1_nolog ("Garbage collecting...done");
1629 return Fcons (Fcons (make_number (total_conses
),
1630 make_number (total_free_conses
)),
1631 Fcons (Fcons (make_number (total_symbols
),
1632 make_number (total_free_symbols
)),
1633 Fcons (Fcons (make_number (total_markers
),
1634 make_number (total_free_markers
)),
1635 Fcons (make_number (total_string_size
),
1636 Fcons (make_number (total_vector_size
),
1638 #ifdef LISP_FLOAT_TYPE
1639 (make_number (total_floats
),
1640 make_number (total_free_floats
)),
1641 #else /* not LISP_FLOAT_TYPE */
1642 (make_number (0), make_number (0)),
1643 #endif /* not LISP_FLOAT_TYPE */
1645 #ifdef USE_TEXT_PROPERTIES
1646 (make_number (total_intervals
),
1647 make_number (total_free_intervals
)),
1648 #else /* not USE_TEXT_PROPERTIES */
1649 (make_number (0), make_number (0)),
1650 #endif /* not USE_TEXT_PROPERTIES */
1658 /* Clear marks on all conses */
1660 register struct cons_block
*cblk
;
1661 register int lim
= cons_block_index
;
1663 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1666 for (i
= 0; i
< lim
; i
++)
1667 XUNMARK (cblk
->conses
[i
].car
);
1668 lim
= CONS_BLOCK_SIZE
;
1671 /* Clear marks on all symbols */
1673 register struct symbol_block
*sblk
;
1674 register int lim
= symbol_block_index
;
1676 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1679 for (i
= 0; i
< lim
; i
++)
1681 XUNMARK (sblk
->symbols
[i
].plist
);
1683 lim
= SYMBOL_BLOCK_SIZE
;
1686 /* Clear marks on all markers */
1688 register struct marker_block
*sblk
;
1689 register int lim
= marker_block_index
;
1691 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1694 for (i
= 0; i
< lim
; i
++)
1695 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1696 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1697 lim
= MARKER_BLOCK_SIZE
;
1700 /* Clear mark bits on all buffers */
1702 register struct buffer
*nextb
= all_buffers
;
1706 XUNMARK (nextb
->name
);
1707 nextb
= nextb
->next
;
1713 /* Mark reference to a Lisp_Object.
1714 If the object referred to has not been seen yet, recursively mark
1715 all the references contained in it.
1717 If the object referenced is a short string, the referencing slot
1718 is threaded into a chain of such slots, pointed to from
1719 the `size' field of the string. The actual string size
1720 lives in the last slot in the chain. We recognize the end
1721 because it is < (unsigned) STRING_BLOCK_SIZE. */
1723 #define LAST_MARKED_SIZE 500
1724 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1725 int last_marked_index
;
1728 mark_object (argptr
)
1729 Lisp_Object
*argptr
;
1731 Lisp_Object
*objptr
= argptr
;
1732 register Lisp_Object obj
;
1739 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1740 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1743 last_marked
[last_marked_index
++] = objptr
;
1744 if (last_marked_index
== LAST_MARKED_SIZE
)
1745 last_marked_index
= 0;
1747 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1751 register struct Lisp_String
*ptr
= XSTRING (obj
);
1753 MARK_INTERVAL_TREE (ptr
->intervals
);
1754 if (ptr
->size
& MARKBIT
)
1755 /* A large string. Just set ARRAY_MARK_FLAG. */
1756 ptr
->size
|= ARRAY_MARK_FLAG
;
1759 /* A small string. Put this reference
1760 into the chain of references to it.
1761 If the address includes MARKBIT, put that bit elsewhere
1762 when we store OBJPTR into the size field. */
1764 if (XMARKBIT (*objptr
))
1766 XSETFASTINT (*objptr
, ptr
->size
);
1770 XSETFASTINT (*objptr
, ptr
->size
);
1772 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1774 ptr
->size
= (EMACS_INT
) objptr
;
1775 if (ptr
->size
& MARKBIT
)
1776 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1781 case Lisp_Vectorlike
:
1782 if (GC_BUFFERP (obj
))
1784 if (!XMARKBIT (XBUFFER (obj
)->name
))
1787 else if (GC_SUBRP (obj
))
1789 else if (GC_COMPILEDP (obj
))
1790 /* We could treat this just like a vector, but it is better
1791 to save the COMPILED_CONSTANTS element for last and avoid recursion
1794 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1795 register EMACS_INT size
= ptr
->size
;
1796 /* See comment above under Lisp_Vector. */
1797 struct Lisp_Vector
*volatile ptr1
= ptr
;
1800 if (size
& ARRAY_MARK_FLAG
)
1801 break; /* Already marked */
1802 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1803 size
&= PSEUDOVECTOR_SIZE_MASK
;
1804 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1806 if (i
!= COMPILED_CONSTANTS
)
1807 mark_object (&ptr1
->contents
[i
]);
1809 /* This cast should be unnecessary, but some Mips compiler complains
1810 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1811 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1814 else if (GC_FRAMEP (obj
))
1816 /* See comment above under Lisp_Vector for why this is volatile. */
1817 register struct frame
*volatile ptr
= XFRAME (obj
);
1818 register EMACS_INT size
= ptr
->size
;
1820 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1821 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1823 mark_object (&ptr
->name
);
1824 mark_object (&ptr
->icon_name
);
1825 mark_object (&ptr
->title
);
1826 mark_object (&ptr
->focus_frame
);
1827 mark_object (&ptr
->selected_window
);
1828 mark_object (&ptr
->minibuffer_window
);
1829 mark_object (&ptr
->param_alist
);
1830 mark_object (&ptr
->scroll_bars
);
1831 mark_object (&ptr
->condemned_scroll_bars
);
1832 mark_object (&ptr
->menu_bar_items
);
1833 mark_object (&ptr
->face_alist
);
1834 mark_object (&ptr
->menu_bar_vector
);
1835 mark_object (&ptr
->buffer_predicate
);
1836 mark_object (&ptr
->buffer_list
);
1838 else if (GC_BOOL_VECTOR_P (obj
))
1840 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1842 if (ptr
->size
& ARRAY_MARK_FLAG
)
1843 break; /* Already marked */
1844 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1848 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1849 register EMACS_INT size
= ptr
->size
;
1850 /* The reason we use ptr1 is to avoid an apparent hardware bug
1851 that happens occasionally on the FSF's HP 300s.
1852 The bug is that a2 gets clobbered by recursive calls to mark_object.
1853 The clobberage seems to happen during function entry,
1854 perhaps in the moveml instruction.
1855 Yes, this is a crock, but we have to do it. */
1856 struct Lisp_Vector
*volatile ptr1
= ptr
;
1859 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1860 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1861 if (size
& PSEUDOVECTOR_FLAG
)
1862 size
&= PSEUDOVECTOR_SIZE_MASK
;
1863 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1864 mark_object (&ptr1
->contents
[i
]);
1870 /* See comment above under Lisp_Vector for why this is volatile. */
1871 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1872 struct Lisp_Symbol
*ptrx
;
1874 if (XMARKBIT (ptr
->plist
)) break;
1876 mark_object ((Lisp_Object
*) &ptr
->value
);
1877 mark_object (&ptr
->function
);
1878 mark_object (&ptr
->plist
);
1879 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1880 mark_object (&ptr
->name
);
1884 /* For the benefit of the last_marked log. */
1885 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1886 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1887 XSETSYMBOL (obj
, ptrx
);
1888 /* We can't goto loop here because *objptr doesn't contain an
1889 actual Lisp_Object with valid datatype field. */
1896 switch (XMISCTYPE (obj
))
1898 case Lisp_Misc_Marker
:
1899 XMARK (XMARKER (obj
)->chain
);
1900 /* DO NOT mark thru the marker's chain.
1901 The buffer's markers chain does not preserve markers from gc;
1902 instead, markers are removed from the chain when freed by gc. */
1905 case Lisp_Misc_Buffer_Local_Value
:
1906 case Lisp_Misc_Some_Buffer_Local_Value
:
1908 register struct Lisp_Buffer_Local_Value
*ptr
1909 = XBUFFER_LOCAL_VALUE (obj
);
1910 if (XMARKBIT (ptr
->car
)) break;
1912 /* If the cdr is nil, avoid recursion for the car. */
1913 if (EQ (ptr
->cdr
, Qnil
))
1918 mark_object (&ptr
->car
);
1919 /* See comment above under Lisp_Vector for why not use ptr here. */
1920 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1924 case Lisp_Misc_Intfwd
:
1925 case Lisp_Misc_Boolfwd
:
1926 case Lisp_Misc_Objfwd
:
1927 case Lisp_Misc_Buffer_Objfwd
:
1928 case Lisp_Misc_Kboard_Objfwd
:
1929 /* Don't bother with Lisp_Buffer_Objfwd,
1930 since all markable slots in current buffer marked anyway. */
1931 /* Don't need to do Lisp_Objfwd, since the places they point
1932 are protected with staticpro. */
1935 case Lisp_Misc_Overlay
:
1937 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1938 if (!XMARKBIT (ptr
->plist
))
1941 mark_object (&ptr
->start
);
1942 mark_object (&ptr
->end
);
1943 objptr
= &ptr
->plist
;
1956 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1957 if (XMARKBIT (ptr
->car
)) break;
1959 /* If the cdr is nil, avoid recursion for the car. */
1960 if (EQ (ptr
->cdr
, Qnil
))
1965 mark_object (&ptr
->car
);
1966 /* See comment above under Lisp_Vector for why not use ptr here. */
1967 objptr
= &XCONS (obj
)->cdr
;
1971 #ifdef LISP_FLOAT_TYPE
1973 XMARK (XFLOAT (obj
)->type
);
1975 #endif /* LISP_FLOAT_TYPE */
1985 /* Mark the pointers in a buffer structure. */
1991 register struct buffer
*buffer
= XBUFFER (buf
);
1992 register Lisp_Object
*ptr
;
1993 Lisp_Object base_buffer
;
1995 /* This is the buffer's markbit */
1996 mark_object (&buffer
->name
);
1997 XMARK (buffer
->name
);
1999 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2002 mark_object (buffer
->syntax_table
);
2004 /* Mark the various string-pointers in the buffer object.
2005 Since the strings may be relocated, we must mark them
2006 in their actual slots. So gc_sweep must convert each slot
2007 back to an ordinary C pointer. */
2008 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2009 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2010 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2011 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2013 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2014 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2015 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2016 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2019 for (ptr
= &buffer
->name
+ 1;
2020 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2024 /* If this is an indirect buffer, mark its base buffer. */
2025 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2027 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2028 mark_buffer (base_buffer
);
2033 /* Mark the pointers in the kboard objects. */
2040 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2042 if (kb
->kbd_macro_buffer
)
2043 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2045 mark_object (&kb
->Vprefix_arg
);
2046 mark_object (&kb
->kbd_queue
);
2047 mark_object (&kb
->Vlast_kbd_macro
);
2048 mark_object (&kb
->Vsystem_key_alist
);
2049 mark_object (&kb
->system_key_syms
);
2053 /* Sweep: find all structures not marked, and free them. */
2058 total_string_size
= 0;
2061 /* Put all unmarked conses on free list */
2063 register struct cons_block
*cblk
;
2064 register int lim
= cons_block_index
;
2065 register int num_free
= 0, num_used
= 0;
2069 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
2072 for (i
= 0; i
< lim
; i
++)
2073 if (!XMARKBIT (cblk
->conses
[i
].car
))
2076 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
2077 cons_free_list
= &cblk
->conses
[i
];
2082 XUNMARK (cblk
->conses
[i
].car
);
2084 lim
= CONS_BLOCK_SIZE
;
2086 total_conses
= num_used
;
2087 total_free_conses
= num_free
;
2090 #ifdef LISP_FLOAT_TYPE
2091 /* Put all unmarked floats on free list */
2093 register struct float_block
*fblk
;
2094 register int lim
= float_block_index
;
2095 register int num_free
= 0, num_used
= 0;
2097 float_free_list
= 0;
2099 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2102 for (i
= 0; i
< lim
; i
++)
2103 if (!XMARKBIT (fblk
->floats
[i
].type
))
2106 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2107 float_free_list
= &fblk
->floats
[i
];
2112 XUNMARK (fblk
->floats
[i
].type
);
2114 lim
= FLOAT_BLOCK_SIZE
;
2116 total_floats
= num_used
;
2117 total_free_floats
= num_free
;
2119 #endif /* LISP_FLOAT_TYPE */
2121 #ifdef USE_TEXT_PROPERTIES
2122 /* Put all unmarked intervals on free list */
2124 register struct interval_block
*iblk
;
2125 register int lim
= interval_block_index
;
2126 register int num_free
= 0, num_used
= 0;
2128 interval_free_list
= 0;
2130 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2134 for (i
= 0; i
< lim
; i
++)
2136 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2138 iblk
->intervals
[i
].parent
= interval_free_list
;
2139 interval_free_list
= &iblk
->intervals
[i
];
2145 XUNMARK (iblk
->intervals
[i
].plist
);
2148 lim
= INTERVAL_BLOCK_SIZE
;
2150 total_intervals
= num_used
;
2151 total_free_intervals
= num_free
;
2153 #endif /* USE_TEXT_PROPERTIES */
2155 /* Put all unmarked symbols on free list */
2157 register struct symbol_block
*sblk
;
2158 register int lim
= symbol_block_index
;
2159 register int num_free
= 0, num_used
= 0;
2161 symbol_free_list
= 0;
2163 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2166 for (i
= 0; i
< lim
; i
++)
2167 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2169 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2170 symbol_free_list
= &sblk
->symbols
[i
];
2176 sblk
->symbols
[i
].name
2177 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2178 XUNMARK (sblk
->symbols
[i
].plist
);
2180 lim
= SYMBOL_BLOCK_SIZE
;
2182 total_symbols
= num_used
;
2183 total_free_symbols
= num_free
;
2187 /* Put all unmarked markers on free list.
2188 Unchain each one first from the buffer it points into,
2189 but only if it's a real marker. */
2191 register struct marker_block
*mblk
;
2192 register int lim
= marker_block_index
;
2193 register int num_free
= 0, num_used
= 0;
2195 marker_free_list
= 0;
2197 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2200 EMACS_INT already_free
= -1;
2202 for (i
= 0; i
< lim
; i
++)
2204 Lisp_Object
*markword
;
2205 switch (mblk
->markers
[i
].u_marker
.type
)
2207 case Lisp_Misc_Marker
:
2208 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2210 case Lisp_Misc_Buffer_Local_Value
:
2211 case Lisp_Misc_Some_Buffer_Local_Value
:
2212 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2214 case Lisp_Misc_Overlay
:
2215 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2217 case Lisp_Misc_Free
:
2218 /* If the object was already free, keep it
2219 on the free list. */
2220 markword
= &already_free
;
2226 if (markword
&& !XMARKBIT (*markword
))
2229 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2231 /* tem1 avoids Sun compiler bug */
2232 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2233 XSETMARKER (tem
, tem1
);
2234 unchain_marker (tem
);
2236 /* Set the type of the freed object to Lisp_Misc_Free.
2237 We could leave the type alone, since nobody checks it,
2238 but this might catch bugs faster. */
2239 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2240 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2241 marker_free_list
= &mblk
->markers
[i
];
2248 XUNMARK (*markword
);
2251 lim
= MARKER_BLOCK_SIZE
;
2254 total_markers
= num_used
;
2255 total_free_markers
= num_free
;
2258 /* Free all unmarked buffers */
2260 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2263 if (!XMARKBIT (buffer
->name
))
2266 prev
->next
= buffer
->next
;
2268 all_buffers
= buffer
->next
;
2269 next
= buffer
->next
;
2275 XUNMARK (buffer
->name
);
2276 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2279 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2280 for purposes of marking and relocation.
2281 Turn them back into C pointers now. */
2282 buffer
->upcase_table
2283 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2284 buffer
->downcase_table
2285 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2287 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2288 buffer
->folding_sort_table
2289 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2292 prev
= buffer
, buffer
= buffer
->next
;
2296 #endif /* standalone */
2298 /* Free all unmarked vectors */
2300 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2301 total_vector_size
= 0;
2304 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2307 prev
->next
= vector
->next
;
2309 all_vectors
= vector
->next
;
2310 next
= vector
->next
;
2316 vector
->size
&= ~ARRAY_MARK_FLAG
;
2317 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2318 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2320 total_vector_size
+= vector
->size
;
2321 prev
= vector
, vector
= vector
->next
;
2325 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2327 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2328 struct Lisp_String
*s
;
2332 s
= (struct Lisp_String
*) &sb
->chars
[0];
2333 if (s
->size
& ARRAY_MARK_FLAG
)
2335 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2336 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2337 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2338 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2339 prev
= sb
, sb
= sb
->next
;
2344 prev
->next
= sb
->next
;
2346 large_string_blocks
= sb
->next
;
2355 /* Compactify strings, relocate references, and free empty string blocks. */
2360 /* String block of old strings we are scanning. */
2361 register struct string_block
*from_sb
;
2362 /* A preceding string block (or maybe the same one)
2363 where we are copying the still-live strings to. */
2364 register struct string_block
*to_sb
;
2368 to_sb
= first_string_block
;
2371 /* Scan each existing string block sequentially, string by string. */
2372 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2375 /* POS is the index of the next string in the block. */
2376 while (pos
< from_sb
->pos
)
2378 register struct Lisp_String
*nextstr
2379 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2381 register struct Lisp_String
*newaddr
;
2382 register EMACS_INT size
= nextstr
->size
;
2384 /* NEXTSTR is the old address of the next string.
2385 Just skip it if it isn't marked. */
2386 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2388 /* It is marked, so its size field is really a chain of refs.
2389 Find the end of the chain, where the actual size lives. */
2390 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2392 if (size
& DONT_COPY_FLAG
)
2393 size
^= MARKBIT
| DONT_COPY_FLAG
;
2394 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2397 total_string_size
+= size
;
2399 /* If it won't fit in TO_SB, close it out,
2400 and move to the next sb. Keep doing so until
2401 TO_SB reaches a large enough, empty enough string block.
2402 We know that TO_SB cannot advance past FROM_SB here
2403 since FROM_SB is large enough to contain this string.
2404 Any string blocks skipped here
2405 will be patched out and freed later. */
2406 while (to_pos
+ STRING_FULLSIZE (size
)
2407 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2409 to_sb
->pos
= to_pos
;
2410 to_sb
= to_sb
->next
;
2413 /* Compute new address of this string
2414 and update TO_POS for the space being used. */
2415 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2416 to_pos
+= STRING_FULLSIZE (size
);
2418 /* Copy the string itself to the new place. */
2419 if (nextstr
!= newaddr
)
2420 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2421 + INTERVAL_PTR_SIZE
);
2423 /* Go through NEXTSTR's chain of references
2424 and make each slot in the chain point to
2425 the new address of this string. */
2426 size
= newaddr
->size
;
2427 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2429 register Lisp_Object
*objptr
;
2430 if (size
& DONT_COPY_FLAG
)
2431 size
^= MARKBIT
| DONT_COPY_FLAG
;
2432 objptr
= (Lisp_Object
*)size
;
2434 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2435 if (XMARKBIT (*objptr
))
2437 XSETSTRING (*objptr
, newaddr
);
2441 XSETSTRING (*objptr
, newaddr
);
2443 /* Store the actual size in the size field. */
2444 newaddr
->size
= size
;
2446 #ifdef USE_TEXT_PROPERTIES
2447 /* Now that the string has been relocated, rebalance its
2448 interval tree, and update the tree's parent pointer. */
2449 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2451 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2452 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2455 #endif /* USE_TEXT_PROPERTIES */
2457 pos
+= STRING_FULLSIZE (size
);
2461 /* Close out the last string block still used and free any that follow. */
2462 to_sb
->pos
= to_pos
;
2463 current_string_block
= to_sb
;
2465 from_sb
= to_sb
->next
;
2469 to_sb
= from_sb
->next
;
2474 /* Free any empty string blocks further back in the chain.
2475 This loop will never free first_string_block, but it is very
2476 unlikely that that one will become empty, so why bother checking? */
2478 from_sb
= first_string_block
;
2479 while (to_sb
= from_sb
->next
)
2481 if (to_sb
->pos
== 0)
2483 if (from_sb
->next
= to_sb
->next
)
2484 from_sb
->next
->prev
= from_sb
;
2492 /* Debugging aids. */
2494 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2495 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2496 This may be helpful in debugging Emacs's memory usage.\n\
2497 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2502 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2507 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2508 "Return a list of counters that measure how much consing there has been.\n\
2509 Each of these counters increments for a certain kind of object.\n\
2510 The counters wrap around from the largest positive integer to zero.\n\
2511 Garbage collection does not decrease them.\n\
2512 The elements of the value are as follows:\n\
2513 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2514 All are in units of 1 = one object consed\n\
2515 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2517 MISCS include overlays, markers, and some internal types.\n\
2518 Frames, windows, buffers, and subprocesses count as vectors\n\
2519 (but the contents of a buffer's text do not count here).")
2522 Lisp_Object lisp_cons_cells_consed
;
2523 Lisp_Object lisp_floats_consed
;
2524 Lisp_Object lisp_vector_cells_consed
;
2525 Lisp_Object lisp_symbols_consed
;
2526 Lisp_Object lisp_string_chars_consed
;
2527 Lisp_Object lisp_misc_objects_consed
;
2528 Lisp_Object lisp_intervals_consed
;
2530 XSETINT (lisp_cons_cells_consed
,
2531 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2532 XSETINT (lisp_floats_consed
,
2533 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2534 XSETINT (lisp_vector_cells_consed
,
2535 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2536 XSETINT (lisp_symbols_consed
,
2537 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2538 XSETINT (lisp_string_chars_consed
,
2539 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2540 XSETINT (lisp_misc_objects_consed
,
2541 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2542 XSETINT (lisp_intervals_consed
,
2543 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2545 return Fcons (lisp_cons_cells_consed
,
2546 Fcons (lisp_floats_consed
,
2547 Fcons (lisp_vector_cells_consed
,
2548 Fcons (lisp_symbols_consed
,
2549 Fcons (lisp_string_chars_consed
,
2550 Fcons (lisp_misc_objects_consed
,
2551 Fcons (lisp_intervals_consed
,
2555 /* Initialization */
2559 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2562 pure_size
= PURESIZE
;
2565 ignore_warnings
= 1;
2570 #ifdef LISP_FLOAT_TYPE
2572 #endif /* LISP_FLOAT_TYPE */
2576 malloc_hysteresis
= 32;
2578 malloc_hysteresis
= 0;
2581 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2583 ignore_warnings
= 0;
2586 consing_since_gc
= 0;
2587 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2588 #ifdef VIRT_ADDR_VARIES
2589 malloc_sbrk_unused
= 1<<22; /* A large number */
2590 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2591 #endif /* VIRT_ADDR_VARIES */
2602 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2603 "*Number of bytes of consing between garbage collections.\n\
2604 Garbage collection can happen automatically once this many bytes have been\n\
2605 allocated since the last garbage collection. All data types count.\n\n\
2606 Garbage collection happens automatically only when `eval' is called.\n\n\
2607 By binding this temporarily to a large number, you can effectively\n\
2608 prevent garbage collection during a part of the program.");
2610 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2611 "Number of bytes of sharable Lisp data allocated so far.");
2613 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2614 "Number of cons cells that have been consed so far.");
2616 DEFVAR_INT ("floats-consed", &floats_consed
,
2617 "Number of floats that have been consed so far.");
2619 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2620 "Number of vector cells that have been consed so far.");
2622 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2623 "Number of symbols that have been consed so far.");
2625 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2626 "Number of string characters that have been consed so far.");
2628 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2629 "Number of miscellaneous objects that have been consed so far.");
2631 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2632 "Number of intervals that have been consed so far.");
2635 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2636 "Number of bytes of unshared memory allocated in this session.");
2638 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2639 "Number of bytes of unshared memory remaining available in this session.");
2642 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2643 "Non-nil means loading Lisp code in order to dump an executable.\n\
2644 This means that certain objects should be allocated in shared (pure) space.");
2646 DEFVAR_INT ("undo-limit", &undo_limit
,
2647 "Keep no more undo information once it exceeds this size.\n\
2648 This limit is applied when garbage collection happens.\n\
2649 The size is counted as the number of bytes occupied,\n\
2650 which includes both saved text and other data.");
2653 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2654 "Don't keep more than this much size of undo information.\n\
2655 A command which pushes past this size is itself forgotten.\n\
2656 This limit is applied when garbage collection happens.\n\
2657 The size is counted as the number of bytes occupied,\n\
2658 which includes both saved text and other data.");
2659 undo_strong_limit
= 30000;
2661 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2662 "Non-nil means display messages at start and end of garbage collection.");
2663 garbage_collection_messages
= 0;
2665 /* We build this in advance because if we wait until we need it, we might
2666 not be able to allocate the memory to hold it. */
2668 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2669 staticpro (&memory_signal_data
);
2671 staticpro (&Qgc_cons_threshold
);
2672 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2674 staticpro (&Qchar_table_extra_slots
);
2675 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2680 defsubr (&Smake_byte_code
);
2681 defsubr (&Smake_list
);
2682 defsubr (&Smake_vector
);
2683 defsubr (&Smake_char_table
);
2684 defsubr (&Smake_string
);
2685 defsubr (&Smake_bool_vector
);
2686 defsubr (&Smake_symbol
);
2687 defsubr (&Smake_marker
);
2688 defsubr (&Spurecopy
);
2689 defsubr (&Sgarbage_collect
);
2690 defsubr (&Smemory_limit
);
2691 defsubr (&Smemory_use_counts
);