1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Note that this declares bzero on OSF/1. How dumb. */
27 #include "intervals.h"
33 #include "blockinput.h"
38 #include "syssignal.h"
42 #ifdef DOUG_LEA_MALLOC
44 #define __malloc_size_t int
46 /* The following come from gmalloc.c. */
48 #if defined (__STDC__) && __STDC__
50 #define __malloc_size_t size_t
52 #define __malloc_size_t unsigned int
54 extern __malloc_size_t _bytes_used
;
55 extern int __malloc_extra_blocks
;
56 #endif /* !defined(DOUG_LEA_MALLOC) */
58 extern Lisp_Object Vhistory_length
;
60 #define max(A,B) ((A) > (B) ? (A) : (B))
61 #define min(A,B) ((A) < (B) ? (A) : (B))
63 /* Macro to verify that storage intended for Lisp objects is not
64 out of range to fit in the space for a pointer.
65 ADDRESS is the start of the block, and SIZE
66 is the amount of space within which objects can start. */
67 #define VALIDATE_LISP_STORAGE(address, size) \
71 XSETCONS (val, (char *) address + size); \
72 if ((char *) XCONS (val) != (char *) address + size) \
79 /* Value of _bytes_used, when spare_memory was freed. */
80 static __malloc_size_t bytes_used_when_full
;
82 /* Number of bytes of consing done since the last gc */
85 /* Count the amount of consing of various sorts of space. */
86 int cons_cells_consed
;
88 int vector_cells_consed
;
90 int string_chars_consed
;
91 int misc_objects_consed
;
94 /* Number of bytes of consing since gc before another gc should be done. */
95 int gc_cons_threshold
;
97 /* Nonzero during gc */
100 /* Nonzero means display messages at beginning and end of GC. */
101 int garbage_collection_messages
;
103 #ifndef VIRT_ADDR_VARIES
105 #endif /* VIRT_ADDR_VARIES */
106 int malloc_sbrk_used
;
108 #ifndef VIRT_ADDR_VARIES
110 #endif /* VIRT_ADDR_VARIES */
111 int malloc_sbrk_unused
;
113 /* Two limits controlling how much undo information to keep. */
115 int undo_strong_limit
;
117 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
118 int total_free_conses
, total_free_markers
, total_free_symbols
;
119 #ifdef LISP_FLOAT_TYPE
120 int total_free_floats
, total_floats
;
121 #endif /* LISP_FLOAT_TYPE */
123 /* Points to memory space allocated as "spare",
124 to be freed if we run out of memory. */
125 static char *spare_memory
;
127 /* Amount of spare memory to keep in reserve. */
128 #define SPARE_MEMORY (1 << 14)
130 /* Number of extra blocks malloc should get when it needs more core. */
131 static int malloc_hysteresis
;
133 /* Nonzero when malloc is called for allocating Lisp object space. */
134 int allocating_for_lisp
;
136 /* Non-nil means defun should do purecopy on the function definition */
137 Lisp_Object Vpurify_flag
;
140 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
141 #define PUREBEG (char *) pure
143 #define pure PURE_SEG_BITS /* Use shared memory segment */
144 #define PUREBEG (char *)PURE_SEG_BITS
146 /* This variable is used only by the XPNTR macro when HAVE_SHM is
147 defined. If we used the PURESIZE macro directly there, that would
148 make most of emacs dependent on puresize.h, which we don't want -
149 you should be able to change that without too much recompilation.
150 So map_in_data initializes pure_size, and the dependencies work
153 #endif /* not HAVE_SHM */
155 /* Index in pure at which next pure object will be allocated. */
158 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
159 char *pending_malloc_warning
;
161 /* Pre-computed signal argument for use when memory is exhausted. */
162 Lisp_Object memory_signal_data
;
164 /* Maximum amount of C stack to save when a GC happens. */
166 #ifndef MAX_SAVE_STACK
167 #define MAX_SAVE_STACK 16000
170 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
171 pointer to a Lisp_Object, when that pointer is viewed as an integer.
172 (On most machines, pointers are even, so we can use the low bit.
173 Word-addressable architectures may need to override this in the m-file.)
174 When linking references to small strings through the size field, we
175 use this slot to hold the bit that would otherwise be interpreted as
177 #ifndef DONT_COPY_FLAG
178 #define DONT_COPY_FLAG 1
179 #endif /* no DONT_COPY_FLAG */
181 /* Buffer in which we save a copy of the C stack at each GC. */
186 /* Non-zero means ignore malloc warnings. Set during initialization. */
189 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
191 static void mark_object (), mark_buffer (), mark_kboards ();
192 static void clear_marks (), gc_sweep ();
193 static void compact_strings ();
195 extern int message_enable_multibyte
;
197 /* Versions of malloc and realloc that print warnings as memory gets full. */
200 malloc_warning_1 (str
)
203 Fprinc (str
, Vstandard_output
);
204 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
205 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
206 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
210 /* malloc calls this if it finds we are near exhausting storage */
216 pending_malloc_warning
= str
;
220 display_malloc_warning ()
222 register Lisp_Object val
;
224 val
= build_string (pending_malloc_warning
);
225 pending_malloc_warning
= 0;
226 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
229 #ifdef DOUG_LEA_MALLOC
230 # define BYTES_USED (mallinfo ().arena)
232 # define BYTES_USED _bytes_used
235 /* Called if malloc returns zero */
240 #ifndef SYSTEM_MALLOC
241 bytes_used_when_full
= BYTES_USED
;
244 /* The first time we get here, free the spare memory. */
251 /* This used to call error, but if we've run out of memory, we could get
252 infinite recursion trying to build the string. */
254 Fsignal (Qnil
, memory_signal_data
);
257 /* Called if we can't allocate relocatable space for a buffer. */
260 buffer_memory_full ()
262 /* If buffers use the relocating allocator,
263 no need to free spare_memory, because we may have plenty of malloc
264 space left that we could get, and if we don't, the malloc that fails
265 will itself cause spare_memory to be freed.
266 If buffers don't use the relocating allocator,
267 treat this like any other failing malloc. */
273 /* This used to call error, but if we've run out of memory, we could get
274 infinite recursion trying to build the string. */
276 Fsignal (Qerror
, memory_signal_data
);
279 /* like malloc routines but check for no memory and block interrupt input. */
288 val
= (long *) malloc (size
);
291 if (!val
&& size
) memory_full ();
296 xrealloc (block
, size
)
303 /* We must call malloc explicitly when BLOCK is 0, since some
304 reallocs don't do this. */
306 val
= (long *) malloc (size
);
308 val
= (long *) realloc (block
, size
);
311 if (!val
&& size
) memory_full ();
325 /* Arranging to disable input signals while we're in malloc.
327 This only works with GNU malloc. To help out systems which can't
328 use GNU malloc, all the calls to malloc, realloc, and free
329 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
330 pairs; unfortunately, we have no idea what C library functions
331 might call malloc, so we can't really protect them unless you're
332 using GNU malloc. Fortunately, most of the major operating can use
335 #ifndef SYSTEM_MALLOC
336 extern void * (*__malloc_hook
) ();
337 static void * (*old_malloc_hook
) ();
338 extern void * (*__realloc_hook
) ();
339 static void * (*old_realloc_hook
) ();
340 extern void (*__free_hook
) ();
341 static void (*old_free_hook
) ();
343 /* This function is used as the hook for free to call. */
346 emacs_blocked_free (ptr
)
350 __free_hook
= old_free_hook
;
352 /* If we released our reserve (due to running out of memory),
353 and we have a fair amount free once again,
354 try to set aside another reserve in case we run out once more. */
355 if (spare_memory
== 0
356 /* Verify there is enough space that even with the malloc
357 hysteresis this call won't run out again.
358 The code here is correct as long as SPARE_MEMORY
359 is substantially larger than the block size malloc uses. */
360 && (bytes_used_when_full
361 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
362 spare_memory
= (char *) malloc (SPARE_MEMORY
);
364 __free_hook
= emacs_blocked_free
;
368 /* If we released our reserve (due to running out of memory),
369 and we have a fair amount free once again,
370 try to set aside another reserve in case we run out once more.
372 This is called when a relocatable block is freed in ralloc.c. */
375 refill_memory_reserve ()
377 if (spare_memory
== 0)
378 spare_memory
= (char *) malloc (SPARE_MEMORY
);
381 /* This function is the malloc hook that Emacs uses. */
384 emacs_blocked_malloc (size
)
390 __malloc_hook
= old_malloc_hook
;
391 #ifdef DOUG_LEA_MALLOC
392 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
394 __malloc_extra_blocks
= malloc_hysteresis
;
396 value
= (void *) malloc (size
);
397 __malloc_hook
= emacs_blocked_malloc
;
404 emacs_blocked_realloc (ptr
, size
)
411 __realloc_hook
= old_realloc_hook
;
412 value
= (void *) realloc (ptr
, size
);
413 __realloc_hook
= emacs_blocked_realloc
;
420 uninterrupt_malloc ()
422 old_free_hook
= __free_hook
;
423 __free_hook
= emacs_blocked_free
;
425 old_malloc_hook
= __malloc_hook
;
426 __malloc_hook
= emacs_blocked_malloc
;
428 old_realloc_hook
= __realloc_hook
;
429 __realloc_hook
= emacs_blocked_realloc
;
433 /* Interval allocation. */
435 #ifdef USE_TEXT_PROPERTIES
436 #define INTERVAL_BLOCK_SIZE \
437 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
439 struct interval_block
441 struct interval_block
*next
;
442 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
445 struct interval_block
*interval_block
;
446 static int interval_block_index
;
448 INTERVAL interval_free_list
;
453 allocating_for_lisp
= 1;
455 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
456 allocating_for_lisp
= 0;
457 interval_block
->next
= 0;
458 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
459 interval_block_index
= 0;
460 interval_free_list
= 0;
463 #define INIT_INTERVALS init_intervals ()
470 if (interval_free_list
)
472 val
= interval_free_list
;
473 interval_free_list
= interval_free_list
->parent
;
477 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
479 register struct interval_block
*newi
;
481 allocating_for_lisp
= 1;
482 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
484 allocating_for_lisp
= 0;
485 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
486 newi
->next
= interval_block
;
487 interval_block
= newi
;
488 interval_block_index
= 0;
490 val
= &interval_block
->intervals
[interval_block_index
++];
492 consing_since_gc
+= sizeof (struct interval
);
494 RESET_INTERVAL (val
);
498 static int total_free_intervals
, total_intervals
;
500 /* Mark the pointers of one interval. */
503 mark_interval (i
, dummy
)
507 if (XMARKBIT (i
->plist
))
509 mark_object (&i
->plist
);
514 mark_interval_tree (tree
)
515 register INTERVAL tree
;
517 /* No need to test if this tree has been marked already; this
518 function is always called through the MARK_INTERVAL_TREE macro,
519 which takes care of that. */
521 /* XMARK expands to an assignment; the LHS of an assignment can't be
523 XMARK (* (Lisp_Object
*) &tree
->parent
);
525 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
528 #define MARK_INTERVAL_TREE(i) \
530 if (!NULL_INTERVAL_P (i) \
531 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
532 mark_interval_tree (i); \
535 /* The oddity in the call to XUNMARK is necessary because XUNMARK
536 expands to an assignment to its argument, and most C compilers don't
537 support casts on the left operand of `='. */
538 #define UNMARK_BALANCE_INTERVALS(i) \
540 if (! NULL_INTERVAL_P (i)) \
542 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
543 (i) = balance_intervals (i); \
547 #else /* no interval use */
549 #define INIT_INTERVALS
551 #define UNMARK_BALANCE_INTERVALS(i)
552 #define MARK_INTERVAL_TREE(i)
554 #endif /* no interval use */
556 /* Floating point allocation. */
558 #ifdef LISP_FLOAT_TYPE
559 /* Allocation of float cells, just like conses */
560 /* We store float cells inside of float_blocks, allocating a new
561 float_block with malloc whenever necessary. Float cells reclaimed by
562 GC are put on a free list to be reallocated before allocating
563 any new float cells from the latest float_block.
565 Each float_block is just under 1020 bytes long,
566 since malloc really allocates in units of powers of two
567 and uses 4 bytes for its own overhead. */
569 #define FLOAT_BLOCK_SIZE \
570 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
574 struct float_block
*next
;
575 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
578 struct float_block
*float_block
;
579 int float_block_index
;
581 struct Lisp_Float
*float_free_list
;
586 allocating_for_lisp
= 1;
587 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
588 allocating_for_lisp
= 0;
589 float_block
->next
= 0;
590 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
591 float_block_index
= 0;
595 /* Explicitly free a float cell. */
597 struct Lisp_Float
*ptr
;
599 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
600 float_free_list
= ptr
;
604 make_float (float_value
)
607 register Lisp_Object val
;
611 /* We use the data field for chaining the free list
612 so that we won't use the same field that has the mark bit. */
613 XSETFLOAT (val
, float_free_list
);
614 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
618 if (float_block_index
== FLOAT_BLOCK_SIZE
)
620 register struct float_block
*new;
622 allocating_for_lisp
= 1;
623 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
624 allocating_for_lisp
= 0;
625 VALIDATE_LISP_STORAGE (new, sizeof *new);
626 new->next
= float_block
;
628 float_block_index
= 0;
630 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
632 XFLOAT (val
)->data
= float_value
;
633 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
634 consing_since_gc
+= sizeof (struct Lisp_Float
);
639 #endif /* LISP_FLOAT_TYPE */
641 /* Allocation of cons cells */
642 /* We store cons cells inside of cons_blocks, allocating a new
643 cons_block with malloc whenever necessary. Cons cells reclaimed by
644 GC are put on a free list to be reallocated before allocating
645 any new cons cells from the latest cons_block.
647 Each cons_block is just under 1020 bytes long,
648 since malloc really allocates in units of powers of two
649 and uses 4 bytes for its own overhead. */
651 #define CONS_BLOCK_SIZE \
652 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
656 struct cons_block
*next
;
657 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
660 struct cons_block
*cons_block
;
661 int cons_block_index
;
663 struct Lisp_Cons
*cons_free_list
;
668 allocating_for_lisp
= 1;
669 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
670 allocating_for_lisp
= 0;
671 cons_block
->next
= 0;
672 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
673 cons_block_index
= 0;
677 /* Explicitly free a cons cell. */
681 struct Lisp_Cons
*ptr
;
683 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
684 cons_free_list
= ptr
;
687 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
688 "Create a new cons, give it CAR and CDR as components, and return it.")
690 Lisp_Object car
, cdr
;
692 register Lisp_Object val
;
696 /* We use the cdr for chaining the free list
697 so that we won't use the same field that has the mark bit. */
698 XSETCONS (val
, cons_free_list
);
699 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
703 if (cons_block_index
== CONS_BLOCK_SIZE
)
705 register struct cons_block
*new;
706 allocating_for_lisp
= 1;
707 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
708 allocating_for_lisp
= 0;
709 VALIDATE_LISP_STORAGE (new, sizeof *new);
710 new->next
= cons_block
;
712 cons_block_index
= 0;
714 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
716 XCONS (val
)->car
= car
;
717 XCONS (val
)->cdr
= cdr
;
718 consing_since_gc
+= sizeof (struct Lisp_Cons
);
723 /* Make a list of 2, 3, 4 or 5 specified objects. */
727 Lisp_Object arg1
, arg2
;
729 return Fcons (arg1
, Fcons (arg2
, Qnil
));
733 list3 (arg1
, arg2
, arg3
)
734 Lisp_Object arg1
, arg2
, arg3
;
736 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
740 list4 (arg1
, arg2
, arg3
, arg4
)
741 Lisp_Object arg1
, arg2
, arg3
, arg4
;
743 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
747 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
748 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
750 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
751 Fcons (arg5
, Qnil
)))));
754 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
755 "Return a newly created list with specified arguments as elements.\n\
756 Any number of arguments, even zero arguments, are allowed.")
759 register Lisp_Object
*args
;
761 register Lisp_Object val
;
767 val
= Fcons (args
[nargs
], val
);
772 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
773 "Return a newly created list of length LENGTH, with each element being INIT.")
775 register Lisp_Object length
, init
;
777 register Lisp_Object val
;
780 CHECK_NATNUM (length
, 0);
781 size
= XFASTINT (length
);
785 val
= Fcons (init
, val
);
789 /* Allocation of vectors */
791 struct Lisp_Vector
*all_vectors
;
794 allocate_vectorlike (len
)
797 struct Lisp_Vector
*p
;
799 allocating_for_lisp
= 1;
800 #ifdef DOUG_LEA_MALLOC
801 /* Prevent mmap'ing the chunk (which is potentially very large). */
802 mallopt (M_MMAP_MAX
, 0);
804 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
805 + (len
- 1) * sizeof (Lisp_Object
));
806 #ifdef DOUG_LEA_MALLOC
807 /* Back to a reasonable maximum of mmap'ed areas. */
808 mallopt (M_MMAP_MAX
, 64);
810 allocating_for_lisp
= 0;
811 VALIDATE_LISP_STORAGE (p
, 0);
812 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
813 + (len
- 1) * sizeof (Lisp_Object
));
814 vector_cells_consed
+= len
;
816 p
->next
= all_vectors
;
821 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
822 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
823 See also the function `vector'.")
825 register Lisp_Object length
, init
;
828 register EMACS_INT sizei
;
830 register struct Lisp_Vector
*p
;
832 CHECK_NATNUM (length
, 0);
833 sizei
= XFASTINT (length
);
835 p
= allocate_vectorlike (sizei
);
837 for (index
= 0; index
< sizei
; index
++)
838 p
->contents
[index
] = init
;
840 XSETVECTOR (vector
, p
);
844 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
845 "Return a newly created char-table, with purpose PURPOSE.\n\
846 Each element is initialized to INIT, which defaults to nil.\n\
847 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
848 The property's value should be an integer between 0 and 10.")
850 register Lisp_Object purpose
, init
;
854 CHECK_SYMBOL (purpose
, 1);
855 n
= Fget (purpose
, Qchar_table_extra_slots
);
857 if (XINT (n
) < 0 || XINT (n
) > 10)
858 args_out_of_range (n
, Qnil
);
859 /* Add 2 to the size for the defalt and parent slots. */
860 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
862 XCHAR_TABLE (vector
)->top
= Qt
;
863 XCHAR_TABLE (vector
)->parent
= Qnil
;
864 XCHAR_TABLE (vector
)->purpose
= purpose
;
865 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
869 /* Return a newly created sub char table with default value DEFALT.
870 Since a sub char table does not appear as a top level Emacs Lisp
871 object, we don't need a Lisp interface to make it. */
874 make_sub_char_table (defalt
)
878 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
879 XCHAR_TABLE (vector
)->top
= Qnil
;
880 XCHAR_TABLE (vector
)->defalt
= defalt
;
881 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
885 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
886 "Return a newly created vector with specified arguments as elements.\n\
887 Any number of arguments, even zero arguments, are allowed.")
892 register Lisp_Object len
, val
;
894 register struct Lisp_Vector
*p
;
896 XSETFASTINT (len
, nargs
);
897 val
= Fmake_vector (len
, Qnil
);
899 for (index
= 0; index
< nargs
; index
++)
900 p
->contents
[index
] = args
[index
];
904 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
905 "Create a byte-code object with specified arguments as elements.\n\
906 The arguments should be the arglist, bytecode-string, constant vector,\n\
907 stack size, (optional) doc string, and (optional) interactive spec.\n\
908 The first four arguments are required; at most six have any\n\
914 register Lisp_Object len
, val
;
916 register struct Lisp_Vector
*p
;
918 XSETFASTINT (len
, nargs
);
919 if (!NILP (Vpurify_flag
))
920 val
= make_pure_vector ((EMACS_INT
) nargs
);
922 val
= Fmake_vector (len
, Qnil
);
924 for (index
= 0; index
< nargs
; index
++)
926 if (!NILP (Vpurify_flag
))
927 args
[index
] = Fpurecopy (args
[index
]);
928 p
->contents
[index
] = args
[index
];
930 XSETCOMPILED (val
, p
);
934 /* Allocation of symbols.
935 Just like allocation of conses!
937 Each symbol_block is just under 1020 bytes long,
938 since malloc really allocates in units of powers of two
939 and uses 4 bytes for its own overhead. */
941 #define SYMBOL_BLOCK_SIZE \
942 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
946 struct symbol_block
*next
;
947 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
950 struct symbol_block
*symbol_block
;
951 int symbol_block_index
;
953 struct Lisp_Symbol
*symbol_free_list
;
958 allocating_for_lisp
= 1;
959 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
960 allocating_for_lisp
= 0;
961 symbol_block
->next
= 0;
962 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
963 symbol_block_index
= 0;
964 symbol_free_list
= 0;
967 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
968 "Return a newly allocated uninterned symbol whose name is NAME.\n\
969 Its value and function definition are void, and its property list is nil.")
973 register Lisp_Object val
;
974 register struct Lisp_Symbol
*p
;
976 CHECK_STRING (name
, 0);
978 if (symbol_free_list
)
980 XSETSYMBOL (val
, symbol_free_list
);
981 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
985 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
987 struct symbol_block
*new;
988 allocating_for_lisp
= 1;
989 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
990 allocating_for_lisp
= 0;
991 VALIDATE_LISP_STORAGE (new, sizeof *new);
992 new->next
= symbol_block
;
994 symbol_block_index
= 0;
996 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
999 p
->name
= XSTRING (name
);
1002 p
->value
= Qunbound
;
1003 p
->function
= Qunbound
;
1005 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
1010 /* Allocation of markers and other objects that share that structure.
1011 Works like allocation of conses. */
1013 #define MARKER_BLOCK_SIZE \
1014 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
1018 struct marker_block
*next
;
1019 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
1022 struct marker_block
*marker_block
;
1023 int marker_block_index
;
1025 union Lisp_Misc
*marker_free_list
;
1030 allocating_for_lisp
= 1;
1031 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
1032 allocating_for_lisp
= 0;
1033 marker_block
->next
= 0;
1034 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1035 marker_block_index
= 0;
1036 marker_free_list
= 0;
1039 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1045 if (marker_free_list
)
1047 XSETMISC (val
, marker_free_list
);
1048 marker_free_list
= marker_free_list
->u_free
.chain
;
1052 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1054 struct marker_block
*new;
1055 allocating_for_lisp
= 1;
1056 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
1057 allocating_for_lisp
= 0;
1058 VALIDATE_LISP_STORAGE (new, sizeof *new);
1059 new->next
= marker_block
;
1061 marker_block_index
= 0;
1063 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1065 consing_since_gc
+= sizeof (union Lisp_Misc
);
1066 misc_objects_consed
++;
1070 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1071 "Return a newly allocated marker which does not point at any place.")
1074 register Lisp_Object val
;
1075 register struct Lisp_Marker
*p
;
1077 val
= allocate_misc ();
1078 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1084 p
->insertion_type
= 0;
1088 /* Put MARKER back on the free list after using it temporarily. */
1091 free_marker (marker
)
1094 unchain_marker (marker
);
1096 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1097 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1098 marker_free_list
= XMISC (marker
);
1100 total_free_markers
++;
1103 /* Allocation of strings */
1105 /* Strings reside inside of string_blocks. The entire data of the string,
1106 both the size and the contents, live in part of the `chars' component of a string_block.
1107 The `pos' component is the index within `chars' of the first free byte.
1109 first_string_block points to the first string_block ever allocated.
1110 Each block points to the next one with its `next' field.
1111 The `prev' fields chain in reverse order.
1112 The last one allocated is the one currently being filled.
1113 current_string_block points to it.
1115 The string_blocks that hold individual large strings
1116 go in a separate chain, started by large_string_blocks. */
1119 /* String blocks contain this many useful bytes.
1120 8188 is power of 2, minus 4 for malloc overhead. */
1121 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1123 /* A string bigger than this gets its own specially-made string block
1124 if it doesn't fit in the current one. */
1125 #define STRING_BLOCK_OUTSIZE 1024
1127 struct string_block_head
1129 struct string_block
*next
, *prev
;
1135 struct string_block
*next
, *prev
;
1137 char chars
[STRING_BLOCK_SIZE
];
1140 /* This points to the string block we are now allocating strings. */
1142 struct string_block
*current_string_block
;
1144 /* This points to the oldest string block, the one that starts the chain. */
1146 struct string_block
*first_string_block
;
1148 /* Last string block in chain of those made for individual large strings. */
1150 struct string_block
*large_string_blocks
;
1152 /* If SIZE is the length of a string, this returns how many bytes
1153 the string occupies in a string_block (including padding). */
1155 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1156 & ~(STRING_PAD - 1))
1157 /* Add 1 for the null terminator,
1158 and add STRING_PAD - 1 as part of rounding up. */
1160 #define STRING_PAD (sizeof (EMACS_INT))
1161 /* Size of the stuff in the string not including its data. */
1162 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1165 #define STRING_FULLSIZE(SIZE) \
1166 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1172 allocating_for_lisp
= 1;
1173 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1174 allocating_for_lisp
= 0;
1175 first_string_block
= current_string_block
;
1176 consing_since_gc
+= sizeof (struct string_block
);
1177 current_string_block
->next
= 0;
1178 current_string_block
->prev
= 0;
1179 current_string_block
->pos
= 0;
1180 large_string_blocks
= 0;
1183 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1184 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1185 Both LENGTH and INIT must be numbers.")
1187 Lisp_Object length
, init
;
1189 register Lisp_Object val
;
1190 register unsigned char *p
, *end
;
1193 CHECK_NATNUM (length
, 0);
1194 CHECK_NUMBER (init
, 1);
1197 if (SINGLE_BYTE_CHAR_P (c
))
1199 nbytes
= XINT (length
);
1200 val
= make_uninit_multibyte_string (nbytes
, nbytes
);
1201 p
= XSTRING (val
)->data
;
1202 end
= p
+ XSTRING (val
)->size
;
1208 unsigned char work
[4], *str
;
1209 int len
= CHAR_STRING (c
, work
, str
);
1211 nbytes
= len
* XINT (length
);
1212 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1213 p
= XSTRING (val
)->data
;
1217 bcopy (str
, p
, len
);
1225 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1226 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1227 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1229 Lisp_Object length
, init
;
1231 register Lisp_Object val
;
1232 struct Lisp_Bool_Vector
*p
;
1234 int length_in_chars
, length_in_elts
, bits_per_value
;
1236 CHECK_NATNUM (length
, 0);
1238 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1240 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1241 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1243 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1244 slot `size' of the struct Lisp_Bool_Vector. */
1245 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1246 p
= XBOOL_VECTOR (val
);
1247 /* Get rid of any bits that would cause confusion. */
1249 XSETBOOL_VECTOR (val
, p
);
1250 p
->size
= XFASTINT (length
);
1252 real_init
= (NILP (init
) ? 0 : -1);
1253 for (i
= 0; i
< length_in_chars
; i
++)
1254 p
->data
[i
] = real_init
;
1259 /* Make a string from NBYTES bytes at CONTENTS,
1260 and compute the number of characters from the contents. */
1263 make_string (contents
, nbytes
)
1267 register Lisp_Object val
;
1268 int nchars
= chars_in_text (contents
, nbytes
);
1269 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1270 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1274 /* Make a string from LENGTH bytes at CONTENTS,
1275 assuming each byte is a character. */
1278 make_unibyte_string (contents
, length
)
1282 register Lisp_Object val
;
1283 val
= make_uninit_string (length
);
1284 bcopy (contents
, XSTRING (val
)->data
, length
);
1288 /* Make a string from NCHARS characters occupying NBYTES bytes at CONTENTS. */
1291 make_multibyte_string (contents
, nchars
, nbytes
)
1295 register Lisp_Object val
;
1296 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1297 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1301 /* Make a string from the data at STR,
1302 treating it as multibyte if the data warrants. */
1308 return make_string (str
, strlen (str
));
1312 make_uninit_string (length
)
1315 return make_uninit_multibyte_string (length
, length
);
1319 make_uninit_multibyte_string (length
, length_byte
)
1320 int length
, length_byte
;
1322 register Lisp_Object val
;
1323 register int fullsize
= STRING_FULLSIZE (length_byte
);
1325 if (length
< 0) abort ();
1327 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1328 /* This string can fit in the current string block */
1331 ((struct Lisp_String
*)
1332 (current_string_block
->chars
+ current_string_block
->pos
)));
1333 current_string_block
->pos
+= fullsize
;
1335 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1336 /* This string gets its own string block */
1338 register struct string_block
*new;
1339 allocating_for_lisp
= 1;
1340 #ifdef DOUG_LEA_MALLOC
1341 /* Prevent mmap'ing the chunk (which is potentially very large). */
1342 mallopt (M_MMAP_MAX
, 0);
1344 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1345 #ifdef DOUG_LEA_MALLOC
1346 /* Back to a reasonable maximum of mmap'ed areas. */
1347 mallopt (M_MMAP_MAX
, 64);
1349 allocating_for_lisp
= 0;
1350 VALIDATE_LISP_STORAGE (new, 0);
1351 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1352 new->pos
= fullsize
;
1353 new->next
= large_string_blocks
;
1354 large_string_blocks
= new;
1356 ((struct Lisp_String
*)
1357 ((struct string_block_head
*)new + 1)));
1360 /* Make a new current string block and start it off with this string */
1362 register struct string_block
*new;
1363 allocating_for_lisp
= 1;
1364 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1365 allocating_for_lisp
= 0;
1366 VALIDATE_LISP_STORAGE (new, sizeof *new);
1367 consing_since_gc
+= sizeof (struct string_block
);
1368 current_string_block
->next
= new;
1369 new->prev
= current_string_block
;
1371 current_string_block
= new;
1372 new->pos
= fullsize
;
1374 (struct Lisp_String
*) current_string_block
->chars
);
1377 string_chars_consed
+= fullsize
;
1378 XSTRING (val
)->size
= length
;
1379 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1380 XSTRING (val
)->data
[length_byte
] = 0;
1381 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1386 /* Return a newly created vector or string with specified arguments as
1387 elements. If all the arguments are characters that can fit
1388 in a string of events, make a string; otherwise, make a vector.
1390 Any number of arguments, even zero arguments, are allowed. */
1393 make_event_array (nargs
, args
)
1399 for (i
= 0; i
< nargs
; i
++)
1400 /* The things that fit in a string
1401 are characters that are in 0...127,
1402 after discarding the meta bit and all the bits above it. */
1403 if (!INTEGERP (args
[i
])
1404 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1405 return Fvector (nargs
, args
);
1407 /* Since the loop exited, we know that all the things in it are
1408 characters, so we can make a string. */
1412 result
= Fmake_string (make_number (nargs
), make_number (0));
1413 for (i
= 0; i
< nargs
; i
++)
1415 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1416 /* Move the meta bit to the right place for a string char. */
1417 if (XINT (args
[i
]) & CHAR_META
)
1418 XSTRING (result
)->data
[i
] |= 0x80;
1425 /* Pure storage management. */
1427 /* Must get an error if pure storage is full,
1428 since if it cannot hold a large string
1429 it may be able to hold conses that point to that string;
1430 then the string is not protected from gc. */
1433 make_pure_string (data
, length
, length_byte
)
1438 register Lisp_Object
new;
1439 register int size
= STRING_FULLSIZE (length_byte
);
1441 if (pureptr
+ size
> PURESIZE
)
1442 error ("Pure Lisp storage exhausted");
1443 XSETSTRING (new, PUREBEG
+ pureptr
);
1444 XSTRING (new)->size
= length
;
1445 SET_STRING_BYTES (XSTRING (new), length_byte
);
1446 bcopy (data
, XSTRING (new)->data
, length_byte
);
1447 XSTRING (new)->data
[length_byte
] = 0;
1449 /* We must give strings in pure storage some kind of interval. So we
1450 give them a null one. */
1451 #if defined (USE_TEXT_PROPERTIES)
1452 XSTRING (new)->intervals
= NULL_INTERVAL
;
1459 pure_cons (car
, cdr
)
1460 Lisp_Object car
, cdr
;
1462 register Lisp_Object
new;
1464 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1465 error ("Pure Lisp storage exhausted");
1466 XSETCONS (new, PUREBEG
+ pureptr
);
1467 pureptr
+= sizeof (struct Lisp_Cons
);
1468 XCONS (new)->car
= Fpurecopy (car
);
1469 XCONS (new)->cdr
= Fpurecopy (cdr
);
1473 #ifdef LISP_FLOAT_TYPE
1476 make_pure_float (num
)
1479 register Lisp_Object
new;
1481 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1482 (double) boundary. Some architectures (like the sparc) require
1483 this, and I suspect that floats are rare enough that it's no
1484 tragedy for those that do. */
1487 char *p
= PUREBEG
+ pureptr
;
1491 alignment
= __alignof (struct Lisp_Float
);
1493 alignment
= sizeof (struct Lisp_Float
);
1496 alignment
= sizeof (struct Lisp_Float
);
1498 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1499 pureptr
= p
- PUREBEG
;
1502 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1503 error ("Pure Lisp storage exhausted");
1504 XSETFLOAT (new, PUREBEG
+ pureptr
);
1505 pureptr
+= sizeof (struct Lisp_Float
);
1506 XFLOAT (new)->data
= num
;
1507 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1511 #endif /* LISP_FLOAT_TYPE */
1514 make_pure_vector (len
)
1517 register Lisp_Object
new;
1518 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1520 if (pureptr
+ size
> PURESIZE
)
1521 error ("Pure Lisp storage exhausted");
1523 XSETVECTOR (new, PUREBEG
+ pureptr
);
1525 XVECTOR (new)->size
= len
;
1529 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1530 "Make a copy of OBJECT in pure storage.\n\
1531 Recursively copies contents of vectors and cons cells.\n\
1532 Does not copy symbols.")
1534 register Lisp_Object obj
;
1536 if (NILP (Vpurify_flag
))
1539 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1540 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1544 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1545 #ifdef LISP_FLOAT_TYPE
1546 else if (FLOATP (obj
))
1547 return make_pure_float (XFLOAT (obj
)->data
);
1548 #endif /* LISP_FLOAT_TYPE */
1549 else if (STRINGP (obj
))
1550 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1551 STRING_BYTES (XSTRING (obj
)));
1552 else if (COMPILEDP (obj
) || VECTORP (obj
))
1554 register struct Lisp_Vector
*vec
;
1555 register int i
, size
;
1557 size
= XVECTOR (obj
)->size
;
1558 if (size
& PSEUDOVECTOR_FLAG
)
1559 size
&= PSEUDOVECTOR_SIZE_MASK
;
1560 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1561 for (i
= 0; i
< size
; i
++)
1562 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1563 if (COMPILEDP (obj
))
1564 XSETCOMPILED (obj
, vec
);
1566 XSETVECTOR (obj
, vec
);
1569 else if (MARKERP (obj
))
1570 error ("Attempt to copy a marker to pure storage");
1575 /* Recording what needs to be marked for gc. */
1577 struct gcpro
*gcprolist
;
1579 #define NSTATICS 768
1581 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1585 /* Put an entry in staticvec, pointing at the variable whose address is given */
1588 staticpro (varaddress
)
1589 Lisp_Object
*varaddress
;
1591 staticvec
[staticidx
++] = varaddress
;
1592 if (staticidx
>= NSTATICS
)
1600 struct catchtag
*next
;
1601 #if 0 /* We don't need this for GC purposes */
1608 struct backtrace
*next
;
1609 Lisp_Object
*function
;
1610 Lisp_Object
*args
; /* Points to vector of args. */
1611 int nargs
; /* length of vector */
1612 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1616 /* Garbage collection! */
1618 /* Temporarily prevent garbage collection. */
1621 inhibit_garbage_collection ()
1623 int count
= specpdl_ptr
- specpdl
;
1625 int nbits
= min (VALBITS
, BITS_PER_INT
);
1627 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1629 specbind (Qgc_cons_threshold
, number
);
1634 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1635 "Reclaim storage for Lisp objects no longer needed.\n\
1636 Returns info on amount of space in use:\n\
1637 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1638 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1639 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1640 Garbage collection happens automatically if you cons more than\n\
1641 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1644 register struct gcpro
*tail
;
1645 register struct specbinding
*bind
;
1646 struct catchtag
*catch;
1647 struct handler
*handler
;
1648 register struct backtrace
*backlist
;
1649 register Lisp_Object tem
;
1650 char *omessage
= echo_area_glyphs
;
1651 int omessage_length
= echo_area_glyphs_length
;
1652 int oldmultibyte
= message_enable_multibyte
;
1653 char stack_top_variable
;
1656 /* In case user calls debug_print during GC,
1657 don't let that cause a recursive GC. */
1658 consing_since_gc
= 0;
1660 /* Save a copy of the contents of the stack, for debugging. */
1661 #if MAX_SAVE_STACK > 0
1662 if (NILP (Vpurify_flag
))
1664 i
= &stack_top_variable
- stack_bottom
;
1666 if (i
< MAX_SAVE_STACK
)
1668 if (stack_copy
== 0)
1669 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1670 else if (stack_copy_size
< i
)
1671 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1674 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1675 bcopy (stack_bottom
, stack_copy
, i
);
1677 bcopy (&stack_top_variable
, stack_copy
, i
);
1681 #endif /* MAX_SAVE_STACK > 0 */
1683 if (garbage_collection_messages
)
1684 message1_nolog ("Garbage collecting...");
1686 /* Don't keep command history around forever. */
1687 if (NUMBERP (Vhistory_length
) && XINT (Vhistory_length
) > 0)
1689 tem
= Fnthcdr (Vhistory_length
, Vcommand_history
);
1691 XCONS (tem
)->cdr
= Qnil
;
1694 /* Likewise for undo information. */
1696 register struct buffer
*nextb
= all_buffers
;
1700 /* If a buffer's undo list is Qt, that means that undo is
1701 turned off in that buffer. Calling truncate_undo_list on
1702 Qt tends to return NULL, which effectively turns undo back on.
1703 So don't call truncate_undo_list if undo_list is Qt. */
1704 if (! EQ (nextb
->undo_list
, Qt
))
1706 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1708 nextb
= nextb
->next
;
1714 /* clear_marks (); */
1716 /* In each "large string", set the MARKBIT of the size field.
1717 That enables mark_object to recognize them. */
1719 register struct string_block
*b
;
1720 for (b
= large_string_blocks
; b
; b
= b
->next
)
1721 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1724 /* Mark all the special slots that serve as the roots of accessibility.
1726 Usually the special slots to mark are contained in particular structures.
1727 Then we know no slot is marked twice because the structures don't overlap.
1728 In some cases, the structures point to the slots to be marked.
1729 For these, we use MARKBIT to avoid double marking of the slot. */
1731 for (i
= 0; i
< staticidx
; i
++)
1732 mark_object (staticvec
[i
]);
1733 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1734 for (i
= 0; i
< tail
->nvars
; i
++)
1735 if (!XMARKBIT (tail
->var
[i
]))
1737 mark_object (&tail
->var
[i
]);
1738 XMARK (tail
->var
[i
]);
1740 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1742 mark_object (&bind
->symbol
);
1743 mark_object (&bind
->old_value
);
1745 for (catch = catchlist
; catch; catch = catch->next
)
1747 mark_object (&catch->tag
);
1748 mark_object (&catch->val
);
1750 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1752 mark_object (&handler
->handler
);
1753 mark_object (&handler
->var
);
1755 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1757 if (!XMARKBIT (*backlist
->function
))
1759 mark_object (backlist
->function
);
1760 XMARK (*backlist
->function
);
1762 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1765 i
= backlist
->nargs
- 1;
1767 if (!XMARKBIT (backlist
->args
[i
]))
1769 mark_object (&backlist
->args
[i
]);
1770 XMARK (backlist
->args
[i
]);
1777 /* Clear the mark bits that we set in certain root slots. */
1779 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1780 for (i
= 0; i
< tail
->nvars
; i
++)
1781 XUNMARK (tail
->var
[i
]);
1782 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1784 XUNMARK (*backlist
->function
);
1785 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1788 i
= backlist
->nargs
- 1;
1790 XUNMARK (backlist
->args
[i
]);
1792 XUNMARK (buffer_defaults
.name
);
1793 XUNMARK (buffer_local_symbols
.name
);
1795 /* clear_marks (); */
1798 consing_since_gc
= 0;
1799 if (gc_cons_threshold
< 10000)
1800 gc_cons_threshold
= 10000;
1802 if (garbage_collection_messages
)
1804 if (omessage
|| minibuf_level
> 0)
1805 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1807 message1_nolog ("Garbage collecting...done");
1810 return Fcons (Fcons (make_number (total_conses
),
1811 make_number (total_free_conses
)),
1812 Fcons (Fcons (make_number (total_symbols
),
1813 make_number (total_free_symbols
)),
1814 Fcons (Fcons (make_number (total_markers
),
1815 make_number (total_free_markers
)),
1816 Fcons (make_number (total_string_size
),
1817 Fcons (make_number (total_vector_size
),
1819 #ifdef LISP_FLOAT_TYPE
1820 (make_number (total_floats
),
1821 make_number (total_free_floats
)),
1822 #else /* not LISP_FLOAT_TYPE */
1823 (make_number (0), make_number (0)),
1824 #endif /* not LISP_FLOAT_TYPE */
1826 #ifdef USE_TEXT_PROPERTIES
1827 (make_number (total_intervals
),
1828 make_number (total_free_intervals
)),
1829 #else /* not USE_TEXT_PROPERTIES */
1830 (make_number (0), make_number (0)),
1831 #endif /* not USE_TEXT_PROPERTIES */
1839 /* Clear marks on all conses */
1841 register struct cons_block
*cblk
;
1842 register int lim
= cons_block_index
;
1844 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1847 for (i
= 0; i
< lim
; i
++)
1848 XUNMARK (cblk
->conses
[i
].car
);
1849 lim
= CONS_BLOCK_SIZE
;
1852 /* Clear marks on all symbols */
1854 register struct symbol_block
*sblk
;
1855 register int lim
= symbol_block_index
;
1857 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1860 for (i
= 0; i
< lim
; i
++)
1862 XUNMARK (sblk
->symbols
[i
].plist
);
1864 lim
= SYMBOL_BLOCK_SIZE
;
1867 /* Clear marks on all markers */
1869 register struct marker_block
*sblk
;
1870 register int lim
= marker_block_index
;
1872 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1875 for (i
= 0; i
< lim
; i
++)
1876 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1877 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1878 lim
= MARKER_BLOCK_SIZE
;
1881 /* Clear mark bits on all buffers */
1883 register struct buffer
*nextb
= all_buffers
;
1887 XUNMARK (nextb
->name
);
1888 nextb
= nextb
->next
;
1894 /* Mark reference to a Lisp_Object.
1895 If the object referred to has not been seen yet, recursively mark
1896 all the references contained in it.
1898 If the object referenced is a short string, the referencing slot
1899 is threaded into a chain of such slots, pointed to from
1900 the `size' field of the string. The actual string size
1901 lives in the last slot in the chain. We recognize the end
1902 because it is < (unsigned) STRING_BLOCK_SIZE. */
1904 #define LAST_MARKED_SIZE 500
1905 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1906 int last_marked_index
;
1909 mark_object (argptr
)
1910 Lisp_Object
*argptr
;
1912 Lisp_Object
*objptr
= argptr
;
1913 register Lisp_Object obj
;
1920 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1921 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1924 last_marked
[last_marked_index
++] = objptr
;
1925 if (last_marked_index
== LAST_MARKED_SIZE
)
1926 last_marked_index
= 0;
1928 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1932 register struct Lisp_String
*ptr
= XSTRING (obj
);
1934 MARK_INTERVAL_TREE (ptr
->intervals
);
1935 if (ptr
->size
& MARKBIT
)
1936 /* A large string. Just set ARRAY_MARK_FLAG. */
1937 ptr
->size
|= ARRAY_MARK_FLAG
;
1940 /* A small string. Put this reference
1941 into the chain of references to it.
1942 If the address includes MARKBIT, put that bit elsewhere
1943 when we store OBJPTR into the size field. */
1945 if (XMARKBIT (*objptr
))
1947 XSETFASTINT (*objptr
, ptr
->size
);
1951 XSETFASTINT (*objptr
, ptr
->size
);
1953 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1955 ptr
->size
= (EMACS_INT
) objptr
;
1956 if (ptr
->size
& MARKBIT
)
1957 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1962 case Lisp_Vectorlike
:
1963 if (GC_BUFFERP (obj
))
1965 if (!XMARKBIT (XBUFFER (obj
)->name
))
1968 else if (GC_SUBRP (obj
))
1970 else if (GC_COMPILEDP (obj
))
1971 /* We could treat this just like a vector, but it is better
1972 to save the COMPILED_CONSTANTS element for last and avoid recursion
1975 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1976 register EMACS_INT size
= ptr
->size
;
1977 /* See comment above under Lisp_Vector. */
1978 struct Lisp_Vector
*volatile ptr1
= ptr
;
1981 if (size
& ARRAY_MARK_FLAG
)
1982 break; /* Already marked */
1983 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1984 size
&= PSEUDOVECTOR_SIZE_MASK
;
1985 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1987 if (i
!= COMPILED_CONSTANTS
)
1988 mark_object (&ptr1
->contents
[i
]);
1990 /* This cast should be unnecessary, but some Mips compiler complains
1991 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1992 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1995 else if (GC_FRAMEP (obj
))
1997 /* See comment above under Lisp_Vector for why this is volatile. */
1998 register struct frame
*volatile ptr
= XFRAME (obj
);
1999 register EMACS_INT size
= ptr
->size
;
2001 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2002 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2004 mark_object (&ptr
->name
);
2005 mark_object (&ptr
->icon_name
);
2006 mark_object (&ptr
->title
);
2007 mark_object (&ptr
->focus_frame
);
2008 mark_object (&ptr
->selected_window
);
2009 mark_object (&ptr
->minibuffer_window
);
2010 mark_object (&ptr
->param_alist
);
2011 mark_object (&ptr
->scroll_bars
);
2012 mark_object (&ptr
->condemned_scroll_bars
);
2013 mark_object (&ptr
->menu_bar_items
);
2014 mark_object (&ptr
->face_alist
);
2015 mark_object (&ptr
->menu_bar_vector
);
2016 mark_object (&ptr
->buffer_predicate
);
2017 mark_object (&ptr
->buffer_list
);
2019 else if (GC_BOOL_VECTOR_P (obj
))
2021 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2023 if (ptr
->size
& ARRAY_MARK_FLAG
)
2024 break; /* Already marked */
2025 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2029 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2030 register EMACS_INT size
= ptr
->size
;
2031 /* The reason we use ptr1 is to avoid an apparent hardware bug
2032 that happens occasionally on the FSF's HP 300s.
2033 The bug is that a2 gets clobbered by recursive calls to mark_object.
2034 The clobberage seems to happen during function entry,
2035 perhaps in the moveml instruction.
2036 Yes, this is a crock, but we have to do it. */
2037 struct Lisp_Vector
*volatile ptr1
= ptr
;
2040 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2041 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2042 if (size
& PSEUDOVECTOR_FLAG
)
2043 size
&= PSEUDOVECTOR_SIZE_MASK
;
2044 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2045 mark_object (&ptr1
->contents
[i
]);
2051 /* See comment above under Lisp_Vector for why this is volatile. */
2052 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2053 struct Lisp_Symbol
*ptrx
;
2055 if (XMARKBIT (ptr
->plist
)) break;
2057 mark_object ((Lisp_Object
*) &ptr
->value
);
2058 mark_object (&ptr
->function
);
2059 mark_object (&ptr
->plist
);
2060 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2061 mark_object (&ptr
->name
);
2062 /* Note that we do not mark the obarray of the symbol.
2063 It is safe not to do so because nothing accesses that
2064 slot except to check whether it is nil. */
2068 /* For the benefit of the last_marked log. */
2069 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2070 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2071 XSETSYMBOL (obj
, ptrx
);
2072 /* We can't goto loop here because *objptr doesn't contain an
2073 actual Lisp_Object with valid datatype field. */
2080 switch (XMISCTYPE (obj
))
2082 case Lisp_Misc_Marker
:
2083 XMARK (XMARKER (obj
)->chain
);
2084 /* DO NOT mark thru the marker's chain.
2085 The buffer's markers chain does not preserve markers from gc;
2086 instead, markers are removed from the chain when freed by gc. */
2089 case Lisp_Misc_Buffer_Local_Value
:
2090 case Lisp_Misc_Some_Buffer_Local_Value
:
2092 register struct Lisp_Buffer_Local_Value
*ptr
2093 = XBUFFER_LOCAL_VALUE (obj
);
2094 if (XMARKBIT (ptr
->realvalue
)) break;
2095 XMARK (ptr
->realvalue
);
2096 /* If the cdr is nil, avoid recursion for the car. */
2097 if (EQ (ptr
->cdr
, Qnil
))
2099 objptr
= &ptr
->realvalue
;
2102 mark_object (&ptr
->realvalue
);
2103 mark_object (&ptr
->buffer
);
2104 mark_object (&ptr
->frame
);
2105 /* See comment above under Lisp_Vector for why not use ptr here. */
2106 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2110 case Lisp_Misc_Intfwd
:
2111 case Lisp_Misc_Boolfwd
:
2112 case Lisp_Misc_Objfwd
:
2113 case Lisp_Misc_Buffer_Objfwd
:
2114 case Lisp_Misc_Kboard_Objfwd
:
2115 /* Don't bother with Lisp_Buffer_Objfwd,
2116 since all markable slots in current buffer marked anyway. */
2117 /* Don't need to do Lisp_Objfwd, since the places they point
2118 are protected with staticpro. */
2121 case Lisp_Misc_Overlay
:
2123 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2124 if (!XMARKBIT (ptr
->plist
))
2127 mark_object (&ptr
->start
);
2128 mark_object (&ptr
->end
);
2129 objptr
= &ptr
->plist
;
2142 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2143 if (XMARKBIT (ptr
->car
)) break;
2145 /* If the cdr is nil, avoid recursion for the car. */
2146 if (EQ (ptr
->cdr
, Qnil
))
2151 mark_object (&ptr
->car
);
2152 /* See comment above under Lisp_Vector for why not use ptr here. */
2153 objptr
= &XCONS (obj
)->cdr
;
2157 #ifdef LISP_FLOAT_TYPE
2159 XMARK (XFLOAT (obj
)->type
);
2161 #endif /* LISP_FLOAT_TYPE */
2171 /* Mark the pointers in a buffer structure. */
2177 register struct buffer
*buffer
= XBUFFER (buf
);
2178 register Lisp_Object
*ptr
;
2179 Lisp_Object base_buffer
;
2181 /* This is the buffer's markbit */
2182 mark_object (&buffer
->name
);
2183 XMARK (buffer
->name
);
2185 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2188 mark_object (buffer
->syntax_table
);
2190 /* Mark the various string-pointers in the buffer object.
2191 Since the strings may be relocated, we must mark them
2192 in their actual slots. So gc_sweep must convert each slot
2193 back to an ordinary C pointer. */
2194 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2195 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2196 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2197 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2199 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2200 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2201 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2202 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2205 for (ptr
= &buffer
->name
+ 1;
2206 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2210 /* If this is an indirect buffer, mark its base buffer. */
2211 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2213 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2214 mark_buffer (base_buffer
);
2219 /* Mark the pointers in the kboard objects. */
2226 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2228 if (kb
->kbd_macro_buffer
)
2229 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2231 mark_object (&kb
->Vprefix_arg
);
2232 mark_object (&kb
->kbd_queue
);
2233 mark_object (&kb
->Vlast_kbd_macro
);
2234 mark_object (&kb
->Vsystem_key_alist
);
2235 mark_object (&kb
->system_key_syms
);
2239 /* Sweep: find all structures not marked, and free them. */
2244 total_string_size
= 0;
2247 /* Put all unmarked conses on free list */
2249 register struct cons_block
*cblk
;
2250 struct cons_block
**cprev
= &cons_block
;
2251 register int lim
= cons_block_index
;
2252 register int num_free
= 0, num_used
= 0;
2256 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2260 for (i
= 0; i
< lim
; i
++)
2261 if (!XMARKBIT (cblk
->conses
[i
].car
))
2265 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2266 cons_free_list
= &cblk
->conses
[i
];
2271 XUNMARK (cblk
->conses
[i
].car
);
2273 lim
= CONS_BLOCK_SIZE
;
2274 /* If this block contains only free conses and we have already
2275 seen more than two blocks worth of free conses then deallocate
2277 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> 2*CONS_BLOCK_SIZE
)
2279 num_free
-= CONS_BLOCK_SIZE
;
2280 *cprev
= cblk
->next
;
2281 /* Unhook from the free list. */
2282 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2286 cprev
= &cblk
->next
;
2288 total_conses
= num_used
;
2289 total_free_conses
= num_free
;
2292 #ifdef LISP_FLOAT_TYPE
2293 /* Put all unmarked floats on free list */
2295 register struct float_block
*fblk
;
2296 struct float_block
**fprev
= &float_block
;
2297 register int lim
= float_block_index
;
2298 register int num_free
= 0, num_used
= 0;
2300 float_free_list
= 0;
2302 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2306 for (i
= 0; i
< lim
; i
++)
2307 if (!XMARKBIT (fblk
->floats
[i
].type
))
2311 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2312 float_free_list
= &fblk
->floats
[i
];
2317 XUNMARK (fblk
->floats
[i
].type
);
2319 lim
= FLOAT_BLOCK_SIZE
;
2320 /* If this block contains only free floats and we have already
2321 seen more than two blocks worth of free floats then deallocate
2323 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> 2*FLOAT_BLOCK_SIZE
)
2325 num_free
-= FLOAT_BLOCK_SIZE
;
2326 *fprev
= fblk
->next
;
2327 /* Unhook from the free list. */
2328 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2332 fprev
= &fblk
->next
;
2334 total_floats
= num_used
;
2335 total_free_floats
= num_free
;
2337 #endif /* LISP_FLOAT_TYPE */
2339 #ifdef USE_TEXT_PROPERTIES
2340 /* Put all unmarked intervals on free list */
2342 register struct interval_block
*iblk
;
2343 struct interval_block
**iprev
= &interval_block
;
2344 register int lim
= interval_block_index
;
2345 register int num_free
= 0, num_used
= 0;
2347 interval_free_list
= 0;
2349 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2354 for (i
= 0; i
< lim
; i
++)
2356 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2358 iblk
->intervals
[i
].parent
= interval_free_list
;
2359 interval_free_list
= &iblk
->intervals
[i
];
2366 XUNMARK (iblk
->intervals
[i
].plist
);
2369 lim
= INTERVAL_BLOCK_SIZE
;
2370 /* If this block contains only free intervals and we have already
2371 seen more than two blocks worth of free intervals then
2372 deallocate this block. */
2373 if (this_free
== INTERVAL_BLOCK_SIZE
2374 && num_free
> 2*INTERVAL_BLOCK_SIZE
)
2376 num_free
-= INTERVAL_BLOCK_SIZE
;
2377 *iprev
= iblk
->next
;
2378 /* Unhook from the free list. */
2379 interval_free_list
= iblk
->intervals
[0].parent
;
2383 iprev
= &iblk
->next
;
2385 total_intervals
= num_used
;
2386 total_free_intervals
= num_free
;
2388 #endif /* USE_TEXT_PROPERTIES */
2390 /* Put all unmarked symbols on free list */
2392 register struct symbol_block
*sblk
;
2393 struct symbol_block
**sprev
= &symbol_block
;
2394 register int lim
= symbol_block_index
;
2395 register int num_free
= 0, num_used
= 0;
2397 symbol_free_list
= 0;
2399 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2403 for (i
= 0; i
< lim
; i
++)
2404 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2406 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2407 symbol_free_list
= &sblk
->symbols
[i
];
2414 sblk
->symbols
[i
].name
2415 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2416 XUNMARK (sblk
->symbols
[i
].plist
);
2418 lim
= SYMBOL_BLOCK_SIZE
;
2419 /* If this block contains only free symbols and we have already
2420 seen more than two blocks worth of free symbols then deallocate
2422 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> 2*SYMBOL_BLOCK_SIZE
)
2424 num_free
-= SYMBOL_BLOCK_SIZE
;
2425 *sprev
= sblk
->next
;
2426 /* Unhook from the free list. */
2427 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2431 sprev
= &sblk
->next
;
2433 total_symbols
= num_used
;
2434 total_free_symbols
= num_free
;
2438 /* Put all unmarked misc's on free list.
2439 For a marker, first unchain it from the buffer it points into. */
2441 register struct marker_block
*mblk
;
2442 struct marker_block
**mprev
= &marker_block
;
2443 register int lim
= marker_block_index
;
2444 register int num_free
= 0, num_used
= 0;
2446 marker_free_list
= 0;
2448 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2452 EMACS_INT already_free
= -1;
2454 for (i
= 0; i
< lim
; i
++)
2456 Lisp_Object
*markword
;
2457 switch (mblk
->markers
[i
].u_marker
.type
)
2459 case Lisp_Misc_Marker
:
2460 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2462 case Lisp_Misc_Buffer_Local_Value
:
2463 case Lisp_Misc_Some_Buffer_Local_Value
:
2464 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2466 case Lisp_Misc_Overlay
:
2467 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2469 case Lisp_Misc_Free
:
2470 /* If the object was already free, keep it
2471 on the free list. */
2472 markword
= (Lisp_Object
*) &already_free
;
2478 if (markword
&& !XMARKBIT (*markword
))
2481 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2483 /* tem1 avoids Sun compiler bug */
2484 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2485 XSETMARKER (tem
, tem1
);
2486 unchain_marker (tem
);
2488 /* Set the type of the freed object to Lisp_Misc_Free.
2489 We could leave the type alone, since nobody checks it,
2490 but this might catch bugs faster. */
2491 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2492 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2493 marker_free_list
= &mblk
->markers
[i
];
2501 XUNMARK (*markword
);
2504 lim
= MARKER_BLOCK_SIZE
;
2505 /* If this block contains only free markers and we have already
2506 seen more than two blocks worth of free markers then deallocate
2508 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> 2*MARKER_BLOCK_SIZE
)
2510 num_free
-= MARKER_BLOCK_SIZE
;
2511 *mprev
= mblk
->next
;
2512 /* Unhook from the free list. */
2513 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2517 mprev
= &mblk
->next
;
2520 total_markers
= num_used
;
2521 total_free_markers
= num_free
;
2524 /* Free all unmarked buffers */
2526 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2529 if (!XMARKBIT (buffer
->name
))
2532 prev
->next
= buffer
->next
;
2534 all_buffers
= buffer
->next
;
2535 next
= buffer
->next
;
2541 XUNMARK (buffer
->name
);
2542 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2545 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2546 for purposes of marking and relocation.
2547 Turn them back into C pointers now. */
2548 buffer
->upcase_table
2549 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2550 buffer
->downcase_table
2551 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2553 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2554 buffer
->folding_sort_table
2555 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2558 prev
= buffer
, buffer
= buffer
->next
;
2562 #endif /* standalone */
2564 /* Free all unmarked vectors */
2566 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2567 total_vector_size
= 0;
2570 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2573 prev
->next
= vector
->next
;
2575 all_vectors
= vector
->next
;
2576 next
= vector
->next
;
2582 vector
->size
&= ~ARRAY_MARK_FLAG
;
2583 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2584 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2586 total_vector_size
+= vector
->size
;
2587 prev
= vector
, vector
= vector
->next
;
2591 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2593 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2594 struct Lisp_String
*s
;
2598 s
= (struct Lisp_String
*) &sb
->chars
[0];
2599 if (s
->size
& ARRAY_MARK_FLAG
)
2601 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2602 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2603 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2604 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2605 prev
= sb
, sb
= sb
->next
;
2610 prev
->next
= sb
->next
;
2612 large_string_blocks
= sb
->next
;
2621 /* Compactify strings, relocate references, and free empty string blocks. */
2626 /* String block of old strings we are scanning. */
2627 register struct string_block
*from_sb
;
2628 /* A preceding string block (or maybe the same one)
2629 where we are copying the still-live strings to. */
2630 register struct string_block
*to_sb
;
2634 to_sb
= first_string_block
;
2637 /* Scan each existing string block sequentially, string by string. */
2638 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2641 /* POS is the index of the next string in the block. */
2642 while (pos
< from_sb
->pos
)
2644 register struct Lisp_String
*nextstr
2645 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2647 register struct Lisp_String
*newaddr
;
2648 register EMACS_INT size
= nextstr
->size
;
2649 EMACS_INT size_byte
= STRING_BYTES (nextstr
);
2651 /* NEXTSTR is the old address of the next string.
2652 Just skip it if it isn't marked. */
2653 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2655 /* It is marked, so its size field is really a chain of refs.
2656 Find the end of the chain, where the actual size lives. */
2657 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2659 if (size
& DONT_COPY_FLAG
)
2660 size
^= MARKBIT
| DONT_COPY_FLAG
;
2661 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2664 total_string_size
+= size_byte
;
2666 /* If it won't fit in TO_SB, close it out,
2667 and move to the next sb. Keep doing so until
2668 TO_SB reaches a large enough, empty enough string block.
2669 We know that TO_SB cannot advance past FROM_SB here
2670 since FROM_SB is large enough to contain this string.
2671 Any string blocks skipped here
2672 will be patched out and freed later. */
2673 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2674 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2676 to_sb
->pos
= to_pos
;
2677 to_sb
= to_sb
->next
;
2680 /* Compute new address of this string
2681 and update TO_POS for the space being used. */
2682 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2683 to_pos
+= STRING_FULLSIZE (size_byte
);
2685 /* Copy the string itself to the new place. */
2686 if (nextstr
!= newaddr
)
2687 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2689 /* Go through NEXTSTR's chain of references
2690 and make each slot in the chain point to
2691 the new address of this string. */
2692 size
= newaddr
->size
;
2693 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2695 register Lisp_Object
*objptr
;
2696 if (size
& DONT_COPY_FLAG
)
2697 size
^= MARKBIT
| DONT_COPY_FLAG
;
2698 objptr
= (Lisp_Object
*)size
;
2700 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2701 if (XMARKBIT (*objptr
))
2703 XSETSTRING (*objptr
, newaddr
);
2707 XSETSTRING (*objptr
, newaddr
);
2709 /* Store the actual size in the size field. */
2710 newaddr
->size
= size
;
2712 #ifdef USE_TEXT_PROPERTIES
2713 /* Now that the string has been relocated, rebalance its
2714 interval tree, and update the tree's parent pointer. */
2715 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2717 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2718 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2721 #endif /* USE_TEXT_PROPERTIES */
2723 pos
+= STRING_FULLSIZE (size_byte
);
2727 /* Close out the last string block still used and free any that follow. */
2728 to_sb
->pos
= to_pos
;
2729 current_string_block
= to_sb
;
2731 from_sb
= to_sb
->next
;
2735 to_sb
= from_sb
->next
;
2740 /* Free any empty string blocks further back in the chain.
2741 This loop will never free first_string_block, but it is very
2742 unlikely that that one will become empty, so why bother checking? */
2744 from_sb
= first_string_block
;
2745 while (to_sb
= from_sb
->next
)
2747 if (to_sb
->pos
== 0)
2749 if (from_sb
->next
= to_sb
->next
)
2750 from_sb
->next
->prev
= from_sb
;
2758 /* Debugging aids. */
2760 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2761 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2762 This may be helpful in debugging Emacs's memory usage.\n\
2763 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2768 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2773 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2774 "Return a list of counters that measure how much consing there has been.\n\
2775 Each of these counters increments for a certain kind of object.\n\
2776 The counters wrap around from the largest positive integer to zero.\n\
2777 Garbage collection does not decrease them.\n\
2778 The elements of the value are as follows:\n\
2779 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2780 All are in units of 1 = one object consed\n\
2781 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2783 MISCS include overlays, markers, and some internal types.\n\
2784 Frames, windows, buffers, and subprocesses count as vectors\n\
2785 (but the contents of a buffer's text do not count here).")
2788 Lisp_Object lisp_cons_cells_consed
;
2789 Lisp_Object lisp_floats_consed
;
2790 Lisp_Object lisp_vector_cells_consed
;
2791 Lisp_Object lisp_symbols_consed
;
2792 Lisp_Object lisp_string_chars_consed
;
2793 Lisp_Object lisp_misc_objects_consed
;
2794 Lisp_Object lisp_intervals_consed
;
2796 XSETINT (lisp_cons_cells_consed
,
2797 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2798 XSETINT (lisp_floats_consed
,
2799 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2800 XSETINT (lisp_vector_cells_consed
,
2801 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2802 XSETINT (lisp_symbols_consed
,
2803 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2804 XSETINT (lisp_string_chars_consed
,
2805 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2806 XSETINT (lisp_misc_objects_consed
,
2807 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2808 XSETINT (lisp_intervals_consed
,
2809 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2811 return Fcons (lisp_cons_cells_consed
,
2812 Fcons (lisp_floats_consed
,
2813 Fcons (lisp_vector_cells_consed
,
2814 Fcons (lisp_symbols_consed
,
2815 Fcons (lisp_string_chars_consed
,
2816 Fcons (lisp_misc_objects_consed
,
2817 Fcons (lisp_intervals_consed
,
2821 /* Initialization */
2825 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2828 pure_size
= PURESIZE
;
2831 ignore_warnings
= 1;
2832 #ifdef DOUG_LEA_MALLOC
2833 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2834 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2835 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2841 #ifdef LISP_FLOAT_TYPE
2843 #endif /* LISP_FLOAT_TYPE */
2847 malloc_hysteresis
= 32;
2849 malloc_hysteresis
= 0;
2852 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2854 ignore_warnings
= 0;
2857 consing_since_gc
= 0;
2858 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2859 #ifdef VIRT_ADDR_VARIES
2860 malloc_sbrk_unused
= 1<<22; /* A large number */
2861 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2862 #endif /* VIRT_ADDR_VARIES */
2873 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2874 "*Number of bytes of consing between garbage collections.\n\
2875 Garbage collection can happen automatically once this many bytes have been\n\
2876 allocated since the last garbage collection. All data types count.\n\n\
2877 Garbage collection happens automatically only when `eval' is called.\n\n\
2878 By binding this temporarily to a large number, you can effectively\n\
2879 prevent garbage collection during a part of the program.");
2881 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2882 "Number of bytes of sharable Lisp data allocated so far.");
2884 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
2885 "Number of cons cells that have been consed so far.");
2887 DEFVAR_INT ("floats-consed", &floats_consed
,
2888 "Number of floats that have been consed so far.");
2890 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
2891 "Number of vector cells that have been consed so far.");
2893 DEFVAR_INT ("symbols-consed", &symbols_consed
,
2894 "Number of symbols that have been consed so far.");
2896 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
2897 "Number of string characters that have been consed so far.");
2899 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
2900 "Number of miscellaneous objects that have been consed so far.");
2902 DEFVAR_INT ("intervals-consed", &intervals_consed
,
2903 "Number of intervals that have been consed so far.");
2906 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2907 "Number of bytes of unshared memory allocated in this session.");
2909 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2910 "Number of bytes of unshared memory remaining available in this session.");
2913 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2914 "Non-nil means loading Lisp code in order to dump an executable.\n\
2915 This means that certain objects should be allocated in shared (pure) space.");
2917 DEFVAR_INT ("undo-limit", &undo_limit
,
2918 "Keep no more undo information once it exceeds this size.\n\
2919 This limit is applied when garbage collection happens.\n\
2920 The size is counted as the number of bytes occupied,\n\
2921 which includes both saved text and other data.");
2924 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2925 "Don't keep more than this much size of undo information.\n\
2926 A command which pushes past this size is itself forgotten.\n\
2927 This limit is applied when garbage collection happens.\n\
2928 The size is counted as the number of bytes occupied,\n\
2929 which includes both saved text and other data.");
2930 undo_strong_limit
= 30000;
2932 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
2933 "Non-nil means display messages at start and end of garbage collection.");
2934 garbage_collection_messages
= 0;
2936 /* We build this in advance because if we wait until we need it, we might
2937 not be able to allocate the memory to hold it. */
2939 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2940 staticpro (&memory_signal_data
);
2942 staticpro (&Qgc_cons_threshold
);
2943 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2945 staticpro (&Qchar_table_extra_slots
);
2946 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2951 defsubr (&Smake_byte_code
);
2952 defsubr (&Smake_list
);
2953 defsubr (&Smake_vector
);
2954 defsubr (&Smake_char_table
);
2955 defsubr (&Smake_string
);
2956 defsubr (&Smake_bool_vector
);
2957 defsubr (&Smake_symbol
);
2958 defsubr (&Smake_marker
);
2959 defsubr (&Spurecopy
);
2960 defsubr (&Sgarbage_collect
);
2961 defsubr (&Smemory_limit
);
2962 defsubr (&Smemory_use_counts
);