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
);
1837 else if (GC_BOOL_VECTOR_P (obj
))
1839 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1841 if (ptr
->size
& ARRAY_MARK_FLAG
)
1842 break; /* Already marked */
1843 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1847 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1848 register EMACS_INT size
= ptr
->size
;
1849 /* The reason we use ptr1 is to avoid an apparent hardware bug
1850 that happens occasionally on the FSF's HP 300s.
1851 The bug is that a2 gets clobbered by recursive calls to mark_object.
1852 The clobberage seems to happen during function entry,
1853 perhaps in the moveml instruction.
1854 Yes, this is a crock, but we have to do it. */
1855 struct Lisp_Vector
*volatile ptr1
= ptr
;
1858 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1859 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1860 if (size
& PSEUDOVECTOR_FLAG
)
1861 size
&= PSEUDOVECTOR_SIZE_MASK
;
1862 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1863 mark_object (&ptr1
->contents
[i
]);
1869 /* See comment above under Lisp_Vector for why this is volatile. */
1870 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1871 struct Lisp_Symbol
*ptrx
;
1873 if (XMARKBIT (ptr
->plist
)) break;
1875 mark_object ((Lisp_Object
*) &ptr
->value
);
1876 mark_object (&ptr
->function
);
1877 mark_object (&ptr
->plist
);
1878 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1879 mark_object (&ptr
->name
);
1883 /* For the benefit of the last_marked log. */
1884 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1885 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1886 XSETSYMBOL (obj
, ptrx
);
1887 /* We can't goto loop here because *objptr doesn't contain an
1888 actual Lisp_Object with valid datatype field. */
1895 switch (XMISCTYPE (obj
))
1897 case Lisp_Misc_Marker
:
1898 XMARK (XMARKER (obj
)->chain
);
1899 /* DO NOT mark thru the marker's chain.
1900 The buffer's markers chain does not preserve markers from gc;
1901 instead, markers are removed from the chain when freed by gc. */
1904 case Lisp_Misc_Buffer_Local_Value
:
1905 case Lisp_Misc_Some_Buffer_Local_Value
:
1907 register struct Lisp_Buffer_Local_Value
*ptr
1908 = XBUFFER_LOCAL_VALUE (obj
);
1909 if (XMARKBIT (ptr
->car
)) break;
1911 /* If the cdr is nil, avoid recursion for the car. */
1912 if (EQ (ptr
->cdr
, Qnil
))
1917 mark_object (&ptr
->car
);
1918 /* See comment above under Lisp_Vector for why not use ptr here. */
1919 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1923 case Lisp_Misc_Intfwd
:
1924 case Lisp_Misc_Boolfwd
:
1925 case Lisp_Misc_Objfwd
:
1926 case Lisp_Misc_Buffer_Objfwd
:
1927 case Lisp_Misc_Kboard_Objfwd
:
1928 /* Don't bother with Lisp_Buffer_Objfwd,
1929 since all markable slots in current buffer marked anyway. */
1930 /* Don't need to do Lisp_Objfwd, since the places they point
1931 are protected with staticpro. */
1934 case Lisp_Misc_Overlay
:
1936 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1937 if (!XMARKBIT (ptr
->plist
))
1940 mark_object (&ptr
->start
);
1941 mark_object (&ptr
->end
);
1942 objptr
= &ptr
->plist
;
1955 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1956 if (XMARKBIT (ptr
->car
)) break;
1958 /* If the cdr is nil, avoid recursion for the car. */
1959 if (EQ (ptr
->cdr
, Qnil
))
1964 mark_object (&ptr
->car
);
1965 /* See comment above under Lisp_Vector for why not use ptr here. */
1966 objptr
= &XCONS (obj
)->cdr
;
1970 #ifdef LISP_FLOAT_TYPE
1972 XMARK (XFLOAT (obj
)->type
);
1974 #endif /* LISP_FLOAT_TYPE */
1984 /* Mark the pointers in a buffer structure. */
1990 register struct buffer
*buffer
= XBUFFER (buf
);
1991 register Lisp_Object
*ptr
;
1992 Lisp_Object base_buffer
;
1994 /* This is the buffer's markbit */
1995 mark_object (&buffer
->name
);
1996 XMARK (buffer
->name
);
1998 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2001 mark_object (buffer
->syntax_table
);
2003 /* Mark the various string-pointers in the buffer object.
2004 Since the strings may be relocated, we must mark them
2005 in their actual slots. So gc_sweep must convert each slot
2006 back to an ordinary C pointer. */
2007 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2008 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2009 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2010 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2012 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2013 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2014 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2015 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2018 for (ptr
= &buffer
->name
+ 1;
2019 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2023 /* If this is an indirect buffer, mark its base buffer. */
2024 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2026 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2027 mark_buffer (base_buffer
);
2032 /* Mark the pointers in the kboard objects. */
2039 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2041 if (kb
->kbd_macro_buffer
)
2042 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2044 mark_object (&kb
->Vprefix_arg
);
2045 mark_object (&kb
->kbd_queue
);
2046 mark_object (&kb
->Vlast_kbd_macro
);
2047 mark_object (&kb
->Vsystem_key_alist
);
2048 mark_object (&kb
->system_key_syms
);
2052 /* Sweep: find all structures not marked, and free them. */
2057 total_string_size
= 0;
2060 /* Put all unmarked conses on free list */
2062 register struct cons_block
*cblk
;
2063 register int lim
= cons_block_index
;
2064 register int num_free
= 0, num_used
= 0;
2068 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
2071 for (i
= 0; i
< lim
; i
++)
2072 if (!XMARKBIT (cblk
->conses
[i
].car
))
2075 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
2076 cons_free_list
= &cblk
->conses
[i
];
2081 XUNMARK (cblk
->conses
[i
].car
);
2083 lim
= CONS_BLOCK_SIZE
;
2085 total_conses
= num_used
;
2086 total_free_conses
= num_free
;
2089 #ifdef LISP_FLOAT_TYPE
2090 /* Put all unmarked floats on free list */
2092 register struct float_block
*fblk
;
2093 register int lim
= float_block_index
;
2094 register int num_free
= 0, num_used
= 0;
2096 float_free_list
= 0;
2098 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2101 for (i
= 0; i
< lim
; i
++)
2102 if (!XMARKBIT (fblk
->floats
[i
].type
))
2105 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2106 float_free_list
= &fblk
->floats
[i
];
2111 XUNMARK (fblk
->floats
[i
].type
);
2113 lim
= FLOAT_BLOCK_SIZE
;
2115 total_floats
= num_used
;
2116 total_free_floats
= num_free
;
2118 #endif /* LISP_FLOAT_TYPE */
2120 #ifdef USE_TEXT_PROPERTIES
2121 /* Put all unmarked intervals on free list */
2123 register struct interval_block
*iblk
;
2124 register int lim
= interval_block_index
;
2125 register int num_free
= 0, num_used
= 0;
2127 interval_free_list
= 0;
2129 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2133 for (i
= 0; i
< lim
; i
++)
2135 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2137 iblk
->intervals
[i
].parent
= interval_free_list
;
2138 interval_free_list
= &iblk
->intervals
[i
];
2144 XUNMARK (iblk
->intervals
[i
].plist
);
2147 lim
= INTERVAL_BLOCK_SIZE
;
2149 total_intervals
= num_used
;
2150 total_free_intervals
= num_free
;
2152 #endif /* USE_TEXT_PROPERTIES */
2154 /* Put all unmarked symbols on free list */
2156 register struct symbol_block
*sblk
;
2157 register int lim
= symbol_block_index
;
2158 register int num_free
= 0, num_used
= 0;
2160 symbol_free_list
= 0;
2162 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2165 for (i
= 0; i
< lim
; i
++)
2166 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2168 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2169 symbol_free_list
= &sblk
->symbols
[i
];
2175 sblk
->symbols
[i
].name
2176 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2177 XUNMARK (sblk
->symbols
[i
].plist
);
2179 lim
= SYMBOL_BLOCK_SIZE
;
2181 total_symbols
= num_used
;
2182 total_free_symbols
= num_free
;
2186 /* Put all unmarked markers on free list.
2187 Unchain each one first from the buffer it points into,
2188 but only if it's a real marker. */
2190 register struct marker_block
*mblk
;
2191 register int lim
= marker_block_index
;
2192 register int num_free
= 0, num_used
= 0;
2194 marker_free_list
= 0;
2196 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2199 EMACS_INT already_free
= -1;
2201 for (i
= 0; i
< lim
; i
++)
2203 Lisp_Object
*markword
;
2204 switch (mblk
->markers
[i
].u_marker
.type
)
2206 case Lisp_Misc_Marker
:
2207 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2209 case Lisp_Misc_Buffer_Local_Value
:
2210 case Lisp_Misc_Some_Buffer_Local_Value
:
2211 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2213 case Lisp_Misc_Overlay
:
2214 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2216 case Lisp_Misc_Free
:
2217 /* If the object was already free, keep it
2218 on the free list. */
2219 markword
= &already_free
;
2225 if (markword
&& !XMARKBIT (*markword
))
2228 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2230 /* tem1 avoids Sun compiler bug */
2231 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2232 XSETMARKER (tem
, tem1
);
2233 unchain_marker (tem
);
2235 /* Set the type of the freed object to Lisp_Misc_Free.
2236 We could leave the type alone, since nobody checks it,
2237 but this might catch bugs faster. */
2238 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2239 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2240 marker_free_list
= &mblk
->markers
[i
];
2247 XUNMARK (*markword
);
2250 lim
= MARKER_BLOCK_SIZE
;
2253 total_markers
= num_used
;
2254 total_free_markers
= num_free
;
2257 /* Free all unmarked buffers */
2259 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2262 if (!XMARKBIT (buffer
->name
))
2265 prev
->next
= buffer
->next
;
2267 all_buffers
= buffer
->next
;
2268 next
= buffer
->next
;
2274 XUNMARK (buffer
->name
);
2275 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2278 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2279 for purposes of marking and relocation.
2280 Turn them back into C pointers now. */
2281 buffer
->upcase_table
2282 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2283 buffer
->downcase_table
2284 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2286 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2287 buffer
->folding_sort_table
2288 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2291 prev
= buffer
, buffer
= buffer
->next
;
2295 #endif /* standalone */
2297 /* Free all unmarked vectors */
2299 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2300 total_vector_size
= 0;
2303 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2306 prev
->next
= vector
->next
;
2308 all_vectors
= vector
->next
;
2309 next
= vector
->next
;
2315 vector
->size
&= ~ARRAY_MARK_FLAG
;
2316 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2317 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2319 total_vector_size
+= vector
->size
;
2320 prev
= vector
, vector
= vector
->next
;
2324 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2326 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2327 struct Lisp_String
*s
;
2331 s
= (struct Lisp_String
*) &sb
->chars
[0];
2332 if (s
->size
& ARRAY_MARK_FLAG
)
2334 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2335 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2336 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2337 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2338 prev
= sb
, sb
= sb
->next
;
2343 prev
->next
= sb
->next
;
2345 large_string_blocks
= sb
->next
;
2354 /* Compactify strings, relocate references, and free empty string blocks. */
2359 /* String block of old strings we are scanning. */
2360 register struct string_block
*from_sb
;
2361 /* A preceding string block (or maybe the same one)
2362 where we are copying the still-live strings to. */
2363 register struct string_block
*to_sb
;
2367 to_sb
= first_string_block
;
2370 /* Scan each existing string block sequentially, string by string. */
2371 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2374 /* POS is the index of the next string in the block. */
2375 while (pos
< from_sb
->pos
)
2377 register struct Lisp_String
*nextstr
2378 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2380 register struct Lisp_String
*newaddr
;
2381 register EMACS_INT size
= nextstr
->size
;
2383 /* NEXTSTR is the old address of the next string.
2384 Just skip it if it isn't marked. */
2385 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2387 /* It is marked, so its size field is really a chain of refs.
2388 Find the end of the chain, where the actual size lives. */
2389 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2391 if (size
& DONT_COPY_FLAG
)
2392 size
^= MARKBIT
| DONT_COPY_FLAG
;
2393 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2396 total_string_size
+= size
;
2398 /* If it won't fit in TO_SB, close it out,
2399 and move to the next sb. Keep doing so until
2400 TO_SB reaches a large enough, empty enough string block.
2401 We know that TO_SB cannot advance past FROM_SB here
2402 since FROM_SB is large enough to contain this string.
2403 Any string blocks skipped here
2404 will be patched out and freed later. */
2405 while (to_pos
+ STRING_FULLSIZE (size
)
2406 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2408 to_sb
->pos
= to_pos
;
2409 to_sb
= to_sb
->next
;
2412 /* Compute new address of this string
2413 and update TO_POS for the space being used. */
2414 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2415 to_pos
+= STRING_FULLSIZE (size
);
2417 /* Copy the string itself to the new place. */
2418 if (nextstr
!= newaddr
)
2419 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2420 + INTERVAL_PTR_SIZE
);
2422 /* Go through NEXTSTR's chain of references
2423 and make each slot in the chain point to
2424 the new address of this string. */
2425 size
= newaddr
->size
;
2426 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2428 register Lisp_Object
*objptr
;
2429 if (size
& DONT_COPY_FLAG
)
2430 size
^= MARKBIT
| DONT_COPY_FLAG
;
2431 objptr
= (Lisp_Object
*)size
;
2433 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2434 if (XMARKBIT (*objptr
))
2436 XSETSTRING (*objptr
, newaddr
);
2440 XSETSTRING (*objptr
, newaddr
);
2442 /* Store the actual size in the size field. */
2443 newaddr
->size
= size
;
2445 #ifdef USE_TEXT_PROPERTIES
2446 /* Now that the string has been relocated, rebalance its
2447 interval tree, and update the tree's parent pointer. */
2448 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2450 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2451 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2454 #endif /* USE_TEXT_PROPERTIES */
2456 pos
+= STRING_FULLSIZE (size
);
2460 /* Close out the last string block still used and free any that follow. */
2461 to_sb
->pos
= to_pos
;
2462 current_string_block
= to_sb
;
2464 from_sb
= to_sb
->next
;
2468 to_sb
= from_sb
->next
;
2473 /* Free any empty string blocks further back in the chain.
2474 This loop will never free first_string_block, but it is very
2475 unlikely that that one will become empty, so why bother checking? */
2477 from_sb
= first_string_block
;
2478 while (to_sb
= from_sb
->next
)
2480 if (to_sb
->pos
== 0)
2482 if (from_sb
->next
= to_sb
->next
)
2483 from_sb
->next
->prev
= from_sb
;
2491 /* Debugging aids. */
2493 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2494 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2495 This may be helpful in debugging Emacs's memory usage.\n\
2496 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2501 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2506 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2507 "Return a list of counters that measure how much consing there has been.\n\
2508 Each of these counters increments for a certain kind of object.\n\
2509 The counters wrap around from the largest positive integer to zero.\n\
2510 Garbage collection does not decrease them.\n\
2511 The elements of the value are as follows:\n\
2512 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2513 All are in units of 1 = one object consed\n\
2514 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2516 MISCS include overlays, markers, and some internal types.\n\
2517 Frames, windows, buffers, and subprocesses count as vectors\n\
2518 (but the contents of a buffer's text do not count here).")
2521 Lisp_Object lisp_cons_cells_consed
;
2522 Lisp_Object lisp_floats_consed
;
2523 Lisp_Object lisp_vector_cells_consed
;
2524 Lisp_Object lisp_symbols_consed
;
2525 Lisp_Object lisp_string_chars_consed
;
2526 Lisp_Object lisp_misc_objects_consed
;
2527 Lisp_Object lisp_intervals_consed
;
2529 XSETINT (lisp_cons_cells_consed
,
2530 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2531 XSETINT (lisp_floats_consed
,
2532 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2533 XSETINT (lisp_vector_cells_consed
,
2534 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2535 XSETINT (lisp_symbols_consed
,
2536 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2537 XSETINT (lisp_string_chars_consed
,
2538 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2539 XSETINT (lisp_misc_objects_consed
,
2540 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2541 XSETINT (lisp_intervals_consed
,
2542 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2544 return Fcons (lisp_cons_cells_consed
,
2545 Fcons (lisp_floats_consed
,
2546 Fcons (lisp_vector_cells_consed
,
2547 Fcons (lisp_symbols_consed
,
2548 Fcons (lisp_string_chars_consed
,
2549 Fcons (lisp_misc_objects_consed
,
2550 Fcons (lisp_intervals_consed
,
2554 /* Initialization */
2558 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2561 pure_size
= PURESIZE
;
2564 ignore_warnings
= 1;
2569 #ifdef LISP_FLOAT_TYPE
2571 #endif /* LISP_FLOAT_TYPE */
2575 malloc_hysteresis
= 32;
2577 malloc_hysteresis
= 0;
2580 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2582 ignore_warnings
= 0;
2585 consing_since_gc
= 0;
2586 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2587 #ifdef VIRT_ADDR_VARIES
2588 malloc_sbrk_unused
= 1<<22; /* A large number */
2589 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2590 #endif /* VIRT_ADDR_VARIES */
2601 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2602 "*Number of bytes of consing between garbage collections.\n\
2603 Garbage collection can happen automatically once this many bytes have been\n\
2604 allocated since the last garbage collection. All data types count.\n\n\
2605 Garbage collection happens automatically only when `eval' is called.\n\n\
2606 By binding this temporarily to a large number, you can effectively\n\
2607 prevent garbage collection during a part of the program.");
2609 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2610 "Number of bytes of sharable Lisp data allocated so far.");
2612 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2613 "Number of cons cells that have been consed so far.");
2615 DEFVAR_INT ("floats-consed", &floats_consed
,
2616 "Number of floats that have been consed so far.");
2618 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2619 "Number of vector cells that have been consed so far.");
2621 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2622 "Number of symbols that have been consed so far.");
2624 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2625 "Number of string characters that have been consed so far.");
2627 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2628 "Number of miscellaneous objects that have been consed so far.");
2630 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2631 "Number of intervals that have been consed so far.");
2634 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2635 "Number of bytes of unshared memory allocated in this session.");
2637 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2638 "Number of bytes of unshared memory remaining available in this session.");
2641 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2642 "Non-nil means loading Lisp code in order to dump an executable.\n\
2643 This means that certain objects should be allocated in shared (pure) space.");
2645 DEFVAR_INT ("undo-limit", &undo_limit
,
2646 "Keep no more undo information once it exceeds this size.\n\
2647 This limit is applied when garbage collection happens.\n\
2648 The size is counted as the number of bytes occupied,\n\
2649 which includes both saved text and other data.");
2652 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2653 "Don't keep more than this much size of undo information.\n\
2654 A command which pushes past this size is itself forgotten.\n\
2655 This limit is applied when garbage collection happens.\n\
2656 The size is counted as the number of bytes occupied,\n\
2657 which includes both saved text and other data.");
2658 undo_strong_limit
= 30000;
2660 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2661 "Non-nil means display messages at start and end of garbage collection.");
2662 garbage_collection_messages
= 0;
2664 /* We build this in advance because if we wait until we need it, we might
2665 not be able to allocate the memory to hold it. */
2667 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2668 staticpro (&memory_signal_data
);
2670 staticpro (&Qgc_cons_threshold
);
2671 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2673 staticpro (&Qchar_table_extra_slots
);
2674 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2679 defsubr (&Smake_byte_code
);
2680 defsubr (&Smake_list
);
2681 defsubr (&Smake_vector
);
2682 defsubr (&Smake_char_table
);
2683 defsubr (&Smake_string
);
2684 defsubr (&Smake_bool_vector
);
2685 defsubr (&Smake_symbol
);
2686 defsubr (&Smake_marker
);
2687 defsubr (&Spurecopy
);
2688 defsubr (&Sgarbage_collect
);
2689 defsubr (&Smemory_limit
);
2690 defsubr (&Smemory_use_counts
);