1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
21 /* Note that this declares bzero on OSF/1. How dumb. */
26 #include "intervals.h"
32 #include "blockinput.h"
36 #include "syssignal.h"
40 #ifdef DOUG_LEA_MALLOC
42 #define __malloc_size_t int
44 /* The following come from gmalloc.c. */
46 #if defined (__STDC__) && __STDC__
48 #define __malloc_size_t size_t
50 #define __malloc_size_t unsigned int
52 extern __malloc_size_t _bytes_used
;
53 extern int __malloc_extra_blocks
;
54 #endif /* !defined(DOUG_LEA_MALLOC) */
56 extern Lisp_Object Vhistory_length
;
58 #define max(A,B) ((A) > (B) ? (A) : (B))
59 #define min(A,B) ((A) < (B) ? (A) : (B))
61 /* Macro to verify that storage intended for Lisp objects is not
62 out of range to fit in the space for a pointer.
63 ADDRESS is the start of the block, and SIZE
64 is the amount of space within which objects can start. */
65 #define VALIDATE_LISP_STORAGE(address, size) \
69 XSETCONS (val, (char *) address + size); \
70 if ((char *) XCONS (val) != (char *) address + size) \
77 /* Value of _bytes_used, when spare_memory was freed. */
78 static __malloc_size_t bytes_used_when_full
;
80 /* Number of bytes of consing done since the last gc */
83 /* Count the amount of consing of various sorts of space. */
84 int cons_cells_consed
;
86 int vector_cells_consed
;
88 int string_chars_consed
;
89 int misc_objects_consed
;
92 /* Number of bytes of consing since gc before another gc should be done. */
93 int gc_cons_threshold
;
95 /* Nonzero during gc */
98 /* Nonzero means display messages at beginning and end of GC. */
99 int garbage_collection_messages
;
101 #ifndef VIRT_ADDR_VARIES
103 #endif /* VIRT_ADDR_VARIES */
104 int malloc_sbrk_used
;
106 #ifndef VIRT_ADDR_VARIES
108 #endif /* VIRT_ADDR_VARIES */
109 int malloc_sbrk_unused
;
111 /* Two limits controlling how much undo information to keep. */
113 int undo_strong_limit
;
115 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
116 int total_free_conses
, total_free_markers
, total_free_symbols
;
117 #ifdef LISP_FLOAT_TYPE
118 int total_free_floats
, total_floats
;
119 #endif /* LISP_FLOAT_TYPE */
121 /* Points to memory space allocated as "spare",
122 to be freed if we run out of memory. */
123 static char *spare_memory
;
125 /* Amount of spare memory to keep in reserve. */
126 #define SPARE_MEMORY (1 << 14)
128 /* Number of extra blocks malloc should get when it needs more core. */
129 static int malloc_hysteresis
;
131 /* Nonzero when malloc is called for allocating Lisp object space. */
132 int allocating_for_lisp
;
134 /* Non-nil means defun should do purecopy on the function definition */
135 Lisp_Object Vpurify_flag
;
138 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
139 #define PUREBEG (char *) pure
141 #define pure PURE_SEG_BITS /* Use shared memory segment */
142 #define PUREBEG (char *)PURE_SEG_BITS
144 /* This variable is used only by the XPNTR macro when HAVE_SHM is
145 defined. If we used the PURESIZE macro directly there, that would
146 make most of emacs dependent on puresize.h, which we don't want -
147 you should be able to change that without too much recompilation.
148 So map_in_data initializes pure_size, and the dependencies work
151 #endif /* not HAVE_SHM */
153 /* Index in pure at which next pure object will be allocated. */
156 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
157 char *pending_malloc_warning
;
159 /* Pre-computed signal argument for use when memory is exhausted. */
160 Lisp_Object memory_signal_data
;
162 /* Maximum amount of C stack to save when a GC happens. */
164 #ifndef MAX_SAVE_STACK
165 #define MAX_SAVE_STACK 16000
168 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
169 pointer to a Lisp_Object, when that pointer is viewed as an integer.
170 (On most machines, pointers are even, so we can use the low bit.
171 Word-addressable architectures may need to override this in the m-file.)
172 When linking references to small strings through the size field, we
173 use this slot to hold the bit that would otherwise be interpreted as
175 #ifndef DONT_COPY_FLAG
176 #define DONT_COPY_FLAG 1
177 #endif /* no DONT_COPY_FLAG */
179 /* Buffer in which we save a copy of the C stack at each GC. */
184 /* Non-zero means ignore malloc warnings. Set during initialization. */
187 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
189 static void mark_object (), mark_buffer (), mark_kboards ();
190 static void clear_marks (), gc_sweep ();
191 static void compact_strings ();
193 /* Versions of malloc and realloc that print warnings as memory gets full. */
196 malloc_warning_1 (str
)
199 Fprinc (str
, Vstandard_output
);
200 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
201 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
202 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
206 /* malloc calls this if it finds we are near exhausting storage */
212 pending_malloc_warning
= str
;
216 display_malloc_warning ()
218 register Lisp_Object val
;
220 val
= build_string (pending_malloc_warning
);
221 pending_malloc_warning
= 0;
222 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
225 #ifdef DOUG_LEA_MALLOC
226 # define BYTES_USED (mallinfo ().arena)
228 # define BYTES_USED _bytes_used
231 /* Called if malloc returns zero */
236 #ifndef SYSTEM_MALLOC
237 bytes_used_when_full
= BYTES_USED
;
240 /* The first time we get here, free the spare memory. */
247 /* This used to call error, but if we've run out of memory, we could get
248 infinite recursion trying to build the string. */
250 Fsignal (Qnil
, memory_signal_data
);
253 /* Called if we can't allocate relocatable space for a buffer. */
256 buffer_memory_full ()
258 /* If buffers use the relocating allocator,
259 no need to free spare_memory, because we may have plenty of malloc
260 space left that we could get, and if we don't, the malloc that fails
261 will itself cause spare_memory to be freed.
262 If buffers don't use the relocating allocator,
263 treat this like any other failing malloc. */
269 /* This used to call error, but if we've run out of memory, we could get
270 infinite recursion trying to build the string. */
272 Fsignal (Qerror
, memory_signal_data
);
275 /* like malloc routines but check for no memory and block interrupt input. */
284 val
= (long *) malloc (size
);
287 if (!val
&& size
) memory_full ();
292 xrealloc (block
, size
)
299 /* We must call malloc explicitly when BLOCK is 0, since some
300 reallocs don't do this. */
302 val
= (long *) malloc (size
);
304 val
= (long *) realloc (block
, size
);
307 if (!val
&& size
) memory_full ();
321 /* Arranging to disable input signals while we're in malloc.
323 This only works with GNU malloc. To help out systems which can't
324 use GNU malloc, all the calls to malloc, realloc, and free
325 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
326 pairs; unfortunately, we have no idea what C library functions
327 might call malloc, so we can't really protect them unless you're
328 using GNU malloc. Fortunately, most of the major operating can use
331 #ifndef SYSTEM_MALLOC
332 extern void * (*__malloc_hook
) ();
333 static void * (*old_malloc_hook
) ();
334 extern void * (*__realloc_hook
) ();
335 static void * (*old_realloc_hook
) ();
336 extern void (*__free_hook
) ();
337 static void (*old_free_hook
) ();
339 /* This function is used as the hook for free to call. */
342 emacs_blocked_free (ptr
)
346 __free_hook
= old_free_hook
;
348 /* If we released our reserve (due to running out of memory),
349 and we have a fair amount free once again,
350 try to set aside another reserve in case we run out once more. */
351 if (spare_memory
== 0
352 /* Verify there is enough space that even with the malloc
353 hysteresis this call won't run out again.
354 The code here is correct as long as SPARE_MEMORY
355 is substantially larger than the block size malloc uses. */
356 && (bytes_used_when_full
357 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
358 spare_memory
= (char *) malloc (SPARE_MEMORY
);
360 __free_hook
= emacs_blocked_free
;
364 /* If we released our reserve (due to running out of memory),
365 and we have a fair amount free once again,
366 try to set aside another reserve in case we run out once more.
368 This is called when a relocatable block is freed in ralloc.c. */
371 refill_memory_reserve ()
373 if (spare_memory
== 0)
374 spare_memory
= (char *) malloc (SPARE_MEMORY
);
377 /* This function is the malloc hook that Emacs uses. */
380 emacs_blocked_malloc (size
)
386 __malloc_hook
= old_malloc_hook
;
387 #ifdef DOUG_LEA_MALLOC
388 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
390 __malloc_extra_blocks
= malloc_hysteresis
;
392 value
= (void *) malloc (size
);
393 __malloc_hook
= emacs_blocked_malloc
;
400 emacs_blocked_realloc (ptr
, size
)
407 __realloc_hook
= old_realloc_hook
;
408 value
= (void *) realloc (ptr
, size
);
409 __realloc_hook
= emacs_blocked_realloc
;
416 uninterrupt_malloc ()
418 old_free_hook
= __free_hook
;
419 __free_hook
= emacs_blocked_free
;
421 old_malloc_hook
= __malloc_hook
;
422 __malloc_hook
= emacs_blocked_malloc
;
424 old_realloc_hook
= __realloc_hook
;
425 __realloc_hook
= emacs_blocked_realloc
;
429 /* Interval allocation. */
431 #ifdef USE_TEXT_PROPERTIES
432 #define INTERVAL_BLOCK_SIZE \
433 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
435 struct interval_block
437 struct interval_block
*next
;
438 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
441 struct interval_block
*interval_block
;
442 static int interval_block_index
;
444 INTERVAL interval_free_list
;
449 allocating_for_lisp
= 1;
451 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
452 allocating_for_lisp
= 0;
453 interval_block
->next
= 0;
454 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
455 interval_block_index
= 0;
456 interval_free_list
= 0;
459 #define INIT_INTERVALS init_intervals ()
466 if (interval_free_list
)
468 val
= interval_free_list
;
469 interval_free_list
= interval_free_list
->parent
;
473 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
475 register struct interval_block
*newi
;
477 allocating_for_lisp
= 1;
478 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
480 allocating_for_lisp
= 0;
481 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
482 newi
->next
= interval_block
;
483 interval_block
= newi
;
484 interval_block_index
= 0;
486 val
= &interval_block
->intervals
[interval_block_index
++];
488 consing_since_gc
+= sizeof (struct interval
);
490 RESET_INTERVAL (val
);
494 static int total_free_intervals
, total_intervals
;
496 /* Mark the pointers of one interval. */
499 mark_interval (i
, dummy
)
503 if (XMARKBIT (i
->plist
))
505 mark_object (&i
->plist
);
510 mark_interval_tree (tree
)
511 register INTERVAL tree
;
513 /* No need to test if this tree has been marked already; this
514 function is always called through the MARK_INTERVAL_TREE macro,
515 which takes care of that. */
517 /* XMARK expands to an assignment; the LHS of an assignment can't be
519 XMARK (* (Lisp_Object
*) &tree
->parent
);
521 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
524 #define MARK_INTERVAL_TREE(i) \
526 if (!NULL_INTERVAL_P (i) \
527 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
528 mark_interval_tree (i); \
531 /* The oddity in the call to XUNMARK is necessary because XUNMARK
532 expands to an assignment to its argument, and most C compilers don't
533 support casts on the left operand of `='. */
534 #define UNMARK_BALANCE_INTERVALS(i) \
536 if (! NULL_INTERVAL_P (i)) \
538 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
539 (i) = balance_intervals (i); \
543 #else /* no interval use */
545 #define INIT_INTERVALS
547 #define UNMARK_BALANCE_INTERVALS(i)
548 #define MARK_INTERVAL_TREE(i)
550 #endif /* no interval use */
552 /* Floating point allocation. */
554 #ifdef LISP_FLOAT_TYPE
555 /* Allocation of float cells, just like conses */
556 /* We store float cells inside of float_blocks, allocating a new
557 float_block with malloc whenever necessary. Float cells reclaimed by
558 GC are put on a free list to be reallocated before allocating
559 any new float cells from the latest float_block.
561 Each float_block is just under 1020 bytes long,
562 since malloc really allocates in units of powers of two
563 and uses 4 bytes for its own overhead. */
565 #define FLOAT_BLOCK_SIZE \
566 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
570 struct float_block
*next
;
571 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
574 struct float_block
*float_block
;
575 int float_block_index
;
577 struct Lisp_Float
*float_free_list
;
582 allocating_for_lisp
= 1;
583 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
584 allocating_for_lisp
= 0;
585 float_block
->next
= 0;
586 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
587 float_block_index
= 0;
591 /* Explicitly free a float cell. */
593 struct Lisp_Float
*ptr
;
595 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
596 float_free_list
= ptr
;
600 make_float (float_value
)
603 register Lisp_Object val
;
607 /* We use the data field for chaining the free list
608 so that we won't use the same field that has the mark bit. */
609 XSETFLOAT (val
, float_free_list
);
610 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
614 if (float_block_index
== FLOAT_BLOCK_SIZE
)
616 register struct float_block
*new;
618 allocating_for_lisp
= 1;
619 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
620 allocating_for_lisp
= 0;
621 VALIDATE_LISP_STORAGE (new, sizeof *new);
622 new->next
= float_block
;
624 float_block_index
= 0;
626 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
628 XFLOAT (val
)->data
= float_value
;
629 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
630 consing_since_gc
+= sizeof (struct Lisp_Float
);
635 #endif /* LISP_FLOAT_TYPE */
637 /* Allocation of cons cells */
638 /* We store cons cells inside of cons_blocks, allocating a new
639 cons_block with malloc whenever necessary. Cons cells reclaimed by
640 GC are put on a free list to be reallocated before allocating
641 any new cons cells from the latest cons_block.
643 Each cons_block is just under 1020 bytes long,
644 since malloc really allocates in units of powers of two
645 and uses 4 bytes for its own overhead. */
647 #define CONS_BLOCK_SIZE \
648 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
652 struct cons_block
*next
;
653 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
656 struct cons_block
*cons_block
;
657 int cons_block_index
;
659 struct Lisp_Cons
*cons_free_list
;
664 allocating_for_lisp
= 1;
665 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
666 allocating_for_lisp
= 0;
667 cons_block
->next
= 0;
668 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
669 cons_block_index
= 0;
673 /* Explicitly free a cons cell. */
677 struct Lisp_Cons
*ptr
;
679 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
680 cons_free_list
= ptr
;
683 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
684 "Create a new cons, give it CAR and CDR as components, and return it.")
686 Lisp_Object car
, cdr
;
688 register Lisp_Object val
;
692 /* We use the cdr for chaining the free list
693 so that we won't use the same field that has the mark bit. */
694 XSETCONS (val
, cons_free_list
);
695 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
699 if (cons_block_index
== CONS_BLOCK_SIZE
)
701 register struct cons_block
*new;
702 allocating_for_lisp
= 1;
703 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
704 allocating_for_lisp
= 0;
705 VALIDATE_LISP_STORAGE (new, sizeof *new);
706 new->next
= cons_block
;
708 cons_block_index
= 0;
710 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
712 XCONS (val
)->car
= car
;
713 XCONS (val
)->cdr
= cdr
;
714 consing_since_gc
+= sizeof (struct Lisp_Cons
);
719 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
720 "Return a newly created list with specified arguments as elements.\n\
721 Any number of arguments, even zero arguments, are allowed.")
724 register Lisp_Object
*args
;
726 register Lisp_Object val
;
732 val
= Fcons (args
[nargs
], val
);
737 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
738 "Return a newly created list of length LENGTH, with each element being INIT.")
740 register Lisp_Object length
, init
;
742 register Lisp_Object val
;
745 CHECK_NATNUM (length
, 0);
746 size
= XFASTINT (length
);
750 val
= Fcons (init
, val
);
754 /* Allocation of vectors */
756 struct Lisp_Vector
*all_vectors
;
759 allocate_vectorlike (len
)
762 struct Lisp_Vector
*p
;
764 allocating_for_lisp
= 1;
765 #ifdef DOUG_LEA_MALLOC
766 /* Prevent mmap'ing the chunk (which is potentially very large). */
767 mallopt (M_MMAP_MAX
, 0);
769 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
770 + (len
- 1) * sizeof (Lisp_Object
));
771 #ifdef DOUG_LEA_MALLOC
772 /* Back to a reasonable maximum of mmap'ed areas. */
773 mallopt (M_MMAP_MAX
, 64);
775 allocating_for_lisp
= 0;
776 VALIDATE_LISP_STORAGE (p
, 0);
777 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
778 + (len
- 1) * sizeof (Lisp_Object
));
779 vector_cells_consed
+= len
;
781 p
->next
= all_vectors
;
786 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
787 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
788 See also the function `vector'.")
790 register Lisp_Object length
, init
;
793 register EMACS_INT sizei
;
795 register struct Lisp_Vector
*p
;
797 CHECK_NATNUM (length
, 0);
798 sizei
= XFASTINT (length
);
800 p
= allocate_vectorlike (sizei
);
802 for (index
= 0; index
< sizei
; index
++)
803 p
->contents
[index
] = init
;
805 XSETVECTOR (vector
, p
);
809 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
810 "Return a newly created char-table, with purpose PURPOSE.\n\
811 Each element is initialized to INIT, which defaults to nil.\n\
812 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
813 The property's value should be an integer between 0 and 10.")
815 register Lisp_Object purpose
, init
;
819 CHECK_SYMBOL (purpose
, 1);
820 n
= Fget (purpose
, Qchar_table_extra_slots
);
822 if (XINT (n
) < 0 || XINT (n
) > 10)
823 args_out_of_range (n
, Qnil
);
824 /* Add 2 to the size for the defalt and parent slots. */
825 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
827 XCHAR_TABLE (vector
)->top
= Qt
;
828 XCHAR_TABLE (vector
)->parent
= Qnil
;
829 XCHAR_TABLE (vector
)->purpose
= purpose
;
830 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
834 /* Return a newly created sub char table with default value DEFALT.
835 Since a sub char table does not appear as a top level Emacs Lisp
836 object, we don't need a Lisp interface to make it. */
839 make_sub_char_table (defalt
)
843 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
844 XCHAR_TABLE (vector
)->top
= Qnil
;
845 XCHAR_TABLE (vector
)->defalt
= defalt
;
846 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
850 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
851 "Return a newly created vector with specified arguments as elements.\n\
852 Any number of arguments, even zero arguments, are allowed.")
857 register Lisp_Object len
, val
;
859 register struct Lisp_Vector
*p
;
861 XSETFASTINT (len
, nargs
);
862 val
= Fmake_vector (len
, Qnil
);
864 for (index
= 0; index
< nargs
; index
++)
865 p
->contents
[index
] = args
[index
];
869 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
870 "Create a byte-code object with specified arguments as elements.\n\
871 The arguments should be the arglist, bytecode-string, constant vector,\n\
872 stack size, (optional) doc string, and (optional) interactive spec.\n\
873 The first four arguments are required; at most six have any\n\
879 register Lisp_Object len
, val
;
881 register struct Lisp_Vector
*p
;
883 XSETFASTINT (len
, nargs
);
884 if (!NILP (Vpurify_flag
))
885 val
= make_pure_vector ((EMACS_INT
) nargs
);
887 val
= Fmake_vector (len
, Qnil
);
889 for (index
= 0; index
< nargs
; index
++)
891 if (!NILP (Vpurify_flag
))
892 args
[index
] = Fpurecopy (args
[index
]);
893 p
->contents
[index
] = args
[index
];
895 XSETCOMPILED (val
, p
);
899 /* Allocation of symbols.
900 Just like allocation of conses!
902 Each symbol_block is just under 1020 bytes long,
903 since malloc really allocates in units of powers of two
904 and uses 4 bytes for its own overhead. */
906 #define SYMBOL_BLOCK_SIZE \
907 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
911 struct symbol_block
*next
;
912 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
915 struct symbol_block
*symbol_block
;
916 int symbol_block_index
;
918 struct Lisp_Symbol
*symbol_free_list
;
923 allocating_for_lisp
= 1;
924 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
925 allocating_for_lisp
= 0;
926 symbol_block
->next
= 0;
927 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
928 symbol_block_index
= 0;
929 symbol_free_list
= 0;
932 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
933 "Return a newly allocated uninterned symbol whose name is NAME.\n\
934 Its value and function definition are void, and its property list is nil.")
938 register Lisp_Object val
;
939 register struct Lisp_Symbol
*p
;
941 CHECK_STRING (name
, 0);
943 if (symbol_free_list
)
945 XSETSYMBOL (val
, symbol_free_list
);
946 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
950 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
952 struct symbol_block
*new;
953 allocating_for_lisp
= 1;
954 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
955 allocating_for_lisp
= 0;
956 VALIDATE_LISP_STORAGE (new, sizeof *new);
957 new->next
= symbol_block
;
959 symbol_block_index
= 0;
961 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
964 p
->name
= XSTRING (name
);
968 p
->function
= Qunbound
;
970 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
975 /* Allocation of markers and other objects that share that structure.
976 Works like allocation of conses. */
978 #define MARKER_BLOCK_SIZE \
979 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
983 struct marker_block
*next
;
984 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
987 struct marker_block
*marker_block
;
988 int marker_block_index
;
990 union Lisp_Misc
*marker_free_list
;
995 allocating_for_lisp
= 1;
996 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
997 allocating_for_lisp
= 0;
998 marker_block
->next
= 0;
999 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1000 marker_block_index
= 0;
1001 marker_free_list
= 0;
1004 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1010 if (marker_free_list
)
1012 XSETMISC (val
, marker_free_list
);
1013 marker_free_list
= marker_free_list
->u_free
.chain
;
1017 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1019 struct marker_block
*new;
1020 allocating_for_lisp
= 1;
1021 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
1022 allocating_for_lisp
= 0;
1023 VALIDATE_LISP_STORAGE (new, sizeof *new);
1024 new->next
= marker_block
;
1026 marker_block_index
= 0;
1028 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1030 consing_since_gc
+= sizeof (union Lisp_Misc
);
1031 misc_objects_consed
++;
1035 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1036 "Return a newly allocated marker which does not point at any place.")
1039 register Lisp_Object val
;
1040 register struct Lisp_Marker
*p
;
1042 val
= allocate_misc ();
1043 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1048 p
->insertion_type
= 0;
1052 /* Put MARKER back on the free list after using it temporarily. */
1055 free_marker (marker
)
1058 unchain_marker (marker
);
1060 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1061 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1062 marker_free_list
= XMISC (marker
);
1064 total_free_markers
++;
1067 /* Allocation of strings */
1069 /* Strings reside inside of string_blocks. The entire data of the string,
1070 both the size and the contents, live in part of the `chars' component of a string_block.
1071 The `pos' component is the index within `chars' of the first free byte.
1073 first_string_block points to the first string_block ever allocated.
1074 Each block points to the next one with its `next' field.
1075 The `prev' fields chain in reverse order.
1076 The last one allocated is the one currently being filled.
1077 current_string_block points to it.
1079 The string_blocks that hold individual large strings
1080 go in a separate chain, started by large_string_blocks. */
1083 /* String blocks contain this many useful bytes.
1084 8188 is power of 2, minus 4 for malloc overhead. */
1085 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1087 /* A string bigger than this gets its own specially-made string block
1088 if it doesn't fit in the current one. */
1089 #define STRING_BLOCK_OUTSIZE 1024
1091 struct string_block_head
1093 struct string_block
*next
, *prev
;
1099 struct string_block
*next
, *prev
;
1101 char chars
[STRING_BLOCK_SIZE
];
1104 /* This points to the string block we are now allocating strings. */
1106 struct string_block
*current_string_block
;
1108 /* This points to the oldest string block, the one that starts the chain. */
1110 struct string_block
*first_string_block
;
1112 /* Last string block in chain of those made for individual large strings. */
1114 struct string_block
*large_string_blocks
;
1116 /* If SIZE is the length of a string, this returns how many bytes
1117 the string occupies in a string_block (including padding). */
1119 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1121 #define PAD (sizeof (EMACS_INT))
1124 #define STRING_FULLSIZE(SIZE) \
1125 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1131 allocating_for_lisp
= 1;
1132 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1133 allocating_for_lisp
= 0;
1134 first_string_block
= current_string_block
;
1135 consing_since_gc
+= sizeof (struct string_block
);
1136 current_string_block
->next
= 0;
1137 current_string_block
->prev
= 0;
1138 current_string_block
->pos
= 0;
1139 large_string_blocks
= 0;
1142 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1143 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1144 Both LENGTH and INIT must be numbers.")
1146 Lisp_Object length
, init
;
1148 register Lisp_Object val
;
1149 register unsigned char *p
, *end
, c
;
1151 CHECK_NATNUM (length
, 0);
1152 CHECK_NUMBER (init
, 1);
1153 val
= make_uninit_string (XFASTINT (length
));
1155 p
= XSTRING (val
)->data
;
1156 end
= p
+ XSTRING (val
)->size
;
1163 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1164 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1165 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1167 Lisp_Object length
, init
;
1169 register Lisp_Object val
;
1170 struct Lisp_Bool_Vector
*p
;
1172 int length_in_chars
, length_in_elts
, bits_per_value
;
1174 CHECK_NATNUM (length
, 0);
1176 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1178 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1179 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1181 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1182 slot `size' of the struct Lisp_Bool_Vector. */
1183 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1184 p
= XBOOL_VECTOR (val
);
1185 /* Get rid of any bits that would cause confusion. */
1187 XSETBOOL_VECTOR (val
, p
);
1188 p
->size
= XFASTINT (length
);
1190 real_init
= (NILP (init
) ? 0 : -1);
1191 for (i
= 0; i
< length_in_chars
; i
++)
1192 p
->data
[i
] = real_init
;
1198 make_string (contents
, length
)
1202 register Lisp_Object val
;
1203 val
= make_uninit_string (length
);
1204 bcopy (contents
, XSTRING (val
)->data
, length
);
1212 return make_string (str
, strlen (str
));
1216 make_uninit_string (length
)
1219 register Lisp_Object val
;
1220 register int fullsize
= STRING_FULLSIZE (length
);
1222 if (length
< 0) abort ();
1224 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1225 /* This string can fit in the current string block */
1228 ((struct Lisp_String
*)
1229 (current_string_block
->chars
+ current_string_block
->pos
)));
1230 current_string_block
->pos
+= fullsize
;
1232 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1233 /* This string gets its own string block */
1235 register struct string_block
*new;
1236 allocating_for_lisp
= 1;
1237 #ifdef DOUG_LEA_MALLOC
1238 /* Prevent mmap'ing the chunk (which is potentially very large). */
1239 mallopt (M_MMAP_MAX
, 0);
1241 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1242 #ifdef DOUG_LEA_MALLOC
1243 /* Back to a reasonable maximum of mmap'ed areas. */
1244 mallopt (M_MMAP_MAX
, 64);
1246 allocating_for_lisp
= 0;
1247 VALIDATE_LISP_STORAGE (new, 0);
1248 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1249 new->pos
= fullsize
;
1250 new->next
= large_string_blocks
;
1251 large_string_blocks
= new;
1253 ((struct Lisp_String
*)
1254 ((struct string_block_head
*)new + 1)));
1257 /* Make a new current string block and start it off with this string */
1259 register struct string_block
*new;
1260 allocating_for_lisp
= 1;
1261 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1262 allocating_for_lisp
= 0;
1263 VALIDATE_LISP_STORAGE (new, sizeof *new);
1264 consing_since_gc
+= sizeof (struct string_block
);
1265 current_string_block
->next
= new;
1266 new->prev
= current_string_block
;
1268 current_string_block
= new;
1269 new->pos
= fullsize
;
1271 (struct Lisp_String
*) current_string_block
->chars
);
1274 string_chars_consed
+= fullsize
;
1275 XSTRING (val
)->size
= length
;
1276 XSTRING (val
)->data
[length
] = 0;
1277 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1282 /* Return a newly created vector or string with specified arguments as
1283 elements. If all the arguments are characters that can fit
1284 in a string of events, make a string; otherwise, make a vector.
1286 Any number of arguments, even zero arguments, are allowed. */
1289 make_event_array (nargs
, args
)
1295 for (i
= 0; i
< nargs
; i
++)
1296 /* The things that fit in a string
1297 are characters that are in 0...127,
1298 after discarding the meta bit and all the bits above it. */
1299 if (!INTEGERP (args
[i
])
1300 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1301 return Fvector (nargs
, args
);
1303 /* Since the loop exited, we know that all the things in it are
1304 characters, so we can make a string. */
1308 result
= Fmake_string (make_number (nargs
), make_number (0));
1309 for (i
= 0; i
< nargs
; i
++)
1311 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1312 /* Move the meta bit to the right place for a string char. */
1313 if (XINT (args
[i
]) & CHAR_META
)
1314 XSTRING (result
)->data
[i
] |= 0x80;
1321 /* Pure storage management. */
1323 /* Must get an error if pure storage is full,
1324 since if it cannot hold a large string
1325 it may be able to hold conses that point to that string;
1326 then the string is not protected from gc. */
1329 make_pure_string (data
, length
)
1333 register Lisp_Object
new;
1334 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1336 if (pureptr
+ size
> PURESIZE
)
1337 error ("Pure Lisp storage exhausted");
1338 XSETSTRING (new, PUREBEG
+ pureptr
);
1339 XSTRING (new)->size
= length
;
1340 bcopy (data
, XSTRING (new)->data
, length
);
1341 XSTRING (new)->data
[length
] = 0;
1343 /* We must give strings in pure storage some kind of interval. So we
1344 give them a null one. */
1345 #if defined (USE_TEXT_PROPERTIES)
1346 XSTRING (new)->intervals
= NULL_INTERVAL
;
1348 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1349 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1354 pure_cons (car
, cdr
)
1355 Lisp_Object car
, cdr
;
1357 register Lisp_Object
new;
1359 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1360 error ("Pure Lisp storage exhausted");
1361 XSETCONS (new, PUREBEG
+ pureptr
);
1362 pureptr
+= sizeof (struct Lisp_Cons
);
1363 XCONS (new)->car
= Fpurecopy (car
);
1364 XCONS (new)->cdr
= Fpurecopy (cdr
);
1368 #ifdef LISP_FLOAT_TYPE
1371 make_pure_float (num
)
1374 register Lisp_Object
new;
1376 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1377 (double) boundary. Some architectures (like the sparc) require
1378 this, and I suspect that floats are rare enough that it's no
1379 tragedy for those that do. */
1382 char *p
= PUREBEG
+ pureptr
;
1386 alignment
= __alignof (struct Lisp_Float
);
1388 alignment
= sizeof (struct Lisp_Float
);
1391 alignment
= sizeof (struct Lisp_Float
);
1393 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1394 pureptr
= p
- PUREBEG
;
1397 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1398 error ("Pure Lisp storage exhausted");
1399 XSETFLOAT (new, PUREBEG
+ pureptr
);
1400 pureptr
+= sizeof (struct Lisp_Float
);
1401 XFLOAT (new)->data
= num
;
1402 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1406 #endif /* LISP_FLOAT_TYPE */
1409 make_pure_vector (len
)
1412 register Lisp_Object
new;
1413 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1415 if (pureptr
+ size
> PURESIZE
)
1416 error ("Pure Lisp storage exhausted");
1418 XSETVECTOR (new, PUREBEG
+ pureptr
);
1420 XVECTOR (new)->size
= len
;
1424 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1425 "Make a copy of OBJECT in pure storage.\n\
1426 Recursively copies contents of vectors and cons cells.\n\
1427 Does not copy symbols.")
1429 register Lisp_Object obj
;
1431 if (NILP (Vpurify_flag
))
1434 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1435 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1439 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1440 #ifdef LISP_FLOAT_TYPE
1441 else if (FLOATP (obj
))
1442 return make_pure_float (XFLOAT (obj
)->data
);
1443 #endif /* LISP_FLOAT_TYPE */
1444 else if (STRINGP (obj
))
1445 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1446 else if (COMPILEDP (obj
) || VECTORP (obj
))
1448 register struct Lisp_Vector
*vec
;
1449 register int i
, size
;
1451 size
= XVECTOR (obj
)->size
;
1452 if (size
& PSEUDOVECTOR_FLAG
)
1453 size
&= PSEUDOVECTOR_SIZE_MASK
;
1454 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1455 for (i
= 0; i
< size
; i
++)
1456 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1457 if (COMPILEDP (obj
))
1458 XSETCOMPILED (obj
, vec
);
1460 XSETVECTOR (obj
, vec
);
1463 else if (MARKERP (obj
))
1464 error ("Attempt to copy a marker to pure storage");
1469 /* Recording what needs to be marked for gc. */
1471 struct gcpro
*gcprolist
;
1473 #define NSTATICS 768
1475 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1479 /* Put an entry in staticvec, pointing at the variable whose address is given */
1482 staticpro (varaddress
)
1483 Lisp_Object
*varaddress
;
1485 staticvec
[staticidx
++] = varaddress
;
1486 if (staticidx
>= NSTATICS
)
1494 struct catchtag
*next
;
1495 /* jmp_buf jmp; /* We don't need this for GC purposes */
1500 struct backtrace
*next
;
1501 Lisp_Object
*function
;
1502 Lisp_Object
*args
; /* Points to vector of args. */
1503 int nargs
; /* length of vector */
1504 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1508 /* Garbage collection! */
1510 /* Temporarily prevent garbage collection. */
1513 inhibit_garbage_collection ()
1515 int count
= specpdl_ptr
- specpdl
;
1517 int nbits
= min (VALBITS
, BITS_PER_INT
);
1519 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1521 specbind (Qgc_cons_threshold
, number
);
1526 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1527 "Reclaim storage for Lisp objects no longer needed.\n\
1528 Returns info on amount of space in use:\n\
1529 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1530 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1531 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1532 Garbage collection happens automatically if you cons more than\n\
1533 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1536 register struct gcpro
*tail
;
1537 register struct specbinding
*bind
;
1538 struct catchtag
*catch;
1539 struct handler
*handler
;
1540 register struct backtrace
*backlist
;
1541 register Lisp_Object tem
;
1542 char *omessage
= echo_area_glyphs
;
1543 int omessage_length
= echo_area_glyphs_length
;
1544 char stack_top_variable
;
1547 /* In case user calls debug_print during GC,
1548 don't let that cause a recursive GC. */
1549 consing_since_gc
= 0;
1551 /* Save a copy of the contents of the stack, for debugging. */
1552 #if MAX_SAVE_STACK > 0
1553 if (NILP (Vpurify_flag
))
1555 i
= &stack_top_variable
- stack_bottom
;
1557 if (i
< MAX_SAVE_STACK
)
1559 if (stack_copy
== 0)
1560 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1561 else if (stack_copy_size
< i
)
1562 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1565 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1566 bcopy (stack_bottom
, stack_copy
, i
);
1568 bcopy (&stack_top_variable
, stack_copy
, i
);
1572 #endif /* MAX_SAVE_STACK > 0 */
1574 if (garbage_collection_messages
)
1575 message1_nolog ("Garbage collecting...");
1577 /* Don't keep command history around forever. */
1578 if (NUMBERP (Vhistory_length
) && XINT (Vhistory_length
) > 0)
1580 tem
= Fnthcdr (Vhistory_length
, Vcommand_history
);
1582 XCONS (tem
)->cdr
= Qnil
;
1585 /* Likewise for undo information. */
1587 register struct buffer
*nextb
= all_buffers
;
1591 /* If a buffer's undo list is Qt, that means that undo is
1592 turned off in that buffer. Calling truncate_undo_list on
1593 Qt tends to return NULL, which effectively turns undo back on.
1594 So don't call truncate_undo_list if undo_list is Qt. */
1595 if (! EQ (nextb
->undo_list
, Qt
))
1597 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1599 nextb
= nextb
->next
;
1605 /* clear_marks (); */
1607 /* In each "large string", set the MARKBIT of the size field.
1608 That enables mark_object to recognize them. */
1610 register struct string_block
*b
;
1611 for (b
= large_string_blocks
; b
; b
= b
->next
)
1612 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1615 /* Mark all the special slots that serve as the roots of accessibility.
1617 Usually the special slots to mark are contained in particular structures.
1618 Then we know no slot is marked twice because the structures don't overlap.
1619 In some cases, the structures point to the slots to be marked.
1620 For these, we use MARKBIT to avoid double marking of the slot. */
1622 for (i
= 0; i
< staticidx
; i
++)
1623 mark_object (staticvec
[i
]);
1624 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1625 for (i
= 0; i
< tail
->nvars
; i
++)
1626 if (!XMARKBIT (tail
->var
[i
]))
1628 mark_object (&tail
->var
[i
]);
1629 XMARK (tail
->var
[i
]);
1631 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1633 mark_object (&bind
->symbol
);
1634 mark_object (&bind
->old_value
);
1636 for (catch = catchlist
; catch; catch = catch->next
)
1638 mark_object (&catch->tag
);
1639 mark_object (&catch->val
);
1641 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1643 mark_object (&handler
->handler
);
1644 mark_object (&handler
->var
);
1646 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1648 if (!XMARKBIT (*backlist
->function
))
1650 mark_object (backlist
->function
);
1651 XMARK (*backlist
->function
);
1653 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1656 i
= backlist
->nargs
- 1;
1658 if (!XMARKBIT (backlist
->args
[i
]))
1660 mark_object (&backlist
->args
[i
]);
1661 XMARK (backlist
->args
[i
]);
1668 /* Clear the mark bits that we set in certain root slots. */
1670 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1671 for (i
= 0; i
< tail
->nvars
; i
++)
1672 XUNMARK (tail
->var
[i
]);
1673 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1675 XUNMARK (*backlist
->function
);
1676 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1679 i
= backlist
->nargs
- 1;
1681 XUNMARK (backlist
->args
[i
]);
1683 XUNMARK (buffer_defaults
.name
);
1684 XUNMARK (buffer_local_symbols
.name
);
1686 /* clear_marks (); */
1689 consing_since_gc
= 0;
1690 if (gc_cons_threshold
< 10000)
1691 gc_cons_threshold
= 10000;
1693 if (garbage_collection_messages
)
1695 if (omessage
|| minibuf_level
> 0)
1696 message2_nolog (omessage
, omessage_length
);
1698 message1_nolog ("Garbage collecting...done");
1701 return Fcons (Fcons (make_number (total_conses
),
1702 make_number (total_free_conses
)),
1703 Fcons (Fcons (make_number (total_symbols
),
1704 make_number (total_free_symbols
)),
1705 Fcons (Fcons (make_number (total_markers
),
1706 make_number (total_free_markers
)),
1707 Fcons (make_number (total_string_size
),
1708 Fcons (make_number (total_vector_size
),
1710 #ifdef LISP_FLOAT_TYPE
1711 (make_number (total_floats
),
1712 make_number (total_free_floats
)),
1713 #else /* not LISP_FLOAT_TYPE */
1714 (make_number (0), make_number (0)),
1715 #endif /* not LISP_FLOAT_TYPE */
1717 #ifdef USE_TEXT_PROPERTIES
1718 (make_number (total_intervals
),
1719 make_number (total_free_intervals
)),
1720 #else /* not USE_TEXT_PROPERTIES */
1721 (make_number (0), make_number (0)),
1722 #endif /* not USE_TEXT_PROPERTIES */
1730 /* Clear marks on all conses */
1732 register struct cons_block
*cblk
;
1733 register int lim
= cons_block_index
;
1735 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1738 for (i
= 0; i
< lim
; i
++)
1739 XUNMARK (cblk
->conses
[i
].car
);
1740 lim
= CONS_BLOCK_SIZE
;
1743 /* Clear marks on all symbols */
1745 register struct symbol_block
*sblk
;
1746 register int lim
= symbol_block_index
;
1748 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1751 for (i
= 0; i
< lim
; i
++)
1753 XUNMARK (sblk
->symbols
[i
].plist
);
1755 lim
= SYMBOL_BLOCK_SIZE
;
1758 /* Clear marks on all markers */
1760 register struct marker_block
*sblk
;
1761 register int lim
= marker_block_index
;
1763 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1766 for (i
= 0; i
< lim
; i
++)
1767 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1768 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1769 lim
= MARKER_BLOCK_SIZE
;
1772 /* Clear mark bits on all buffers */
1774 register struct buffer
*nextb
= all_buffers
;
1778 XUNMARK (nextb
->name
);
1779 nextb
= nextb
->next
;
1785 /* Mark reference to a Lisp_Object.
1786 If the object referred to has not been seen yet, recursively mark
1787 all the references contained in it.
1789 If the object referenced is a short string, the referencing slot
1790 is threaded into a chain of such slots, pointed to from
1791 the `size' field of the string. The actual string size
1792 lives in the last slot in the chain. We recognize the end
1793 because it is < (unsigned) STRING_BLOCK_SIZE. */
1795 #define LAST_MARKED_SIZE 500
1796 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1797 int last_marked_index
;
1800 mark_object (argptr
)
1801 Lisp_Object
*argptr
;
1803 Lisp_Object
*objptr
= argptr
;
1804 register Lisp_Object obj
;
1811 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1812 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1815 last_marked
[last_marked_index
++] = objptr
;
1816 if (last_marked_index
== LAST_MARKED_SIZE
)
1817 last_marked_index
= 0;
1819 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1823 register struct Lisp_String
*ptr
= XSTRING (obj
);
1825 MARK_INTERVAL_TREE (ptr
->intervals
);
1826 if (ptr
->size
& MARKBIT
)
1827 /* A large string. Just set ARRAY_MARK_FLAG. */
1828 ptr
->size
|= ARRAY_MARK_FLAG
;
1831 /* A small string. Put this reference
1832 into the chain of references to it.
1833 If the address includes MARKBIT, put that bit elsewhere
1834 when we store OBJPTR into the size field. */
1836 if (XMARKBIT (*objptr
))
1838 XSETFASTINT (*objptr
, ptr
->size
);
1842 XSETFASTINT (*objptr
, ptr
->size
);
1844 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1846 ptr
->size
= (EMACS_INT
) objptr
;
1847 if (ptr
->size
& MARKBIT
)
1848 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1853 case Lisp_Vectorlike
:
1854 if (GC_BUFFERP (obj
))
1856 if (!XMARKBIT (XBUFFER (obj
)->name
))
1859 else if (GC_SUBRP (obj
))
1861 else if (GC_COMPILEDP (obj
))
1862 /* We could treat this just like a vector, but it is better
1863 to save the COMPILED_CONSTANTS element for last and avoid recursion
1866 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1867 register EMACS_INT size
= ptr
->size
;
1868 /* See comment above under Lisp_Vector. */
1869 struct Lisp_Vector
*volatile ptr1
= ptr
;
1872 if (size
& ARRAY_MARK_FLAG
)
1873 break; /* Already marked */
1874 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1875 size
&= PSEUDOVECTOR_SIZE_MASK
;
1876 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1878 if (i
!= COMPILED_CONSTANTS
)
1879 mark_object (&ptr1
->contents
[i
]);
1881 /* This cast should be unnecessary, but some Mips compiler complains
1882 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1883 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1886 else if (GC_FRAMEP (obj
))
1888 /* See comment above under Lisp_Vector for why this is volatile. */
1889 register struct frame
*volatile ptr
= XFRAME (obj
);
1890 register EMACS_INT size
= ptr
->size
;
1892 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1893 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1895 mark_object (&ptr
->name
);
1896 mark_object (&ptr
->icon_name
);
1897 mark_object (&ptr
->title
);
1898 mark_object (&ptr
->focus_frame
);
1899 mark_object (&ptr
->selected_window
);
1900 mark_object (&ptr
->minibuffer_window
);
1901 mark_object (&ptr
->param_alist
);
1902 mark_object (&ptr
->scroll_bars
);
1903 mark_object (&ptr
->condemned_scroll_bars
);
1904 mark_object (&ptr
->menu_bar_items
);
1905 mark_object (&ptr
->face_alist
);
1906 mark_object (&ptr
->menu_bar_vector
);
1907 mark_object (&ptr
->buffer_predicate
);
1908 mark_object (&ptr
->buffer_list
);
1910 else if (GC_BOOL_VECTOR_P (obj
))
1912 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1914 if (ptr
->size
& ARRAY_MARK_FLAG
)
1915 break; /* Already marked */
1916 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1920 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1921 register EMACS_INT size
= ptr
->size
;
1922 /* The reason we use ptr1 is to avoid an apparent hardware bug
1923 that happens occasionally on the FSF's HP 300s.
1924 The bug is that a2 gets clobbered by recursive calls to mark_object.
1925 The clobberage seems to happen during function entry,
1926 perhaps in the moveml instruction.
1927 Yes, this is a crock, but we have to do it. */
1928 struct Lisp_Vector
*volatile ptr1
= ptr
;
1931 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1932 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1933 if (size
& PSEUDOVECTOR_FLAG
)
1934 size
&= PSEUDOVECTOR_SIZE_MASK
;
1935 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1936 mark_object (&ptr1
->contents
[i
]);
1942 /* See comment above under Lisp_Vector for why this is volatile. */
1943 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1944 struct Lisp_Symbol
*ptrx
;
1946 if (XMARKBIT (ptr
->plist
)) break;
1948 mark_object ((Lisp_Object
*) &ptr
->value
);
1949 mark_object (&ptr
->function
);
1950 mark_object (&ptr
->plist
);
1951 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1952 mark_object (&ptr
->name
);
1956 /* For the benefit of the last_marked log. */
1957 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1958 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1959 XSETSYMBOL (obj
, ptrx
);
1960 /* We can't goto loop here because *objptr doesn't contain an
1961 actual Lisp_Object with valid datatype field. */
1968 switch (XMISCTYPE (obj
))
1970 case Lisp_Misc_Marker
:
1971 XMARK (XMARKER (obj
)->chain
);
1972 /* DO NOT mark thru the marker's chain.
1973 The buffer's markers chain does not preserve markers from gc;
1974 instead, markers are removed from the chain when freed by gc. */
1977 case Lisp_Misc_Buffer_Local_Value
:
1978 case Lisp_Misc_Some_Buffer_Local_Value
:
1980 register struct Lisp_Buffer_Local_Value
*ptr
1981 = XBUFFER_LOCAL_VALUE (obj
);
1982 if (XMARKBIT (ptr
->car
)) break;
1984 /* If the cdr is nil, avoid recursion for the car. */
1985 if (EQ (ptr
->cdr
, Qnil
))
1990 mark_object (&ptr
->car
);
1991 /* See comment above under Lisp_Vector for why not use ptr here. */
1992 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1996 case Lisp_Misc_Intfwd
:
1997 case Lisp_Misc_Boolfwd
:
1998 case Lisp_Misc_Objfwd
:
1999 case Lisp_Misc_Buffer_Objfwd
:
2000 case Lisp_Misc_Kboard_Objfwd
:
2001 /* Don't bother with Lisp_Buffer_Objfwd,
2002 since all markable slots in current buffer marked anyway. */
2003 /* Don't need to do Lisp_Objfwd, since the places they point
2004 are protected with staticpro. */
2007 case Lisp_Misc_Overlay
:
2009 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2010 if (!XMARKBIT (ptr
->plist
))
2013 mark_object (&ptr
->start
);
2014 mark_object (&ptr
->end
);
2015 objptr
= &ptr
->plist
;
2028 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2029 if (XMARKBIT (ptr
->car
)) break;
2031 /* If the cdr is nil, avoid recursion for the car. */
2032 if (EQ (ptr
->cdr
, Qnil
))
2037 mark_object (&ptr
->car
);
2038 /* See comment above under Lisp_Vector for why not use ptr here. */
2039 objptr
= &XCONS (obj
)->cdr
;
2043 #ifdef LISP_FLOAT_TYPE
2045 XMARK (XFLOAT (obj
)->type
);
2047 #endif /* LISP_FLOAT_TYPE */
2057 /* Mark the pointers in a buffer structure. */
2063 register struct buffer
*buffer
= XBUFFER (buf
);
2064 register Lisp_Object
*ptr
;
2065 Lisp_Object base_buffer
;
2067 /* This is the buffer's markbit */
2068 mark_object (&buffer
->name
);
2069 XMARK (buffer
->name
);
2071 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2074 mark_object (buffer
->syntax_table
);
2076 /* Mark the various string-pointers in the buffer object.
2077 Since the strings may be relocated, we must mark them
2078 in their actual slots. So gc_sweep must convert each slot
2079 back to an ordinary C pointer. */
2080 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2081 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2082 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2083 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2085 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2086 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2087 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2088 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2091 for (ptr
= &buffer
->name
+ 1;
2092 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2096 /* If this is an indirect buffer, mark its base buffer. */
2097 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2099 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2100 mark_buffer (base_buffer
);
2105 /* Mark the pointers in the kboard objects. */
2112 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2114 if (kb
->kbd_macro_buffer
)
2115 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2117 mark_object (&kb
->Vprefix_arg
);
2118 mark_object (&kb
->kbd_queue
);
2119 mark_object (&kb
->Vlast_kbd_macro
);
2120 mark_object (&kb
->Vsystem_key_alist
);
2121 mark_object (&kb
->system_key_syms
);
2125 /* Sweep: find all structures not marked, and free them. */
2130 total_string_size
= 0;
2133 /* Put all unmarked conses on free list */
2135 register struct cons_block
*cblk
;
2136 struct cons_block
**cprev
= &cons_block
;
2137 register int lim
= cons_block_index
;
2138 register int num_free
= 0, num_used
= 0;
2142 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2146 for (i
= 0; i
< lim
; i
++)
2147 if (!XMARKBIT (cblk
->conses
[i
].car
))
2151 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2152 cons_free_list
= &cblk
->conses
[i
];
2157 XUNMARK (cblk
->conses
[i
].car
);
2159 lim
= CONS_BLOCK_SIZE
;
2160 /* If this block contains only free conses and we have already
2161 seen more than two blocks worth of free conses then deallocate
2163 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> 2*CONS_BLOCK_SIZE
)
2165 num_free
-= CONS_BLOCK_SIZE
;
2166 *cprev
= cblk
->next
;
2167 /* Unhook from the free list. */
2168 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2172 cprev
= &cblk
->next
;
2174 total_conses
= num_used
;
2175 total_free_conses
= num_free
;
2178 #ifdef LISP_FLOAT_TYPE
2179 /* Put all unmarked floats on free list */
2181 register struct float_block
*fblk
;
2182 struct float_block
**fprev
= &float_block
;
2183 register int lim
= float_block_index
;
2184 register int num_free
= 0, num_used
= 0;
2186 float_free_list
= 0;
2188 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2192 for (i
= 0; i
< lim
; i
++)
2193 if (!XMARKBIT (fblk
->floats
[i
].type
))
2197 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2198 float_free_list
= &fblk
->floats
[i
];
2203 XUNMARK (fblk
->floats
[i
].type
);
2205 lim
= FLOAT_BLOCK_SIZE
;
2206 /* If this block contains only free floats and we have already
2207 seen more than two blocks worth of free floats then deallocate
2209 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> 2*FLOAT_BLOCK_SIZE
)
2211 num_free
-= FLOAT_BLOCK_SIZE
;
2212 *fprev
= fblk
->next
;
2213 /* Unhook from the free list. */
2214 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2218 fprev
= &fblk
->next
;
2220 total_floats
= num_used
;
2221 total_free_floats
= num_free
;
2223 #endif /* LISP_FLOAT_TYPE */
2225 #ifdef USE_TEXT_PROPERTIES
2226 /* Put all unmarked intervals on free list */
2228 register struct interval_block
*iblk
;
2229 struct interval_block
**iprev
= &interval_block
;
2230 register int lim
= interval_block_index
;
2231 register int num_free
= 0, num_used
= 0;
2233 interval_free_list
= 0;
2235 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2240 for (i
= 0; i
< lim
; i
++)
2242 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2244 iblk
->intervals
[i
].parent
= interval_free_list
;
2245 interval_free_list
= &iblk
->intervals
[i
];
2252 XUNMARK (iblk
->intervals
[i
].plist
);
2255 lim
= INTERVAL_BLOCK_SIZE
;
2256 /* If this block contains only free intervals and we have already
2257 seen more than two blocks worth of free intervals then
2258 deallocate this block. */
2259 if (this_free
== INTERVAL_BLOCK_SIZE
2260 && num_free
> 2*INTERVAL_BLOCK_SIZE
)
2262 num_free
-= INTERVAL_BLOCK_SIZE
;
2263 *iprev
= iblk
->next
;
2264 /* Unhook from the free list. */
2265 interval_free_list
= iblk
->intervals
[0].parent
;
2269 iprev
= &iblk
->next
;
2271 total_intervals
= num_used
;
2272 total_free_intervals
= num_free
;
2274 #endif /* USE_TEXT_PROPERTIES */
2276 /* Put all unmarked symbols on free list */
2278 register struct symbol_block
*sblk
;
2279 struct symbol_block
**sprev
= &symbol_block
;
2280 register int lim
= symbol_block_index
;
2281 register int num_free
= 0, num_used
= 0;
2283 symbol_free_list
= 0;
2285 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2289 for (i
= 0; i
< lim
; i
++)
2290 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2292 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2293 symbol_free_list
= &sblk
->symbols
[i
];
2300 sblk
->symbols
[i
].name
2301 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2302 XUNMARK (sblk
->symbols
[i
].plist
);
2304 lim
= SYMBOL_BLOCK_SIZE
;
2305 /* If this block contains only free symbols and we have already
2306 seen more than two blocks worth of free symbols then deallocate
2308 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> 2*SYMBOL_BLOCK_SIZE
)
2310 num_free
-= SYMBOL_BLOCK_SIZE
;
2311 *sprev
= sblk
->next
;
2312 /* Unhook from the free list. */
2313 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2317 sprev
= &sblk
->next
;
2319 total_symbols
= num_used
;
2320 total_free_symbols
= num_free
;
2324 /* Put all unmarked markers on free list.
2325 Unchain each one first from the buffer it points into,
2326 but only if it's a real marker. */
2328 register struct marker_block
*mblk
;
2329 struct marker_block
**mprev
= &marker_block
;
2330 register int lim
= marker_block_index
;
2331 register int num_free
= 0, num_used
= 0;
2333 marker_free_list
= 0;
2335 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2339 EMACS_INT already_free
= -1;
2341 for (i
= 0; i
< lim
; i
++)
2343 Lisp_Object
*markword
;
2344 switch (mblk
->markers
[i
].u_marker
.type
)
2346 case Lisp_Misc_Marker
:
2347 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2349 case Lisp_Misc_Buffer_Local_Value
:
2350 case Lisp_Misc_Some_Buffer_Local_Value
:
2351 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2353 case Lisp_Misc_Overlay
:
2354 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2356 case Lisp_Misc_Free
:
2357 /* If the object was already free, keep it
2358 on the free list. */
2359 markword
= (Lisp_Object
*) &already_free
;
2365 if (markword
&& !XMARKBIT (*markword
))
2368 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2370 /* tem1 avoids Sun compiler bug */
2371 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2372 XSETMARKER (tem
, tem1
);
2373 unchain_marker (tem
);
2375 /* Set the type of the freed object to Lisp_Misc_Free.
2376 We could leave the type alone, since nobody checks it,
2377 but this might catch bugs faster. */
2378 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2379 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2380 marker_free_list
= &mblk
->markers
[i
];
2388 XUNMARK (*markword
);
2391 lim
= MARKER_BLOCK_SIZE
;
2392 /* If this block contains only free markers and we have already
2393 seen more than two blocks worth of free markers then deallocate
2395 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> 2*MARKER_BLOCK_SIZE
)
2397 num_free
-= MARKER_BLOCK_SIZE
;
2398 *mprev
= mblk
->next
;
2399 /* Unhook from the free list. */
2400 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2404 mprev
= &mblk
->next
;
2407 total_markers
= num_used
;
2408 total_free_markers
= num_free
;
2411 /* Free all unmarked buffers */
2413 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2416 if (!XMARKBIT (buffer
->name
))
2419 prev
->next
= buffer
->next
;
2421 all_buffers
= buffer
->next
;
2422 next
= buffer
->next
;
2428 XUNMARK (buffer
->name
);
2429 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2432 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2433 for purposes of marking and relocation.
2434 Turn them back into C pointers now. */
2435 buffer
->upcase_table
2436 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2437 buffer
->downcase_table
2438 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2440 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2441 buffer
->folding_sort_table
2442 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2445 prev
= buffer
, buffer
= buffer
->next
;
2449 #endif /* standalone */
2451 /* Free all unmarked vectors */
2453 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2454 total_vector_size
= 0;
2457 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2460 prev
->next
= vector
->next
;
2462 all_vectors
= vector
->next
;
2463 next
= vector
->next
;
2469 vector
->size
&= ~ARRAY_MARK_FLAG
;
2470 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2471 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2473 total_vector_size
+= vector
->size
;
2474 prev
= vector
, vector
= vector
->next
;
2478 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2480 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2481 struct Lisp_String
*s
;
2485 s
= (struct Lisp_String
*) &sb
->chars
[0];
2486 if (s
->size
& ARRAY_MARK_FLAG
)
2488 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2489 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2490 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2491 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2492 prev
= sb
, sb
= sb
->next
;
2497 prev
->next
= sb
->next
;
2499 large_string_blocks
= sb
->next
;
2508 /* Compactify strings, relocate references, and free empty string blocks. */
2513 /* String block of old strings we are scanning. */
2514 register struct string_block
*from_sb
;
2515 /* A preceding string block (or maybe the same one)
2516 where we are copying the still-live strings to. */
2517 register struct string_block
*to_sb
;
2521 to_sb
= first_string_block
;
2524 /* Scan each existing string block sequentially, string by string. */
2525 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2528 /* POS is the index of the next string in the block. */
2529 while (pos
< from_sb
->pos
)
2531 register struct Lisp_String
*nextstr
2532 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2534 register struct Lisp_String
*newaddr
;
2535 register EMACS_INT size
= nextstr
->size
;
2537 /* NEXTSTR is the old address of the next string.
2538 Just skip it if it isn't marked. */
2539 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2541 /* It is marked, so its size field is really a chain of refs.
2542 Find the end of the chain, where the actual size lives. */
2543 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2545 if (size
& DONT_COPY_FLAG
)
2546 size
^= MARKBIT
| DONT_COPY_FLAG
;
2547 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2550 total_string_size
+= size
;
2552 /* If it won't fit in TO_SB, close it out,
2553 and move to the next sb. Keep doing so until
2554 TO_SB reaches a large enough, empty enough string block.
2555 We know that TO_SB cannot advance past FROM_SB here
2556 since FROM_SB is large enough to contain this string.
2557 Any string blocks skipped here
2558 will be patched out and freed later. */
2559 while (to_pos
+ STRING_FULLSIZE (size
)
2560 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2562 to_sb
->pos
= to_pos
;
2563 to_sb
= to_sb
->next
;
2566 /* Compute new address of this string
2567 and update TO_POS for the space being used. */
2568 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2569 to_pos
+= STRING_FULLSIZE (size
);
2571 /* Copy the string itself to the new place. */
2572 if (nextstr
!= newaddr
)
2573 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2574 + INTERVAL_PTR_SIZE
);
2576 /* Go through NEXTSTR's chain of references
2577 and make each slot in the chain point to
2578 the new address of this string. */
2579 size
= newaddr
->size
;
2580 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2582 register Lisp_Object
*objptr
;
2583 if (size
& DONT_COPY_FLAG
)
2584 size
^= MARKBIT
| DONT_COPY_FLAG
;
2585 objptr
= (Lisp_Object
*)size
;
2587 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2588 if (XMARKBIT (*objptr
))
2590 XSETSTRING (*objptr
, newaddr
);
2594 XSETSTRING (*objptr
, newaddr
);
2596 /* Store the actual size in the size field. */
2597 newaddr
->size
= size
;
2599 #ifdef USE_TEXT_PROPERTIES
2600 /* Now that the string has been relocated, rebalance its
2601 interval tree, and update the tree's parent pointer. */
2602 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2604 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2605 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2608 #endif /* USE_TEXT_PROPERTIES */
2610 pos
+= STRING_FULLSIZE (size
);
2614 /* Close out the last string block still used and free any that follow. */
2615 to_sb
->pos
= to_pos
;
2616 current_string_block
= to_sb
;
2618 from_sb
= to_sb
->next
;
2622 to_sb
= from_sb
->next
;
2627 /* Free any empty string blocks further back in the chain.
2628 This loop will never free first_string_block, but it is very
2629 unlikely that that one will become empty, so why bother checking? */
2631 from_sb
= first_string_block
;
2632 while (to_sb
= from_sb
->next
)
2634 if (to_sb
->pos
== 0)
2636 if (from_sb
->next
= to_sb
->next
)
2637 from_sb
->next
->prev
= from_sb
;
2645 /* Debugging aids. */
2647 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2648 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2649 This may be helpful in debugging Emacs's memory usage.\n\
2650 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2655 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2660 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2661 "Return a list of counters that measure how much consing there has been.\n\
2662 Each of these counters increments for a certain kind of object.\n\
2663 The counters wrap around from the largest positive integer to zero.\n\
2664 Garbage collection does not decrease them.\n\
2665 The elements of the value are as follows:\n\
2666 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2667 All are in units of 1 = one object consed\n\
2668 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2670 MISCS include overlays, markers, and some internal types.\n\
2671 Frames, windows, buffers, and subprocesses count as vectors\n\
2672 (but the contents of a buffer's text do not count here).")
2675 Lisp_Object lisp_cons_cells_consed
;
2676 Lisp_Object lisp_floats_consed
;
2677 Lisp_Object lisp_vector_cells_consed
;
2678 Lisp_Object lisp_symbols_consed
;
2679 Lisp_Object lisp_string_chars_consed
;
2680 Lisp_Object lisp_misc_objects_consed
;
2681 Lisp_Object lisp_intervals_consed
;
2683 XSETINT (lisp_cons_cells_consed
,
2684 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2685 XSETINT (lisp_floats_consed
,
2686 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2687 XSETINT (lisp_vector_cells_consed
,
2688 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2689 XSETINT (lisp_symbols_consed
,
2690 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2691 XSETINT (lisp_string_chars_consed
,
2692 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2693 XSETINT (lisp_misc_objects_consed
,
2694 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2695 XSETINT (lisp_intervals_consed
,
2696 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2698 return Fcons (lisp_cons_cells_consed
,
2699 Fcons (lisp_floats_consed
,
2700 Fcons (lisp_vector_cells_consed
,
2701 Fcons (lisp_symbols_consed
,
2702 Fcons (lisp_string_chars_consed
,
2703 Fcons (lisp_misc_objects_consed
,
2704 Fcons (lisp_intervals_consed
,
2708 /* Initialization */
2712 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2715 pure_size
= PURESIZE
;
2718 ignore_warnings
= 1;
2719 #ifdef DOUG_LEA_MALLOC
2720 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2721 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2722 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2728 #ifdef LISP_FLOAT_TYPE
2730 #endif /* LISP_FLOAT_TYPE */
2734 malloc_hysteresis
= 32;
2736 malloc_hysteresis
= 0;
2739 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2741 ignore_warnings
= 0;
2744 consing_since_gc
= 0;
2745 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2746 #ifdef VIRT_ADDR_VARIES
2747 malloc_sbrk_unused
= 1<<22; /* A large number */
2748 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2749 #endif /* VIRT_ADDR_VARIES */
2760 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2761 "*Number of bytes of consing between garbage collections.\n\
2762 Garbage collection can happen automatically once this many bytes have been\n\
2763 allocated since the last garbage collection. All data types count.\n\n\
2764 Garbage collection happens automatically only when `eval' is called.\n\n\
2765 By binding this temporarily to a large number, you can effectively\n\
2766 prevent garbage collection during a part of the program.");
2768 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2769 "Number of bytes of sharable Lisp data allocated so far.");
2771 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2772 "Number of cons cells that have been consed so far.");
2774 DEFVAR_INT ("floats-consed", &floats_consed
,
2775 "Number of floats that have been consed so far.");
2777 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2778 "Number of vector cells that have been consed so far.");
2780 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2781 "Number of symbols that have been consed so far.");
2783 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2784 "Number of string characters that have been consed so far.");
2786 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2787 "Number of miscellaneous objects that have been consed so far.");
2789 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2790 "Number of intervals that have been consed so far.");
2793 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2794 "Number of bytes of unshared memory allocated in this session.");
2796 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2797 "Number of bytes of unshared memory remaining available in this session.");
2800 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2801 "Non-nil means loading Lisp code in order to dump an executable.\n\
2802 This means that certain objects should be allocated in shared (pure) space.");
2804 DEFVAR_INT ("undo-limit", &undo_limit
,
2805 "Keep no more undo information once it exceeds this size.\n\
2806 This limit is applied when garbage collection happens.\n\
2807 The size is counted as the number of bytes occupied,\n\
2808 which includes both saved text and other data.");
2811 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2812 "Don't keep more than this much size of undo information.\n\
2813 A command which pushes past this size is itself forgotten.\n\
2814 This limit is applied when garbage collection happens.\n\
2815 The size is counted as the number of bytes occupied,\n\
2816 which includes both saved text and other data.");
2817 undo_strong_limit
= 30000;
2819 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2820 "Non-nil means display messages at start and end of garbage collection.");
2821 garbage_collection_messages
= 0;
2823 /* We build this in advance because if we wait until we need it, we might
2824 not be able to allocate the memory to hold it. */
2826 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2827 staticpro (&memory_signal_data
);
2829 staticpro (&Qgc_cons_threshold
);
2830 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2832 staticpro (&Qchar_table_extra_slots
);
2833 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2838 defsubr (&Smake_byte_code
);
2839 defsubr (&Smake_list
);
2840 defsubr (&Smake_vector
);
2841 defsubr (&Smake_char_table
);
2842 defsubr (&Smake_string
);
2843 defsubr (&Smake_bool_vector
);
2844 defsubr (&Smake_symbol
);
2845 defsubr (&Smake_marker
);
2846 defsubr (&Spurecopy
);
2847 defsubr (&Sgarbage_collect
);
2848 defsubr (&Smemory_limit
);
2849 defsubr (&Smemory_use_counts
);