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 #define max(A,B) ((A) > (B) ? (A) : (B))
52 #define min(A,B) ((A) < (B) ? (A) : (B))
54 /* Macro to verify that storage intended for Lisp objects is not
55 out of range to fit in the space for a pointer.
56 ADDRESS is the start of the block, and SIZE
57 is the amount of space within which objects can start. */
58 #define VALIDATE_LISP_STORAGE(address, size) \
62 XSETCONS (val, (char *) address + size); \
63 if ((char *) XCONS (val) != (char *) address + size) \
70 /* Value of _bytes_used, when spare_memory was freed. */
71 static __malloc_size_t bytes_used_when_full
;
73 /* Number of bytes of consing done since the last gc */
76 /* Count the amount of consing of various sorts of space. */
77 int cons_cells_consed
;
79 int vector_cells_consed
;
81 int string_chars_consed
;
82 int misc_objects_consed
;
85 /* Number of bytes of consing since gc before another gc should be done. */
86 int gc_cons_threshold
;
88 /* Nonzero during gc */
91 /* Nonzero means display messages at beginning and end of GC. */
92 int garbage_collection_messages
;
94 #ifndef VIRT_ADDR_VARIES
96 #endif /* VIRT_ADDR_VARIES */
99 #ifndef VIRT_ADDR_VARIES
101 #endif /* VIRT_ADDR_VARIES */
102 int malloc_sbrk_unused
;
104 /* Two limits controlling how much undo information to keep. */
106 int undo_strong_limit
;
108 /* Points to memory space allocated as "spare",
109 to be freed if we run out of memory. */
110 static char *spare_memory
;
112 /* Amount of spare memory to keep in reserve. */
113 #define SPARE_MEMORY (1 << 14)
115 /* Number of extra blocks malloc should get when it needs more core. */
116 static int malloc_hysteresis
;
118 /* Nonzero when malloc is called for allocating Lisp object space. */
119 int allocating_for_lisp
;
121 /* Non-nil means defun should do purecopy on the function definition */
122 Lisp_Object Vpurify_flag
;
125 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
126 #define PUREBEG (char *) pure
128 #define pure PURE_SEG_BITS /* Use shared memory segment */
129 #define PUREBEG (char *)PURE_SEG_BITS
131 /* This variable is used only by the XPNTR macro when HAVE_SHM is
132 defined. If we used the PURESIZE macro directly there, that would
133 make most of emacs dependent on puresize.h, which we don't want -
134 you should be able to change that without too much recompilation.
135 So map_in_data initializes pure_size, and the dependencies work
138 #endif /* not HAVE_SHM */
140 /* Index in pure at which next pure object will be allocated. */
143 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
144 char *pending_malloc_warning
;
146 /* Pre-computed signal argument for use when memory is exhausted. */
147 Lisp_Object memory_signal_data
;
149 /* Maximum amount of C stack to save when a GC happens. */
151 #ifndef MAX_SAVE_STACK
152 #define MAX_SAVE_STACK 16000
155 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
156 pointer to a Lisp_Object, when that pointer is viewed as an integer.
157 (On most machines, pointers are even, so we can use the low bit.
158 Word-addressable architectures may need to override this in the m-file.)
159 When linking references to small strings through the size field, we
160 use this slot to hold the bit that would otherwise be interpreted as
162 #ifndef DONT_COPY_FLAG
163 #define DONT_COPY_FLAG 1
164 #endif /* no DONT_COPY_FLAG */
166 /* Buffer in which we save a copy of the C stack at each GC. */
171 /* Non-zero means ignore malloc warnings. Set during initialization. */
174 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
176 static void mark_object (), mark_buffer (), mark_kboards ();
177 static void clear_marks (), gc_sweep ();
178 static void compact_strings ();
180 /* Versions of malloc and realloc that print warnings as memory gets full. */
183 malloc_warning_1 (str
)
186 Fprinc (str
, Vstandard_output
);
187 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
188 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
189 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
193 /* malloc calls this if it finds we are near exhausting storage */
197 pending_malloc_warning
= str
;
200 display_malloc_warning ()
202 register Lisp_Object val
;
204 val
= build_string (pending_malloc_warning
);
205 pending_malloc_warning
= 0;
206 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
209 /* Called if malloc returns zero */
213 #ifndef SYSTEM_MALLOC
214 bytes_used_when_full
= _bytes_used
;
217 /* The first time we get here, free the spare memory. */
224 /* This used to call error, but if we've run out of memory, we could get
225 infinite recursion trying to build the string. */
227 Fsignal (Qerror
, memory_signal_data
);
230 /* Called if we can't allocate relocatable space for a buffer. */
233 buffer_memory_full ()
235 /* If buffers use the relocating allocator,
236 no need to free spare_memory, because we may have plenty of malloc
237 space left that we could get, and if we don't, the malloc that fails
238 will itself cause spare_memory to be freed.
239 If buffers don't use the relocating allocator,
240 treat this like any other failing malloc. */
246 /* This used to call error, but if we've run out of memory, we could get
247 infinite recursion trying to build the string. */
249 Fsignal (Qerror
, memory_signal_data
);
252 /* like malloc routines but check for no memory and block interrupt input. */
261 val
= (long *) malloc (size
);
264 if (!val
&& size
) memory_full ();
269 xrealloc (block
, size
)
276 /* We must call malloc explicitly when BLOCK is 0, since some
277 reallocs don't do this. */
279 val
= (long *) malloc (size
);
281 val
= (long *) realloc (block
, size
);
284 if (!val
&& size
) memory_full ();
298 /* Arranging to disable input signals while we're in malloc.
300 This only works with GNU malloc. To help out systems which can't
301 use GNU malloc, all the calls to malloc, realloc, and free
302 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
303 pairs; unfortunately, we have no idea what C library functions
304 might call malloc, so we can't really protect them unless you're
305 using GNU malloc. Fortunately, most of the major operating can use
308 #ifndef SYSTEM_MALLOC
309 extern void * (*__malloc_hook
) ();
310 static void * (*old_malloc_hook
) ();
311 extern void * (*__realloc_hook
) ();
312 static void * (*old_realloc_hook
) ();
313 extern void (*__free_hook
) ();
314 static void (*old_free_hook
) ();
316 /* This function is used as the hook for free to call. */
319 emacs_blocked_free (ptr
)
323 __free_hook
= old_free_hook
;
325 /* If we released our reserve (due to running out of memory),
326 and we have a fair amount free once again,
327 try to set aside another reserve in case we run out once more. */
328 if (spare_memory
== 0
329 /* Verify there is enough space that even with the malloc
330 hysteresis this call won't run out again.
331 The code here is correct as long as SPARE_MEMORY
332 is substantially larger than the block size malloc uses. */
333 && (bytes_used_when_full
334 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
335 spare_memory
= (char *) malloc (SPARE_MEMORY
);
337 __free_hook
= emacs_blocked_free
;
341 /* If we released our reserve (due to running out of memory),
342 and we have a fair amount free once again,
343 try to set aside another reserve in case we run out once more.
345 This is called when a relocatable block is freed in ralloc.c. */
348 refill_memory_reserve ()
350 if (spare_memory
== 0)
351 spare_memory
= (char *) malloc (SPARE_MEMORY
);
354 /* This function is the malloc hook that Emacs uses. */
357 emacs_blocked_malloc (size
)
363 __malloc_hook
= old_malloc_hook
;
364 __malloc_extra_blocks
= malloc_hysteresis
;
365 value
= (void *) malloc (size
);
366 __malloc_hook
= emacs_blocked_malloc
;
373 emacs_blocked_realloc (ptr
, size
)
380 __realloc_hook
= old_realloc_hook
;
381 value
= (void *) realloc (ptr
, size
);
382 __realloc_hook
= emacs_blocked_realloc
;
389 uninterrupt_malloc ()
391 old_free_hook
= __free_hook
;
392 __free_hook
= emacs_blocked_free
;
394 old_malloc_hook
= __malloc_hook
;
395 __malloc_hook
= emacs_blocked_malloc
;
397 old_realloc_hook
= __realloc_hook
;
398 __realloc_hook
= emacs_blocked_realloc
;
402 /* Interval allocation. */
404 #ifdef USE_TEXT_PROPERTIES
405 #define INTERVAL_BLOCK_SIZE \
406 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
408 struct interval_block
410 struct interval_block
*next
;
411 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
414 struct interval_block
*interval_block
;
415 static int interval_block_index
;
417 INTERVAL interval_free_list
;
422 allocating_for_lisp
= 1;
424 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
425 allocating_for_lisp
= 0;
426 interval_block
->next
= 0;
427 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
428 interval_block_index
= 0;
429 interval_free_list
= 0;
432 #define INIT_INTERVALS init_intervals ()
439 if (interval_free_list
)
441 val
= interval_free_list
;
442 interval_free_list
= interval_free_list
->parent
;
446 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
448 register struct interval_block
*newi
;
450 allocating_for_lisp
= 1;
451 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
453 allocating_for_lisp
= 0;
454 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
455 newi
->next
= interval_block
;
456 interval_block
= newi
;
457 interval_block_index
= 0;
459 val
= &interval_block
->intervals
[interval_block_index
++];
461 consing_since_gc
+= sizeof (struct interval
);
463 RESET_INTERVAL (val
);
467 static int total_free_intervals
, total_intervals
;
469 /* Mark the pointers of one interval. */
472 mark_interval (i
, dummy
)
476 if (XMARKBIT (i
->plist
))
478 mark_object (&i
->plist
);
483 mark_interval_tree (tree
)
484 register INTERVAL tree
;
486 /* No need to test if this tree has been marked already; this
487 function is always called through the MARK_INTERVAL_TREE macro,
488 which takes care of that. */
490 /* XMARK expands to an assignment; the LHS of an assignment can't be
492 XMARK (* (Lisp_Object
*) &tree
->parent
);
494 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
497 #define MARK_INTERVAL_TREE(i) \
499 if (!NULL_INTERVAL_P (i) \
500 && ! XMARKBIT ((Lisp_Object) i->parent)) \
501 mark_interval_tree (i); \
504 /* The oddity in the call to XUNMARK is necessary because XUNMARK
505 expands to an assignment to its argument, and most C compilers don't
506 support casts on the left operand of `='. */
507 #define UNMARK_BALANCE_INTERVALS(i) \
509 if (! NULL_INTERVAL_P (i)) \
511 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
512 (i) = balance_intervals (i); \
516 #else /* no interval use */
518 #define INIT_INTERVALS
520 #define UNMARK_BALANCE_INTERVALS(i)
521 #define MARK_INTERVAL_TREE(i)
523 #endif /* no interval use */
525 /* Floating point allocation. */
527 #ifdef LISP_FLOAT_TYPE
528 /* Allocation of float cells, just like conses */
529 /* We store float cells inside of float_blocks, allocating a new
530 float_block with malloc whenever necessary. Float cells reclaimed by
531 GC are put on a free list to be reallocated before allocating
532 any new float cells from the latest float_block.
534 Each float_block is just under 1020 bytes long,
535 since malloc really allocates in units of powers of two
536 and uses 4 bytes for its own overhead. */
538 #define FLOAT_BLOCK_SIZE \
539 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
543 struct float_block
*next
;
544 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
547 struct float_block
*float_block
;
548 int float_block_index
;
550 struct Lisp_Float
*float_free_list
;
555 allocating_for_lisp
= 1;
556 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
557 allocating_for_lisp
= 0;
558 float_block
->next
= 0;
559 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
560 float_block_index
= 0;
564 /* Explicitly free a float cell. */
566 struct Lisp_Float
*ptr
;
568 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
569 float_free_list
= ptr
;
573 make_float (float_value
)
576 register Lisp_Object val
;
580 XSETFLOAT (val
, float_free_list
);
581 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
585 if (float_block_index
== FLOAT_BLOCK_SIZE
)
587 register struct float_block
*new;
589 allocating_for_lisp
= 1;
590 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
591 allocating_for_lisp
= 0;
592 VALIDATE_LISP_STORAGE (new, sizeof *new);
593 new->next
= float_block
;
595 float_block_index
= 0;
597 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
599 XFLOAT (val
)->data
= float_value
;
600 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
601 consing_since_gc
+= sizeof (struct Lisp_Float
);
606 #endif /* LISP_FLOAT_TYPE */
608 /* Allocation of cons cells */
609 /* We store cons cells inside of cons_blocks, allocating a new
610 cons_block with malloc whenever necessary. Cons cells reclaimed by
611 GC are put on a free list to be reallocated before allocating
612 any new cons cells from the latest cons_block.
614 Each cons_block is just under 1020 bytes long,
615 since malloc really allocates in units of powers of two
616 and uses 4 bytes for its own overhead. */
618 #define CONS_BLOCK_SIZE \
619 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
623 struct cons_block
*next
;
624 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
627 struct cons_block
*cons_block
;
628 int cons_block_index
;
630 struct Lisp_Cons
*cons_free_list
;
635 allocating_for_lisp
= 1;
636 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
637 allocating_for_lisp
= 0;
638 cons_block
->next
= 0;
639 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
640 cons_block_index
= 0;
644 /* Explicitly free a cons cell. */
646 struct Lisp_Cons
*ptr
;
648 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
649 cons_free_list
= ptr
;
652 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
653 "Create a new cons, give it CAR and CDR as components, and return it.")
655 Lisp_Object car
, cdr
;
657 register Lisp_Object val
;
661 XSETCONS (val
, cons_free_list
);
662 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
666 if (cons_block_index
== CONS_BLOCK_SIZE
)
668 register struct cons_block
*new;
669 allocating_for_lisp
= 1;
670 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
671 allocating_for_lisp
= 0;
672 VALIDATE_LISP_STORAGE (new, sizeof *new);
673 new->next
= cons_block
;
675 cons_block_index
= 0;
677 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
679 XCONS (val
)->car
= car
;
680 XCONS (val
)->cdr
= cdr
;
681 consing_since_gc
+= sizeof (struct Lisp_Cons
);
686 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
687 "Return a newly created list with specified arguments as elements.\n\
688 Any number of arguments, even zero arguments, are allowed.")
691 register Lisp_Object
*args
;
693 register Lisp_Object val
;
699 val
= Fcons (args
[nargs
], val
);
704 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
705 "Return a newly created list of length LENGTH, with each element being INIT.")
707 register Lisp_Object length
, init
;
709 register Lisp_Object val
;
712 CHECK_NATNUM (length
, 0);
713 size
= XFASTINT (length
);
717 val
= Fcons (init
, val
);
721 /* Allocation of vectors */
723 struct Lisp_Vector
*all_vectors
;
726 allocate_vectorlike (len
)
729 struct Lisp_Vector
*p
;
731 allocating_for_lisp
= 1;
732 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
733 + (len
- 1) * sizeof (Lisp_Object
));
734 allocating_for_lisp
= 0;
735 VALIDATE_LISP_STORAGE (p
, 0);
736 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
737 + (len
- 1) * sizeof (Lisp_Object
));
738 vector_cells_consed
+= len
;
740 p
->next
= all_vectors
;
745 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
746 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
747 See also the function `vector'.")
749 register Lisp_Object length
, init
;
752 register EMACS_INT sizei
;
754 register struct Lisp_Vector
*p
;
756 CHECK_NATNUM (length
, 0);
757 sizei
= XFASTINT (length
);
759 p
= allocate_vectorlike (sizei
);
761 for (index
= 0; index
< sizei
; index
++)
762 p
->contents
[index
] = init
;
764 XSETVECTOR (vector
, p
);
768 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
769 "Return a newly created char-table, with purpose PURPOSE.\n\
770 Each element is initialized to INIT, which defaults to nil.\n\
771 PURPOSE should be a symbol which has a `char-table-extra-slot' property.\n\
772 The property's value should be an integer between 0 and 10.")
774 register Lisp_Object purpose
, init
;
778 CHECK_SYMBOL (purpose
, 1);
779 n
= Fget (purpose
, Qchar_table_extra_slots
);
781 if (XINT (n
) < 0 || XINT (n
) > 10)
782 args_out_of_range (n
, Qnil
);
783 /* Add 2 to the size for the defalt and parent slots. */
784 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
786 XCHAR_TABLE (vector
)->parent
= Qnil
;
787 XCHAR_TABLE (vector
)->purpose
= purpose
;
788 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
792 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
793 "Return a newly created vector with specified arguments as elements.\n\
794 Any number of arguments, even zero arguments, are allowed.")
799 register Lisp_Object len
, val
;
801 register struct Lisp_Vector
*p
;
803 XSETFASTINT (len
, nargs
);
804 val
= Fmake_vector (len
, Qnil
);
806 for (index
= 0; index
< nargs
; index
++)
807 p
->contents
[index
] = args
[index
];
811 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
812 "Create a byte-code object with specified arguments as elements.\n\
813 The arguments should be the arglist, bytecode-string, constant vector,\n\
814 stack size, (optional) doc string, and (optional) interactive spec.\n\
815 The first four arguments are required; at most six have any\n\
821 register Lisp_Object len
, val
;
823 register struct Lisp_Vector
*p
;
825 XSETFASTINT (len
, nargs
);
826 if (!NILP (Vpurify_flag
))
827 val
= make_pure_vector (len
);
829 val
= Fmake_vector (len
, Qnil
);
831 for (index
= 0; index
< nargs
; index
++)
833 if (!NILP (Vpurify_flag
))
834 args
[index
] = Fpurecopy (args
[index
]);
835 p
->contents
[index
] = args
[index
];
837 XSETCOMPILED (val
, val
);
841 /* Allocation of symbols.
842 Just like allocation of conses!
844 Each symbol_block is just under 1020 bytes long,
845 since malloc really allocates in units of powers of two
846 and uses 4 bytes for its own overhead. */
848 #define SYMBOL_BLOCK_SIZE \
849 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
853 struct symbol_block
*next
;
854 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
857 struct symbol_block
*symbol_block
;
858 int symbol_block_index
;
860 struct Lisp_Symbol
*symbol_free_list
;
865 allocating_for_lisp
= 1;
866 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
867 allocating_for_lisp
= 0;
868 symbol_block
->next
= 0;
869 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
870 symbol_block_index
= 0;
871 symbol_free_list
= 0;
874 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
875 "Return a newly allocated uninterned symbol whose name is NAME.\n\
876 Its value and function definition are void, and its property list is nil.")
880 register Lisp_Object val
;
881 register struct Lisp_Symbol
*p
;
883 CHECK_STRING (name
, 0);
885 if (symbol_free_list
)
887 XSETSYMBOL (val
, symbol_free_list
);
888 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
892 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
894 struct symbol_block
*new;
895 allocating_for_lisp
= 1;
896 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
897 allocating_for_lisp
= 0;
898 VALIDATE_LISP_STORAGE (new, sizeof *new);
899 new->next
= symbol_block
;
901 symbol_block_index
= 0;
903 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
906 p
->name
= XSTRING (name
);
909 p
->function
= Qunbound
;
911 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
916 /* Allocation of markers and other objects that share that structure.
917 Works like allocation of conses. */
919 #define MARKER_BLOCK_SIZE \
920 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
924 struct marker_block
*next
;
925 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
928 struct marker_block
*marker_block
;
929 int marker_block_index
;
931 union Lisp_Misc
*marker_free_list
;
936 allocating_for_lisp
= 1;
937 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
938 allocating_for_lisp
= 0;
939 marker_block
->next
= 0;
940 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
941 marker_block_index
= 0;
942 marker_free_list
= 0;
945 /* Return a newly allocated Lisp_Misc object, with no substructure. */
951 if (marker_free_list
)
953 XSETMISC (val
, marker_free_list
);
954 marker_free_list
= marker_free_list
->u_free
.chain
;
958 if (marker_block_index
== MARKER_BLOCK_SIZE
)
960 struct marker_block
*new;
961 allocating_for_lisp
= 1;
962 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
963 allocating_for_lisp
= 0;
964 VALIDATE_LISP_STORAGE (new, sizeof *new);
965 new->next
= marker_block
;
967 marker_block_index
= 0;
969 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
971 consing_since_gc
+= sizeof (union Lisp_Misc
);
972 misc_objects_consed
++;
976 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
977 "Return a newly allocated marker which does not point at any place.")
980 register Lisp_Object val
;
981 register struct Lisp_Marker
*p
;
983 val
= allocate_misc ();
984 XMISCTYPE (val
) = Lisp_Misc_Marker
;
989 p
->insertion_type
= 0;
993 /* Allocation of strings */
995 /* Strings reside inside of string_blocks. The entire data of the string,
996 both the size and the contents, live in part of the `chars' component of a string_block.
997 The `pos' component is the index within `chars' of the first free byte.
999 first_string_block points to the first string_block ever allocated.
1000 Each block points to the next one with its `next' field.
1001 The `prev' fields chain in reverse order.
1002 The last one allocated is the one currently being filled.
1003 current_string_block points to it.
1005 The string_blocks that hold individual large strings
1006 go in a separate chain, started by large_string_blocks. */
1009 /* String blocks contain this many useful bytes.
1010 8188 is power of 2, minus 4 for malloc overhead. */
1011 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1013 /* A string bigger than this gets its own specially-made string block
1014 if it doesn't fit in the current one. */
1015 #define STRING_BLOCK_OUTSIZE 1024
1017 struct string_block_head
1019 struct string_block
*next
, *prev
;
1025 struct string_block
*next
, *prev
;
1027 char chars
[STRING_BLOCK_SIZE
];
1030 /* This points to the string block we are now allocating strings. */
1032 struct string_block
*current_string_block
;
1034 /* This points to the oldest string block, the one that starts the chain. */
1036 struct string_block
*first_string_block
;
1038 /* Last string block in chain of those made for individual large strings. */
1040 struct string_block
*large_string_blocks
;
1042 /* If SIZE is the length of a string, this returns how many bytes
1043 the string occupies in a string_block (including padding). */
1045 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1047 #define PAD (sizeof (EMACS_INT))
1050 #define STRING_FULLSIZE(SIZE) \
1051 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1057 allocating_for_lisp
= 1;
1058 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1059 allocating_for_lisp
= 0;
1060 first_string_block
= current_string_block
;
1061 consing_since_gc
+= sizeof (struct string_block
);
1062 current_string_block
->next
= 0;
1063 current_string_block
->prev
= 0;
1064 current_string_block
->pos
= 0;
1065 large_string_blocks
= 0;
1068 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1069 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1070 Both LENGTH and INIT must be numbers.")
1072 Lisp_Object length
, init
;
1074 register Lisp_Object val
;
1075 register unsigned char *p
, *end
, c
;
1077 CHECK_NATNUM (length
, 0);
1078 CHECK_NUMBER (init
, 1);
1079 val
= make_uninit_string (XFASTINT (length
));
1081 p
= XSTRING (val
)->data
;
1082 end
= p
+ XSTRING (val
)->size
;
1089 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1090 "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\
1091 Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.")
1093 Lisp_Object length
, init
;
1095 register Lisp_Object val
;
1096 struct Lisp_Bool_Vector
*p
;
1098 int length_in_chars
, length_in_elts
, bits_per_value
;
1100 CHECK_NATNUM (length
, 0);
1102 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1104 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1105 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1107 val
= Fmake_vector (make_number (length_in_elts
), Qnil
);
1108 p
= XBOOL_VECTOR (val
);
1109 /* Get rid of any bits that would cause confusion. */
1111 XSETBOOL_VECTOR (val
, p
);
1112 p
->size
= XFASTINT (length
);
1114 real_init
= (NILP (init
) ? 0 : -1);
1115 for (i
= 0; i
< length_in_chars
; i
++)
1116 p
->data
[i
] = real_init
;
1122 make_string (contents
, length
)
1126 register Lisp_Object val
;
1127 val
= make_uninit_string (length
);
1128 bcopy (contents
, XSTRING (val
)->data
, length
);
1136 return make_string (str
, strlen (str
));
1140 make_uninit_string (length
)
1143 register Lisp_Object val
;
1144 register int fullsize
= STRING_FULLSIZE (length
);
1146 if (length
< 0) abort ();
1148 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1149 /* This string can fit in the current string block */
1152 ((struct Lisp_String
*)
1153 (current_string_block
->chars
+ current_string_block
->pos
)));
1154 current_string_block
->pos
+= fullsize
;
1156 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1157 /* This string gets its own string block */
1159 register struct string_block
*new;
1160 allocating_for_lisp
= 1;
1161 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1162 allocating_for_lisp
= 0;
1163 VALIDATE_LISP_STORAGE (new, 0);
1164 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1165 new->pos
= fullsize
;
1166 new->next
= large_string_blocks
;
1167 large_string_blocks
= new;
1169 ((struct Lisp_String
*)
1170 ((struct string_block_head
*)new + 1)));
1173 /* Make a new current string block and start it off with this string */
1175 register struct string_block
*new;
1176 allocating_for_lisp
= 1;
1177 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1178 allocating_for_lisp
= 0;
1179 VALIDATE_LISP_STORAGE (new, sizeof *new);
1180 consing_since_gc
+= sizeof (struct string_block
);
1181 current_string_block
->next
= new;
1182 new->prev
= current_string_block
;
1184 current_string_block
= new;
1185 new->pos
= fullsize
;
1187 (struct Lisp_String
*) current_string_block
->chars
);
1190 string_chars_consed
+= fullsize
;
1191 XSTRING (val
)->size
= length
;
1192 XSTRING (val
)->data
[length
] = 0;
1193 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1198 /* Return a newly created vector or string with specified arguments as
1199 elements. If all the arguments are characters that can fit
1200 in a string of events, make a string; otherwise, make a vector.
1202 Any number of arguments, even zero arguments, are allowed. */
1205 make_event_array (nargs
, args
)
1211 for (i
= 0; i
< nargs
; i
++)
1212 /* The things that fit in a string
1213 are characters that are in 0...127,
1214 after discarding the meta bit and all the bits above it. */
1215 if (!INTEGERP (args
[i
])
1216 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1217 return Fvector (nargs
, args
);
1219 /* Since the loop exited, we know that all the things in it are
1220 characters, so we can make a string. */
1224 result
= Fmake_string (nargs
, make_number (0));
1225 for (i
= 0; i
< nargs
; i
++)
1227 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1228 /* Move the meta bit to the right place for a string char. */
1229 if (XINT (args
[i
]) & CHAR_META
)
1230 XSTRING (result
)->data
[i
] |= 0x80;
1237 /* Pure storage management. */
1239 /* Must get an error if pure storage is full,
1240 since if it cannot hold a large string
1241 it may be able to hold conses that point to that string;
1242 then the string is not protected from gc. */
1245 make_pure_string (data
, length
)
1249 register Lisp_Object
new;
1250 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1252 if (pureptr
+ size
> PURESIZE
)
1253 error ("Pure Lisp storage exhausted");
1254 XSETSTRING (new, PUREBEG
+ pureptr
);
1255 XSTRING (new)->size
= length
;
1256 bcopy (data
, XSTRING (new)->data
, length
);
1257 XSTRING (new)->data
[length
] = 0;
1259 /* We must give strings in pure storage some kind of interval. So we
1260 give them a null one. */
1261 #if defined (USE_TEXT_PROPERTIES)
1262 XSTRING (new)->intervals
= NULL_INTERVAL
;
1264 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1265 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1270 pure_cons (car
, cdr
)
1271 Lisp_Object car
, cdr
;
1273 register Lisp_Object
new;
1275 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1276 error ("Pure Lisp storage exhausted");
1277 XSETCONS (new, PUREBEG
+ pureptr
);
1278 pureptr
+= sizeof (struct Lisp_Cons
);
1279 XCONS (new)->car
= Fpurecopy (car
);
1280 XCONS (new)->cdr
= Fpurecopy (cdr
);
1284 #ifdef LISP_FLOAT_TYPE
1287 make_pure_float (num
)
1290 register Lisp_Object
new;
1292 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1293 (double) boundary. Some architectures (like the sparc) require
1294 this, and I suspect that floats are rare enough that it's no
1295 tragedy for those that do. */
1298 char *p
= PUREBEG
+ pureptr
;
1302 alignment
= __alignof (struct Lisp_Float
);
1304 alignment
= sizeof (struct Lisp_Float
);
1307 alignment
= sizeof (struct Lisp_Float
);
1309 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1310 pureptr
= p
- PUREBEG
;
1313 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1314 error ("Pure Lisp storage exhausted");
1315 XSETFLOAT (new, PUREBEG
+ pureptr
);
1316 pureptr
+= sizeof (struct Lisp_Float
);
1317 XFLOAT (new)->data
= num
;
1318 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1322 #endif /* LISP_FLOAT_TYPE */
1325 make_pure_vector (len
)
1328 register Lisp_Object
new;
1329 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1331 if (pureptr
+ size
> PURESIZE
)
1332 error ("Pure Lisp storage exhausted");
1334 XSETVECTOR (new, PUREBEG
+ pureptr
);
1336 XVECTOR (new)->size
= len
;
1340 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1341 "Make a copy of OBJECT in pure storage.\n\
1342 Recursively copies contents of vectors and cons cells.\n\
1343 Does not copy symbols.")
1345 register Lisp_Object obj
;
1347 if (NILP (Vpurify_flag
))
1350 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1351 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1355 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1356 #ifdef LISP_FLOAT_TYPE
1357 else if (FLOATP (obj
))
1358 return make_pure_float (XFLOAT (obj
)->data
);
1359 #endif /* LISP_FLOAT_TYPE */
1360 else if (STRINGP (obj
))
1361 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1362 else if (COMPILEDP (obj
) || VECTORP (obj
))
1364 register struct Lisp_Vector
*vec
;
1365 register int i
, size
;
1367 size
= XVECTOR (obj
)->size
;
1368 if (size
& PSEUDOVECTOR_FLAG
)
1369 size
&= PSEUDOVECTOR_SIZE_MASK
;
1370 vec
= XVECTOR (make_pure_vector (size
));
1371 for (i
= 0; i
< size
; i
++)
1372 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1373 if (COMPILEDP (obj
))
1374 XSETCOMPILED (obj
, vec
);
1376 XSETVECTOR (obj
, vec
);
1379 else if (MARKERP (obj
))
1380 error ("Attempt to copy a marker to pure storage");
1385 /* Recording what needs to be marked for gc. */
1387 struct gcpro
*gcprolist
;
1389 #define NSTATICS 768
1391 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1395 /* Put an entry in staticvec, pointing at the variable whose address is given */
1398 staticpro (varaddress
)
1399 Lisp_Object
*varaddress
;
1401 staticvec
[staticidx
++] = varaddress
;
1402 if (staticidx
>= NSTATICS
)
1410 struct catchtag
*next
;
1411 /* jmp_buf jmp; /* We don't need this for GC purposes */
1416 struct backtrace
*next
;
1417 Lisp_Object
*function
;
1418 Lisp_Object
*args
; /* Points to vector of args. */
1419 int nargs
; /* length of vector */
1420 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1424 /* Garbage collection! */
1426 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1427 int total_free_conses
, total_free_markers
, total_free_symbols
;
1428 #ifdef LISP_FLOAT_TYPE
1429 int total_free_floats
, total_floats
;
1430 #endif /* LISP_FLOAT_TYPE */
1432 /* Temporarily prevent garbage collection. */
1435 inhibit_garbage_collection ()
1437 int count
= specpdl_ptr
- specpdl
;
1439 int nbits
= min (VALBITS
, BITS_PER_INT
);
1441 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1443 specbind (Qgc_cons_threshold
, number
);
1448 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1449 "Reclaim storage for Lisp objects no longer needed.\n\
1450 Returns info on amount of space in use:\n\
1451 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1452 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1453 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1454 Garbage collection happens automatically if you cons more than\n\
1455 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1458 register struct gcpro
*tail
;
1459 register struct specbinding
*bind
;
1460 struct catchtag
*catch;
1461 struct handler
*handler
;
1462 register struct backtrace
*backlist
;
1463 register Lisp_Object tem
;
1464 char *omessage
= echo_area_glyphs
;
1465 int omessage_length
= echo_area_glyphs_length
;
1466 char stack_top_variable
;
1469 /* In case user calls debug_print during GC,
1470 don't let that cause a recursive GC. */
1471 consing_since_gc
= 0;
1473 /* Save a copy of the contents of the stack, for debugging. */
1474 #if MAX_SAVE_STACK > 0
1475 if (NILP (Vpurify_flag
))
1477 i
= &stack_top_variable
- stack_bottom
;
1479 if (i
< MAX_SAVE_STACK
)
1481 if (stack_copy
== 0)
1482 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1483 else if (stack_copy_size
< i
)
1484 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1487 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1488 bcopy (stack_bottom
, stack_copy
, i
);
1490 bcopy (&stack_top_variable
, stack_copy
, i
);
1494 #endif /* MAX_SAVE_STACK > 0 */
1496 if (garbage_collection_messages
)
1497 message1_nolog ("Garbage collecting...");
1499 /* Don't keep command history around forever */
1500 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1502 XCONS (tem
)->cdr
= Qnil
;
1504 /* Likewise for undo information. */
1506 register struct buffer
*nextb
= all_buffers
;
1510 /* If a buffer's undo list is Qt, that means that undo is
1511 turned off in that buffer. Calling truncate_undo_list on
1512 Qt tends to return NULL, which effectively turns undo back on.
1513 So don't call truncate_undo_list if undo_list is Qt. */
1514 if (! EQ (nextb
->undo_list
, Qt
))
1516 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1518 nextb
= nextb
->next
;
1524 /* clear_marks (); */
1526 /* In each "large string", set the MARKBIT of the size field.
1527 That enables mark_object to recognize them. */
1529 register struct string_block
*b
;
1530 for (b
= large_string_blocks
; b
; b
= b
->next
)
1531 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1534 /* Mark all the special slots that serve as the roots of accessibility.
1536 Usually the special slots to mark are contained in particular structures.
1537 Then we know no slot is marked twice because the structures don't overlap.
1538 In some cases, the structures point to the slots to be marked.
1539 For these, we use MARKBIT to avoid double marking of the slot. */
1541 for (i
= 0; i
< staticidx
; i
++)
1542 mark_object (staticvec
[i
]);
1543 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1544 for (i
= 0; i
< tail
->nvars
; i
++)
1545 if (!XMARKBIT (tail
->var
[i
]))
1547 mark_object (&tail
->var
[i
]);
1548 XMARK (tail
->var
[i
]);
1550 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1552 mark_object (&bind
->symbol
);
1553 mark_object (&bind
->old_value
);
1555 for (catch = catchlist
; catch; catch = catch->next
)
1557 mark_object (&catch->tag
);
1558 mark_object (&catch->val
);
1560 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1562 mark_object (&handler
->handler
);
1563 mark_object (&handler
->var
);
1565 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1567 if (!XMARKBIT (*backlist
->function
))
1569 mark_object (backlist
->function
);
1570 XMARK (*backlist
->function
);
1572 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1575 i
= backlist
->nargs
- 1;
1577 if (!XMARKBIT (backlist
->args
[i
]))
1579 mark_object (&backlist
->args
[i
]);
1580 XMARK (backlist
->args
[i
]);
1587 /* Clear the mark bits that we set in certain root slots. */
1589 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1590 for (i
= 0; i
< tail
->nvars
; i
++)
1591 XUNMARK (tail
->var
[i
]);
1592 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1594 XUNMARK (*backlist
->function
);
1595 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1598 i
= backlist
->nargs
- 1;
1600 XUNMARK (backlist
->args
[i
]);
1602 XUNMARK (buffer_defaults
.name
);
1603 XUNMARK (buffer_local_symbols
.name
);
1605 /* clear_marks (); */
1608 consing_since_gc
= 0;
1609 if (gc_cons_threshold
< 10000)
1610 gc_cons_threshold
= 10000;
1612 if (garbage_collection_messages
)
1614 if (omessage
|| minibuf_level
> 0)
1615 message2_nolog (omessage
, omessage_length
);
1617 message1_nolog ("Garbage collecting...done");
1620 return Fcons (Fcons (make_number (total_conses
),
1621 make_number (total_free_conses
)),
1622 Fcons (Fcons (make_number (total_symbols
),
1623 make_number (total_free_symbols
)),
1624 Fcons (Fcons (make_number (total_markers
),
1625 make_number (total_free_markers
)),
1626 Fcons (make_number (total_string_size
),
1627 Fcons (make_number (total_vector_size
),
1629 #ifdef LISP_FLOAT_TYPE
1630 (make_number (total_floats
),
1631 make_number (total_free_floats
)),
1632 #else /* not LISP_FLOAT_TYPE */
1633 (make_number (0), make_number (0)),
1634 #endif /* not LISP_FLOAT_TYPE */
1636 #ifdef USE_TEXT_PROPERTIES
1637 (make_number (total_intervals
),
1638 make_number (total_free_intervals
)),
1639 #else /* not USE_TEXT_PROPERTIES */
1640 (make_number (0), make_number (0)),
1641 #endif /* not USE_TEXT_PROPERTIES */
1649 /* Clear marks on all conses */
1651 register struct cons_block
*cblk
;
1652 register int lim
= cons_block_index
;
1654 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1657 for (i
= 0; i
< lim
; i
++)
1658 XUNMARK (cblk
->conses
[i
].car
);
1659 lim
= CONS_BLOCK_SIZE
;
1662 /* Clear marks on all symbols */
1664 register struct symbol_block
*sblk
;
1665 register int lim
= symbol_block_index
;
1667 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1670 for (i
= 0; i
< lim
; i
++)
1672 XUNMARK (sblk
->symbols
[i
].plist
);
1674 lim
= SYMBOL_BLOCK_SIZE
;
1677 /* Clear marks on all markers */
1679 register struct marker_block
*sblk
;
1680 register int lim
= marker_block_index
;
1682 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1685 for (i
= 0; i
< lim
; i
++)
1686 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1687 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1688 lim
= MARKER_BLOCK_SIZE
;
1691 /* Clear mark bits on all buffers */
1693 register struct buffer
*nextb
= all_buffers
;
1697 XUNMARK (nextb
->name
);
1698 nextb
= nextb
->next
;
1704 /* Mark reference to a Lisp_Object.
1705 If the object referred to has not been seen yet, recursively mark
1706 all the references contained in it.
1708 If the object referenced is a short string, the referencing slot
1709 is threaded into a chain of such slots, pointed to from
1710 the `size' field of the string. The actual string size
1711 lives in the last slot in the chain. We recognize the end
1712 because it is < (unsigned) STRING_BLOCK_SIZE. */
1714 #define LAST_MARKED_SIZE 500
1715 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1716 int last_marked_index
;
1719 mark_object (argptr
)
1720 Lisp_Object
*argptr
;
1722 Lisp_Object
*objptr
= argptr
;
1723 register Lisp_Object obj
;
1730 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1731 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1734 last_marked
[last_marked_index
++] = objptr
;
1735 if (last_marked_index
== LAST_MARKED_SIZE
)
1736 last_marked_index
= 0;
1738 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1742 register struct Lisp_String
*ptr
= XSTRING (obj
);
1744 MARK_INTERVAL_TREE (ptr
->intervals
);
1745 if (ptr
->size
& MARKBIT
)
1746 /* A large string. Just set ARRAY_MARK_FLAG. */
1747 ptr
->size
|= ARRAY_MARK_FLAG
;
1750 /* A small string. Put this reference
1751 into the chain of references to it.
1752 If the address includes MARKBIT, put that bit elsewhere
1753 when we store OBJPTR into the size field. */
1755 if (XMARKBIT (*objptr
))
1757 XSETFASTINT (*objptr
, ptr
->size
);
1761 XSETFASTINT (*objptr
, ptr
->size
);
1763 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1765 ptr
->size
= (EMACS_INT
) objptr
;
1766 if (ptr
->size
& MARKBIT
)
1767 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1772 case Lisp_Vectorlike
:
1773 if (GC_BUFFERP (obj
))
1775 if (!XMARKBIT (XBUFFER (obj
)->name
))
1778 else if (GC_SUBRP (obj
))
1780 else if (GC_COMPILEDP (obj
))
1781 /* We could treat this just like a vector, but it is better
1782 to save the COMPILED_CONSTANTS element for last and avoid recursion
1785 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1786 register EMACS_INT size
= ptr
->size
;
1787 /* See comment above under Lisp_Vector. */
1788 struct Lisp_Vector
*volatile ptr1
= ptr
;
1791 if (size
& ARRAY_MARK_FLAG
)
1792 break; /* Already marked */
1793 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1794 size
&= PSEUDOVECTOR_SIZE_MASK
;
1795 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1797 if (i
!= COMPILED_CONSTANTS
)
1798 mark_object (&ptr1
->contents
[i
]);
1800 /* This cast should be unnecessary, but some Mips compiler complains
1801 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1802 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1806 else if (GC_FRAMEP (obj
))
1808 /* See comment above under Lisp_Vector for why this is volatile. */
1809 register struct frame
*volatile ptr
= XFRAME (obj
);
1810 register EMACS_INT size
= ptr
->size
;
1812 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1813 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1815 mark_object (&ptr
->name
);
1816 mark_object (&ptr
->icon_name
);
1817 mark_object (&ptr
->title
);
1818 mark_object (&ptr
->focus_frame
);
1819 mark_object (&ptr
->selected_window
);
1820 mark_object (&ptr
->minibuffer_window
);
1821 mark_object (&ptr
->param_alist
);
1822 mark_object (&ptr
->scroll_bars
);
1823 mark_object (&ptr
->condemned_scroll_bars
);
1824 mark_object (&ptr
->menu_bar_items
);
1825 mark_object (&ptr
->face_alist
);
1826 mark_object (&ptr
->menu_bar_vector
);
1827 mark_object (&ptr
->buffer_predicate
);
1829 #endif /* MULTI_FRAME */
1830 else if (GC_BOOL_VECTOR_P (obj
))
1832 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1834 if (ptr
->size
& ARRAY_MARK_FLAG
)
1835 break; /* Already marked */
1836 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1840 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1841 register EMACS_INT size
= ptr
->size
;
1842 /* The reason we use ptr1 is to avoid an apparent hardware bug
1843 that happens occasionally on the FSF's HP 300s.
1844 The bug is that a2 gets clobbered by recursive calls to mark_object.
1845 The clobberage seems to happen during function entry,
1846 perhaps in the moveml instruction.
1847 Yes, this is a crock, but we have to do it. */
1848 struct Lisp_Vector
*volatile ptr1
= ptr
;
1851 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1852 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1853 if (size
& PSEUDOVECTOR_FLAG
)
1854 size
&= PSEUDOVECTOR_SIZE_MASK
;
1855 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1856 mark_object (&ptr1
->contents
[i
]);
1862 /* See comment above under Lisp_Vector for why this is volatile. */
1863 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1864 struct Lisp_Symbol
*ptrx
;
1866 if (XMARKBIT (ptr
->plist
)) break;
1868 mark_object ((Lisp_Object
*) &ptr
->value
);
1869 mark_object (&ptr
->function
);
1870 mark_object (&ptr
->plist
);
1871 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1872 mark_object (&ptr
->name
);
1876 /* For the benefit of the last_marked log. */
1877 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1878 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1879 XSETSYMBOL (obj
, ptrx
);
1880 /* We can't goto loop here because *objptr doesn't contain an
1881 actual Lisp_Object with valid datatype field. */
1888 switch (XMISCTYPE (obj
))
1890 case Lisp_Misc_Marker
:
1891 XMARK (XMARKER (obj
)->chain
);
1892 /* DO NOT mark thru the marker's chain.
1893 The buffer's markers chain does not preserve markers from gc;
1894 instead, markers are removed from the chain when freed by gc. */
1897 case Lisp_Misc_Buffer_Local_Value
:
1898 case Lisp_Misc_Some_Buffer_Local_Value
:
1900 register struct Lisp_Buffer_Local_Value
*ptr
1901 = XBUFFER_LOCAL_VALUE (obj
);
1902 if (XMARKBIT (ptr
->car
)) break;
1904 /* If the cdr is nil, avoid recursion for the car. */
1905 if (EQ (ptr
->cdr
, Qnil
))
1910 mark_object (&ptr
->car
);
1911 /* See comment above under Lisp_Vector for why not use ptr here. */
1912 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1916 case Lisp_Misc_Intfwd
:
1917 case Lisp_Misc_Boolfwd
:
1918 case Lisp_Misc_Objfwd
:
1919 case Lisp_Misc_Buffer_Objfwd
:
1920 case Lisp_Misc_Kboard_Objfwd
:
1921 /* Don't bother with Lisp_Buffer_Objfwd,
1922 since all markable slots in current buffer marked anyway. */
1923 /* Don't need to do Lisp_Objfwd, since the places they point
1924 are protected with staticpro. */
1927 case Lisp_Misc_Overlay
:
1929 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1930 if (!XMARKBIT (ptr
->plist
))
1933 mark_object (&ptr
->start
);
1934 mark_object (&ptr
->end
);
1935 objptr
= &ptr
->plist
;
1948 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1949 if (XMARKBIT (ptr
->car
)) break;
1951 /* If the cdr is nil, avoid recursion for the car. */
1952 if (EQ (ptr
->cdr
, Qnil
))
1957 mark_object (&ptr
->car
);
1958 /* See comment above under Lisp_Vector for why not use ptr here. */
1959 objptr
= &XCONS (obj
)->cdr
;
1963 #ifdef LISP_FLOAT_TYPE
1965 XMARK (XFLOAT (obj
)->type
);
1967 #endif /* LISP_FLOAT_TYPE */
1977 /* Mark the pointers in a buffer structure. */
1983 register struct buffer
*buffer
= XBUFFER (buf
);
1984 register Lisp_Object
*ptr
;
1985 Lisp_Object base_buffer
;
1987 /* This is the buffer's markbit */
1988 mark_object (&buffer
->name
);
1989 XMARK (buffer
->name
);
1991 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1994 mark_object (buffer
->syntax_table
);
1996 /* Mark the various string-pointers in the buffer object.
1997 Since the strings may be relocated, we must mark them
1998 in their actual slots. So gc_sweep must convert each slot
1999 back to an ordinary C pointer. */
2000 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2001 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2002 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2003 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2005 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2006 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2007 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2008 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2011 for (ptr
= &buffer
->name
+ 1;
2012 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2016 /* If this is an indirect buffer, mark its base buffer. */
2017 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2019 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2020 mark_buffer (base_buffer
);
2025 /* Mark the pointers in the kboard objects. */
2032 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2034 if (kb
->kbd_macro_buffer
)
2035 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2037 mark_object (&kb
->Vprefix_arg
);
2038 mark_object (&kb
->kbd_queue
);
2039 mark_object (&kb
->Vlast_kbd_macro
);
2040 mark_object (&kb
->Vsystem_key_alist
);
2041 mark_object (&kb
->system_key_syms
);
2045 /* Sweep: find all structures not marked, and free them. */
2050 total_string_size
= 0;
2053 /* Put all unmarked conses on free list */
2055 register struct cons_block
*cblk
;
2056 register int lim
= cons_block_index
;
2057 register int num_free
= 0, num_used
= 0;
2061 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
2064 for (i
= 0; i
< lim
; i
++)
2065 if (!XMARKBIT (cblk
->conses
[i
].car
))
2068 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
2069 cons_free_list
= &cblk
->conses
[i
];
2074 XUNMARK (cblk
->conses
[i
].car
);
2076 lim
= CONS_BLOCK_SIZE
;
2078 total_conses
= num_used
;
2079 total_free_conses
= num_free
;
2082 #ifdef LISP_FLOAT_TYPE
2083 /* Put all unmarked floats on free list */
2085 register struct float_block
*fblk
;
2086 register int lim
= float_block_index
;
2087 register int num_free
= 0, num_used
= 0;
2089 float_free_list
= 0;
2091 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2094 for (i
= 0; i
< lim
; i
++)
2095 if (!XMARKBIT (fblk
->floats
[i
].type
))
2098 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2099 float_free_list
= &fblk
->floats
[i
];
2104 XUNMARK (fblk
->floats
[i
].type
);
2106 lim
= FLOAT_BLOCK_SIZE
;
2108 total_floats
= num_used
;
2109 total_free_floats
= num_free
;
2111 #endif /* LISP_FLOAT_TYPE */
2113 #ifdef USE_TEXT_PROPERTIES
2114 /* Put all unmarked intervals on free list */
2116 register struct interval_block
*iblk
;
2117 register int lim
= interval_block_index
;
2118 register int num_free
= 0, num_used
= 0;
2120 interval_free_list
= 0;
2122 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2126 for (i
= 0; i
< lim
; i
++)
2128 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2130 iblk
->intervals
[i
].parent
= interval_free_list
;
2131 interval_free_list
= &iblk
->intervals
[i
];
2137 XUNMARK (iblk
->intervals
[i
].plist
);
2140 lim
= INTERVAL_BLOCK_SIZE
;
2142 total_intervals
= num_used
;
2143 total_free_intervals
= num_free
;
2145 #endif /* USE_TEXT_PROPERTIES */
2147 /* Put all unmarked symbols on free list */
2149 register struct symbol_block
*sblk
;
2150 register int lim
= symbol_block_index
;
2151 register int num_free
= 0, num_used
= 0;
2153 symbol_free_list
= 0;
2155 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2158 for (i
= 0; i
< lim
; i
++)
2159 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2161 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2162 symbol_free_list
= &sblk
->symbols
[i
];
2168 sblk
->symbols
[i
].name
2169 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2170 XUNMARK (sblk
->symbols
[i
].plist
);
2172 lim
= SYMBOL_BLOCK_SIZE
;
2174 total_symbols
= num_used
;
2175 total_free_symbols
= num_free
;
2179 /* Put all unmarked markers on free list.
2180 Unchain each one first from the buffer it points into,
2181 but only if it's a real marker. */
2183 register struct marker_block
*mblk
;
2184 register int lim
= marker_block_index
;
2185 register int num_free
= 0, num_used
= 0;
2187 marker_free_list
= 0;
2189 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2192 EMACS_INT already_free
= -1;
2194 for (i
= 0; i
< lim
; i
++)
2196 Lisp_Object
*markword
;
2197 switch (mblk
->markers
[i
].u_marker
.type
)
2199 case Lisp_Misc_Marker
:
2200 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2202 case Lisp_Misc_Buffer_Local_Value
:
2203 case Lisp_Misc_Some_Buffer_Local_Value
:
2204 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2206 case Lisp_Misc_Overlay
:
2207 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2209 case Lisp_Misc_Free
:
2210 /* If the object was already free, keep it
2211 on the free list. */
2212 markword
= &already_free
;
2218 if (markword
&& !XMARKBIT (*markword
))
2221 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2223 /* tem1 avoids Sun compiler bug */
2224 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2225 XSETMARKER (tem
, tem1
);
2226 unchain_marker (tem
);
2228 /* Set the type of the freed object to Lisp_Misc_Free.
2229 We could leave the type alone, since nobody checks it,
2230 but this might catch bugs faster. */
2231 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2232 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2233 marker_free_list
= &mblk
->markers
[i
];
2240 XUNMARK (*markword
);
2243 lim
= MARKER_BLOCK_SIZE
;
2246 total_markers
= num_used
;
2247 total_free_markers
= num_free
;
2250 /* Free all unmarked buffers */
2252 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2255 if (!XMARKBIT (buffer
->name
))
2258 prev
->next
= buffer
->next
;
2260 all_buffers
= buffer
->next
;
2261 next
= buffer
->next
;
2267 XUNMARK (buffer
->name
);
2268 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2271 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2272 for purposes of marking and relocation.
2273 Turn them back into C pointers now. */
2274 buffer
->upcase_table
2275 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2276 buffer
->downcase_table
2277 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2279 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2280 buffer
->folding_sort_table
2281 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2284 prev
= buffer
, buffer
= buffer
->next
;
2288 #endif /* standalone */
2290 /* Free all unmarked vectors */
2292 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2293 total_vector_size
= 0;
2296 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2299 prev
->next
= vector
->next
;
2301 all_vectors
= vector
->next
;
2302 next
= vector
->next
;
2308 vector
->size
&= ~ARRAY_MARK_FLAG
;
2309 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2310 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2312 total_vector_size
+= vector
->size
;
2313 prev
= vector
, vector
= vector
->next
;
2317 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2319 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2320 struct Lisp_String
*s
;
2324 s
= (struct Lisp_String
*) &sb
->chars
[0];
2325 if (s
->size
& ARRAY_MARK_FLAG
)
2327 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2328 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2329 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2330 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2331 prev
= sb
, sb
= sb
->next
;
2336 prev
->next
= sb
->next
;
2338 large_string_blocks
= sb
->next
;
2347 /* Compactify strings, relocate references, and free empty string blocks. */
2352 /* String block of old strings we are scanning. */
2353 register struct string_block
*from_sb
;
2354 /* A preceding string block (or maybe the same one)
2355 where we are copying the still-live strings to. */
2356 register struct string_block
*to_sb
;
2360 to_sb
= first_string_block
;
2363 /* Scan each existing string block sequentially, string by string. */
2364 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2367 /* POS is the index of the next string in the block. */
2368 while (pos
< from_sb
->pos
)
2370 register struct Lisp_String
*nextstr
2371 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2373 register struct Lisp_String
*newaddr
;
2374 register EMACS_INT size
= nextstr
->size
;
2376 /* NEXTSTR is the old address of the next string.
2377 Just skip it if it isn't marked. */
2378 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2380 /* It is marked, so its size field is really a chain of refs.
2381 Find the end of the chain, where the actual size lives. */
2382 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2384 if (size
& DONT_COPY_FLAG
)
2385 size
^= MARKBIT
| DONT_COPY_FLAG
;
2386 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2389 total_string_size
+= size
;
2391 /* If it won't fit in TO_SB, close it out,
2392 and move to the next sb. Keep doing so until
2393 TO_SB reaches a large enough, empty enough string block.
2394 We know that TO_SB cannot advance past FROM_SB here
2395 since FROM_SB is large enough to contain this string.
2396 Any string blocks skipped here
2397 will be patched out and freed later. */
2398 while (to_pos
+ STRING_FULLSIZE (size
)
2399 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2401 to_sb
->pos
= to_pos
;
2402 to_sb
= to_sb
->next
;
2405 /* Compute new address of this string
2406 and update TO_POS for the space being used. */
2407 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2408 to_pos
+= STRING_FULLSIZE (size
);
2410 /* Copy the string itself to the new place. */
2411 if (nextstr
!= newaddr
)
2412 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2413 + INTERVAL_PTR_SIZE
);
2415 /* Go through NEXTSTR's chain of references
2416 and make each slot in the chain point to
2417 the new address of this string. */
2418 size
= newaddr
->size
;
2419 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2421 register Lisp_Object
*objptr
;
2422 if (size
& DONT_COPY_FLAG
)
2423 size
^= MARKBIT
| DONT_COPY_FLAG
;
2424 objptr
= (Lisp_Object
*)size
;
2426 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2427 if (XMARKBIT (*objptr
))
2429 XSETSTRING (*objptr
, newaddr
);
2433 XSETSTRING (*objptr
, newaddr
);
2435 /* Store the actual size in the size field. */
2436 newaddr
->size
= size
;
2438 #ifdef USE_TEXT_PROPERTIES
2439 /* Now that the string has been relocated, rebalance its
2440 interval tree, and update the tree's parent pointer. */
2441 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2443 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2444 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2447 #endif /* USE_TEXT_PROPERTIES */
2449 pos
+= STRING_FULLSIZE (size
);
2453 /* Close out the last string block still used and free any that follow. */
2454 to_sb
->pos
= to_pos
;
2455 current_string_block
= to_sb
;
2457 from_sb
= to_sb
->next
;
2461 to_sb
= from_sb
->next
;
2466 /* Free any empty string blocks further back in the chain.
2467 This loop will never free first_string_block, but it is very
2468 unlikely that that one will become empty, so why bother checking? */
2470 from_sb
= first_string_block
;
2471 while (to_sb
= from_sb
->next
)
2473 if (to_sb
->pos
== 0)
2475 if (from_sb
->next
= to_sb
->next
)
2476 from_sb
->next
->prev
= from_sb
;
2484 /* Debugging aids. */
2486 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2487 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2488 This may be helpful in debugging Emacs's memory usage.\n\
2489 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2494 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2499 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2500 "Return a list of counters that measure how much consing there has been.\n\
2501 Each of these counters increments for a certain kind of object.\n\
2502 The counters wrap around from the largest positive integer to zero.\n\
2503 Garbage collection does not decrease them.\n\
2504 The elements of the value are as follows:\n\
2505 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2506 All are in units of 1 = one object consed\n\
2507 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2509 MISCS include overlays, markers, and some internal types.\n\
2510 Frames, windows, buffers, and subprocesses count as vectors\n\
2511 (but the contents of a buffer's text do not count here).")
2514 Lisp_Object lisp_cons_cells_consed
;
2515 Lisp_Object lisp_floats_consed
;
2516 Lisp_Object lisp_vector_cells_consed
;
2517 Lisp_Object lisp_symbols_consed
;
2518 Lisp_Object lisp_string_chars_consed
;
2519 Lisp_Object lisp_misc_objects_consed
;
2520 Lisp_Object lisp_intervals_consed
;
2522 XSETINT (lisp_cons_cells_consed
,
2523 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2524 XSETINT (lisp_floats_consed
,
2525 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2526 XSETINT (lisp_vector_cells_consed
,
2527 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2528 XSETINT (lisp_symbols_consed
,
2529 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2530 XSETINT (lisp_string_chars_consed
,
2531 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2532 XSETINT (lisp_misc_objects_consed
,
2533 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2534 XSETINT (lisp_intervals_consed
,
2535 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2537 return Fcons (lisp_cons_cells_consed
,
2538 Fcons (lisp_floats_consed
,
2539 Fcons (lisp_vector_cells_consed
,
2540 Fcons (lisp_symbols_consed
,
2541 Fcons (lisp_string_chars_consed
,
2542 Fcons (lisp_misc_objects_consed
,
2543 Fcons (lisp_intervals_consed
,
2547 /* Initialization */
2551 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2554 pure_size
= PURESIZE
;
2557 ignore_warnings
= 1;
2562 #ifdef LISP_FLOAT_TYPE
2564 #endif /* LISP_FLOAT_TYPE */
2568 malloc_hysteresis
= 32;
2570 malloc_hysteresis
= 0;
2573 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2575 ignore_warnings
= 0;
2578 consing_since_gc
= 0;
2579 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2580 #ifdef VIRT_ADDR_VARIES
2581 malloc_sbrk_unused
= 1<<22; /* A large number */
2582 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2583 #endif /* VIRT_ADDR_VARIES */
2594 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2595 "*Number of bytes of consing between garbage collections.\n\
2596 Garbage collection can happen automatically once this many bytes have been\n\
2597 allocated since the last garbage collection. All data types count.\n\n\
2598 Garbage collection happens automatically only when `eval' is called.\n\n\
2599 By binding this temporarily to a large number, you can effectively\n\
2600 prevent garbage collection during a part of the program.");
2602 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2603 "Number of bytes of sharable Lisp data allocated so far.");
2605 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2606 "Number of cons cells that have been consed so far.");
2608 DEFVAR_INT ("floats-consed", &floats_consed
,
2609 "Number of floats that have been consed so far.");
2611 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2612 "Number of vector cells that have been consed so far.");
2614 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2615 "Number of symbols that have been consed so far.");
2617 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2618 "Number of string characters that have been consed so far.");
2620 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2621 "Number of miscellaneous objects that have been consed so far.");
2623 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2624 "Number of intervals that have been consed so far.");
2627 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2628 "Number of bytes of unshared memory allocated in this session.");
2630 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2631 "Number of bytes of unshared memory remaining available in this session.");
2634 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2635 "Non-nil means loading Lisp code in order to dump an executable.\n\
2636 This means that certain objects should be allocated in shared (pure) space.");
2638 DEFVAR_INT ("undo-limit", &undo_limit
,
2639 "Keep no more undo information once it exceeds this size.\n\
2640 This limit is applied when garbage collection happens.\n\
2641 The size is counted as the number of bytes occupied,\n\
2642 which includes both saved text and other data.");
2645 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2646 "Don't keep more than this much size of undo information.\n\
2647 A command which pushes past this size is itself forgotten.\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.");
2651 undo_strong_limit
= 30000;
2653 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2654 "Non-nil means display messages at start and end of garbage collection.");
2655 garbage_collection_messages
= 0;
2657 /* We build this in advance because if we wait until we need it, we might
2658 not be able to allocate the memory to hold it. */
2660 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2661 staticpro (&memory_signal_data
);
2663 staticpro (&Qgc_cons_threshold
);
2664 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2666 staticpro (&Qchar_table_extra_slots
);
2667 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2672 defsubr (&Smake_byte_code
);
2673 defsubr (&Smake_list
);
2674 defsubr (&Smake_vector
);
2675 defsubr (&Smake_char_table
);
2676 defsubr (&Smake_string
);
2677 defsubr (&Smake_bool_vector
);
2678 defsubr (&Smake_symbol
);
2679 defsubr (&Smake_marker
);
2680 defsubr (&Spurecopy
);
2681 defsubr (&Sgarbage_collect
);
2682 defsubr (&Smemory_limit
);
2683 defsubr (&Smemory_use_counts
);