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. */
32 #include "intervals.h"
38 #include "blockinput.h"
43 #include "syssignal.h"
47 #ifdef DOUG_LEA_MALLOC
49 #define __malloc_size_t int
51 /* Specify maximum number of areas to mmap.
52 It would be nice to use a value that explicitly
54 #define MMAP_MAX_AREAS 100000000
57 /* The following come from gmalloc.c. */
59 #if defined (__STDC__) && __STDC__
61 #define __malloc_size_t size_t
63 #define __malloc_size_t unsigned int
65 extern __malloc_size_t _bytes_used
;
66 extern int __malloc_extra_blocks
;
67 #endif /* !defined(DOUG_LEA_MALLOC) */
69 #define max(A,B) ((A) > (B) ? (A) : (B))
70 #define min(A,B) ((A) < (B) ? (A) : (B))
72 /* Macro to verify that storage intended for Lisp objects is not
73 out of range to fit in the space for a pointer.
74 ADDRESS is the start of the block, and SIZE
75 is the amount of space within which objects can start. */
76 #define VALIDATE_LISP_STORAGE(address, size) \
80 XSETCONS (val, (char *) address + size); \
81 if ((char *) XCONS (val) != (char *) address + size) \
88 /* Value of _bytes_used, when spare_memory was freed. */
89 static __malloc_size_t bytes_used_when_full
;
91 /* Number of bytes of consing done since the last gc */
94 /* Count the amount of consing of various sorts of space. */
95 int cons_cells_consed
;
97 int vector_cells_consed
;
99 int string_chars_consed
;
100 int misc_objects_consed
;
101 int intervals_consed
;
103 /* Number of bytes of consing since gc before another gc should be done. */
104 int gc_cons_threshold
;
106 /* Nonzero during gc */
109 /* Nonzero means display messages at beginning and end of GC. */
110 int garbage_collection_messages
;
112 #ifndef VIRT_ADDR_VARIES
114 #endif /* VIRT_ADDR_VARIES */
115 int malloc_sbrk_used
;
117 #ifndef VIRT_ADDR_VARIES
119 #endif /* VIRT_ADDR_VARIES */
120 int malloc_sbrk_unused
;
122 /* Two limits controlling how much undo information to keep. */
124 int undo_strong_limit
;
126 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
127 int total_free_conses
, total_free_markers
, total_free_symbols
;
128 #ifdef LISP_FLOAT_TYPE
129 int total_free_floats
, total_floats
;
130 #endif /* LISP_FLOAT_TYPE */
132 /* Points to memory space allocated as "spare",
133 to be freed if we run out of memory. */
134 static char *spare_memory
;
136 /* Amount of spare memory to keep in reserve. */
137 #define SPARE_MEMORY (1 << 14)
139 /* Number of extra blocks malloc should get when it needs more core. */
140 static int malloc_hysteresis
;
142 /* Nonzero when malloc is called for allocating Lisp object space. */
143 int allocating_for_lisp
;
145 /* Non-nil means defun should do purecopy on the function definition */
146 Lisp_Object Vpurify_flag
;
149 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
150 #define PUREBEG (char *) pure
152 #define pure PURE_SEG_BITS /* Use shared memory segment */
153 #define PUREBEG (char *)PURE_SEG_BITS
155 /* This variable is used only by the XPNTR macro when HAVE_SHM is
156 defined. If we used the PURESIZE macro directly there, that would
157 make most of emacs dependent on puresize.h, which we don't want -
158 you should be able to change that without too much recompilation.
159 So map_in_data initializes pure_size, and the dependencies work
162 #endif /* not HAVE_SHM */
164 /* Index in pure at which next pure object will be allocated. */
167 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
168 char *pending_malloc_warning
;
170 /* Pre-computed signal argument for use when memory is exhausted. */
171 Lisp_Object memory_signal_data
;
173 /* Maximum amount of C stack to save when a GC happens. */
175 #ifndef MAX_SAVE_STACK
176 #define MAX_SAVE_STACK 16000
179 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
180 pointer to a Lisp_Object, when that pointer is viewed as an integer.
181 (On most machines, pointers are even, so we can use the low bit.
182 Word-addressable architectures may need to override this in the m-file.)
183 When linking references to small strings through the size field, we
184 use this slot to hold the bit that would otherwise be interpreted as
186 #ifndef DONT_COPY_FLAG
187 #define DONT_COPY_FLAG 1
188 #endif /* no DONT_COPY_FLAG */
190 /* Buffer in which we save a copy of the C stack at each GC. */
195 /* Non-zero means ignore malloc warnings. Set during initialization. */
198 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
200 static void mark_buffer (), mark_kboards ();
201 static void clear_marks (), gc_sweep ();
202 static void compact_strings ();
203 static void mark_glyph_matrix
P_ ((struct glyph_matrix
*));
204 static void mark_face_cache
P_ ((struct face_cache
*));
206 #ifdef HAVE_WINDOW_SYSTEM
207 static void mark_image
P_ ((struct image
*));
208 static void mark_image_cache
P_ ((struct frame
*));
209 #endif /* HAVE_WINDOW_SYSTEM */
212 extern int message_enable_multibyte
;
214 /* Versions of malloc and realloc that print warnings as memory gets full. */
217 malloc_warning_1 (str
)
220 Fprinc (str
, Vstandard_output
);
221 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
222 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
223 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
227 /* malloc calls this if it finds we are near exhausting storage */
233 pending_malloc_warning
= str
;
237 display_malloc_warning ()
239 register Lisp_Object val
;
241 val
= build_string (pending_malloc_warning
);
242 pending_malloc_warning
= 0;
243 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
246 #ifdef DOUG_LEA_MALLOC
247 # define BYTES_USED (mallinfo ().arena)
249 # define BYTES_USED _bytes_used
252 /* Called if malloc returns zero */
257 #ifndef SYSTEM_MALLOC
258 bytes_used_when_full
= BYTES_USED
;
261 /* The first time we get here, free the spare memory. */
268 /* This used to call error, but if we've run out of memory, we could get
269 infinite recursion trying to build the string. */
271 Fsignal (Qnil
, memory_signal_data
);
274 /* Called if we can't allocate relocatable space for a buffer. */
277 buffer_memory_full ()
279 /* If buffers use the relocating allocator,
280 no need to free spare_memory, because we may have plenty of malloc
281 space left that we could get, and if we don't, the malloc that fails
282 will itself cause spare_memory to be freed.
283 If buffers don't use the relocating allocator,
284 treat this like any other failing malloc. */
290 /* This used to call error, but if we've run out of memory, we could get
291 infinite recursion trying to build the string. */
293 Fsignal (Qerror
, memory_signal_data
);
296 /* Like malloc routines but check for no memory and block interrupt input. */
305 val
= (long *) malloc (size
);
308 if (!val
&& size
) memory_full ();
313 xrealloc (block
, size
)
320 /* We must call malloc explicitly when BLOCK is 0, since some
321 reallocs don't do this. */
323 val
= (long *) malloc (size
);
325 val
= (long *) realloc (block
, size
);
328 if (!val
&& size
) memory_full ();
341 /* Like malloc but used for allocating Lisp data. */
350 allocating_for_lisp
++;
351 val
= (long *) malloc (size
);
352 allocating_for_lisp
--;
355 if (!val
&& size
) memory_full ();
364 allocating_for_lisp
++;
366 allocating_for_lisp
--;
370 /* Arranging to disable input signals while we're in malloc.
372 This only works with GNU malloc. To help out systems which can't
373 use GNU malloc, all the calls to malloc, realloc, and free
374 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
375 pairs; unfortunately, we have no idea what C library functions
376 might call malloc, so we can't really protect them unless you're
377 using GNU malloc. Fortunately, most of the major operating can use
380 #ifndef SYSTEM_MALLOC
381 extern void * (*__malloc_hook
) ();
382 static void * (*old_malloc_hook
) ();
383 extern void * (*__realloc_hook
) ();
384 static void * (*old_realloc_hook
) ();
385 extern void (*__free_hook
) ();
386 static void (*old_free_hook
) ();
388 /* This function is used as the hook for free to call. */
391 emacs_blocked_free (ptr
)
395 __free_hook
= old_free_hook
;
397 /* If we released our reserve (due to running out of memory),
398 and we have a fair amount free once again,
399 try to set aside another reserve in case we run out once more. */
400 if (spare_memory
== 0
401 /* Verify there is enough space that even with the malloc
402 hysteresis this call won't run out again.
403 The code here is correct as long as SPARE_MEMORY
404 is substantially larger than the block size malloc uses. */
405 && (bytes_used_when_full
406 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
407 spare_memory
= (char *) malloc (SPARE_MEMORY
);
409 __free_hook
= emacs_blocked_free
;
413 /* If we released our reserve (due to running out of memory),
414 and we have a fair amount free once again,
415 try to set aside another reserve in case we run out once more.
417 This is called when a relocatable block is freed in ralloc.c. */
420 refill_memory_reserve ()
422 if (spare_memory
== 0)
423 spare_memory
= (char *) malloc (SPARE_MEMORY
);
426 /* This function is the malloc hook that Emacs uses. */
429 emacs_blocked_malloc (size
)
435 __malloc_hook
= old_malloc_hook
;
436 #ifdef DOUG_LEA_MALLOC
437 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
439 __malloc_extra_blocks
= malloc_hysteresis
;
441 value
= (void *) malloc (size
);
442 __malloc_hook
= emacs_blocked_malloc
;
449 emacs_blocked_realloc (ptr
, size
)
456 __realloc_hook
= old_realloc_hook
;
457 value
= (void *) realloc (ptr
, size
);
458 __realloc_hook
= emacs_blocked_realloc
;
465 uninterrupt_malloc ()
467 if (__free_hook
!= emacs_blocked_free
)
468 old_free_hook
= __free_hook
;
469 __free_hook
= emacs_blocked_free
;
471 if (__malloc_hook
!= emacs_blocked_malloc
)
472 old_malloc_hook
= __malloc_hook
;
473 __malloc_hook
= emacs_blocked_malloc
;
475 if (__realloc_hook
!= emacs_blocked_realloc
)
476 old_realloc_hook
= __realloc_hook
;
477 __realloc_hook
= emacs_blocked_realloc
;
481 /* Interval allocation. */
483 #ifdef USE_TEXT_PROPERTIES
484 #define INTERVAL_BLOCK_SIZE \
485 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
487 struct interval_block
489 struct interval_block
*next
;
490 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
493 struct interval_block
*interval_block
;
494 static int interval_block_index
;
496 INTERVAL interval_free_list
;
498 /* Total number of interval blocks now in use. */
499 int n_interval_blocks
;
505 = (struct interval_block
*) lisp_malloc (sizeof (struct interval_block
));
506 interval_block
->next
= 0;
507 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
508 interval_block_index
= 0;
509 interval_free_list
= 0;
510 n_interval_blocks
= 1;
513 #define INIT_INTERVALS init_intervals ()
520 if (interval_free_list
)
522 val
= interval_free_list
;
523 interval_free_list
= interval_free_list
->parent
;
527 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
529 register struct interval_block
*newi
;
531 newi
= (struct interval_block
*) lisp_malloc (sizeof (struct interval_block
));
533 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
534 newi
->next
= interval_block
;
535 interval_block
= newi
;
536 interval_block_index
= 0;
539 val
= &interval_block
->intervals
[interval_block_index
++];
541 consing_since_gc
+= sizeof (struct interval
);
543 RESET_INTERVAL (val
);
547 static int total_free_intervals
, total_intervals
;
549 /* Mark the pointers of one interval. */
552 mark_interval (i
, dummy
)
556 if (XMARKBIT (i
->plist
))
558 mark_object (&i
->plist
);
563 mark_interval_tree (tree
)
564 register INTERVAL tree
;
566 /* No need to test if this tree has been marked already; this
567 function is always called through the MARK_INTERVAL_TREE macro,
568 which takes care of that. */
570 /* XMARK expands to an assignment; the LHS of an assignment can't be
572 XMARK (* (Lisp_Object
*) &tree
->parent
);
574 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
577 #define MARK_INTERVAL_TREE(i) \
579 if (!NULL_INTERVAL_P (i) \
580 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
581 mark_interval_tree (i); \
584 /* The oddity in the call to XUNMARK is necessary because XUNMARK
585 expands to an assignment to its argument, and most C compilers don't
586 support casts on the left operand of `='. */
587 #define UNMARK_BALANCE_INTERVALS(i) \
589 if (! NULL_INTERVAL_P (i)) \
591 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
592 (i) = balance_intervals (i); \
596 #else /* no interval use */
598 #define INIT_INTERVALS
600 #define UNMARK_BALANCE_INTERVALS(i)
601 #define MARK_INTERVAL_TREE(i)
603 #endif /* no interval use */
605 /* Floating point allocation. */
607 #ifdef LISP_FLOAT_TYPE
608 /* Allocation of float cells, just like conses */
609 /* We store float cells inside of float_blocks, allocating a new
610 float_block with malloc whenever necessary. Float cells reclaimed by
611 GC are put on a free list to be reallocated before allocating
612 any new float cells from the latest float_block.
614 Each float_block is just under 1020 bytes long,
615 since malloc really allocates in units of powers of two
616 and uses 4 bytes for its own overhead. */
618 #define FLOAT_BLOCK_SIZE \
619 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
623 struct float_block
*next
;
624 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
627 struct float_block
*float_block
;
628 int float_block_index
;
630 /* Total number of float blocks now in use. */
633 struct Lisp_Float
*float_free_list
;
638 float_block
= (struct float_block
*) lisp_malloc (sizeof (struct float_block
));
639 float_block
->next
= 0;
640 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
641 float_block_index
= 0;
646 /* Explicitly free a float cell. */
649 struct Lisp_Float
*ptr
;
651 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
652 float_free_list
= ptr
;
656 make_float (float_value
)
659 register Lisp_Object val
;
663 /* We use the data field for chaining the free list
664 so that we won't use the same field that has the mark bit. */
665 XSETFLOAT (val
, float_free_list
);
666 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
670 if (float_block_index
== FLOAT_BLOCK_SIZE
)
672 register struct float_block
*new;
674 new = (struct float_block
*) lisp_malloc (sizeof (struct float_block
));
675 VALIDATE_LISP_STORAGE (new, sizeof *new);
676 new->next
= float_block
;
678 float_block_index
= 0;
681 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
683 XFLOAT (val
)->data
= float_value
;
684 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
685 consing_since_gc
+= sizeof (struct Lisp_Float
);
690 #endif /* LISP_FLOAT_TYPE */
692 /* Allocation of cons cells */
693 /* We store cons cells inside of cons_blocks, allocating a new
694 cons_block with malloc whenever necessary. Cons cells reclaimed by
695 GC are put on a free list to be reallocated before allocating
696 any new cons cells from the latest cons_block.
698 Each cons_block is just under 1020 bytes long,
699 since malloc really allocates in units of powers of two
700 and uses 4 bytes for its own overhead. */
702 #define CONS_BLOCK_SIZE \
703 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
707 struct cons_block
*next
;
708 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
711 struct cons_block
*cons_block
;
712 int cons_block_index
;
714 struct Lisp_Cons
*cons_free_list
;
716 /* Total number of cons blocks now in use. */
722 cons_block
= (struct cons_block
*) lisp_malloc (sizeof (struct cons_block
));
723 cons_block
->next
= 0;
724 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
725 cons_block_index
= 0;
730 /* Explicitly free a cons cell. */
734 struct Lisp_Cons
*ptr
;
736 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
737 cons_free_list
= ptr
;
740 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
741 "Create a new cons, give it CAR and CDR as components, and return it.")
743 Lisp_Object car
, cdr
;
745 register Lisp_Object val
;
749 /* We use the cdr for chaining the free list
750 so that we won't use the same field that has the mark bit. */
751 XSETCONS (val
, cons_free_list
);
752 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
756 if (cons_block_index
== CONS_BLOCK_SIZE
)
758 register struct cons_block
*new;
759 new = (struct cons_block
*) lisp_malloc (sizeof (struct cons_block
));
760 VALIDATE_LISP_STORAGE (new, sizeof *new);
761 new->next
= cons_block
;
763 cons_block_index
= 0;
766 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
768 XCONS (val
)->car
= car
;
769 XCONS (val
)->cdr
= cdr
;
770 consing_since_gc
+= sizeof (struct Lisp_Cons
);
775 /* Make a list of 2, 3, 4 or 5 specified objects. */
779 Lisp_Object arg1
, arg2
;
781 return Fcons (arg1
, Fcons (arg2
, Qnil
));
785 list3 (arg1
, arg2
, arg3
)
786 Lisp_Object arg1
, arg2
, arg3
;
788 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
792 list4 (arg1
, arg2
, arg3
, arg4
)
793 Lisp_Object arg1
, arg2
, arg3
, arg4
;
795 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
799 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
800 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
802 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
803 Fcons (arg5
, Qnil
)))));
806 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
807 "Return a newly created list with specified arguments as elements.\n\
808 Any number of arguments, even zero arguments, are allowed.")
811 register Lisp_Object
*args
;
813 register Lisp_Object val
;
819 val
= Fcons (args
[nargs
], val
);
824 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
825 "Return a newly created list of length LENGTH, with each element being INIT.")
827 register Lisp_Object length
, init
;
829 register Lisp_Object val
;
832 CHECK_NATNUM (length
, 0);
833 size
= XFASTINT (length
);
837 val
= Fcons (init
, val
);
841 /* Allocation of vectors */
843 struct Lisp_Vector
*all_vectors
;
845 /* Total number of vectorlike objects now in use. */
849 allocate_vectorlike (len
)
852 struct Lisp_Vector
*p
;
854 #ifdef DOUG_LEA_MALLOC
855 /* Prevent mmap'ing the chunk (which is potentially very large). */
856 mallopt (M_MMAP_MAX
, 0);
858 p
= (struct Lisp_Vector
*)lisp_malloc (sizeof (struct Lisp_Vector
)
859 + (len
- 1) * sizeof (Lisp_Object
));
860 #ifdef DOUG_LEA_MALLOC
861 /* Back to a reasonable maximum of mmap'ed areas. */
862 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
864 VALIDATE_LISP_STORAGE (p
, 0);
865 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
866 + (len
- 1) * sizeof (Lisp_Object
));
867 vector_cells_consed
+= len
;
870 p
->next
= all_vectors
;
875 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
876 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
877 See also the function `vector'.")
879 register Lisp_Object length
, init
;
882 register EMACS_INT sizei
;
884 register struct Lisp_Vector
*p
;
886 CHECK_NATNUM (length
, 0);
887 sizei
= XFASTINT (length
);
889 p
= allocate_vectorlike (sizei
);
891 for (index
= 0; index
< sizei
; index
++)
892 p
->contents
[index
] = init
;
894 XSETVECTOR (vector
, p
);
898 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
899 "Return a newly created char-table, with purpose PURPOSE.\n\
900 Each element is initialized to INIT, which defaults to nil.\n\
901 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
902 The property's value should be an integer between 0 and 10.")
904 register Lisp_Object purpose
, init
;
908 CHECK_SYMBOL (purpose
, 1);
909 n
= Fget (purpose
, Qchar_table_extra_slots
);
911 if (XINT (n
) < 0 || XINT (n
) > 10)
912 args_out_of_range (n
, Qnil
);
913 /* Add 2 to the size for the defalt and parent slots. */
914 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
916 XCHAR_TABLE (vector
)->top
= Qt
;
917 XCHAR_TABLE (vector
)->parent
= Qnil
;
918 XCHAR_TABLE (vector
)->purpose
= purpose
;
919 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
923 /* Return a newly created sub char table with default value DEFALT.
924 Since a sub char table does not appear as a top level Emacs Lisp
925 object, we don't need a Lisp interface to make it. */
928 make_sub_char_table (defalt
)
932 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
933 XCHAR_TABLE (vector
)->top
= Qnil
;
934 XCHAR_TABLE (vector
)->defalt
= defalt
;
935 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
939 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
940 "Return a newly created vector with specified arguments as elements.\n\
941 Any number of arguments, even zero arguments, are allowed.")
946 register Lisp_Object len
, val
;
948 register struct Lisp_Vector
*p
;
950 XSETFASTINT (len
, nargs
);
951 val
= Fmake_vector (len
, Qnil
);
953 for (index
= 0; index
< nargs
; index
++)
954 p
->contents
[index
] = args
[index
];
958 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
959 "Create a byte-code object with specified arguments as elements.\n\
960 The arguments should be the arglist, bytecode-string, constant vector,\n\
961 stack size, (optional) doc string, and (optional) interactive spec.\n\
962 The first four arguments are required; at most six have any\n\
968 register Lisp_Object len
, val
;
970 register struct Lisp_Vector
*p
;
972 XSETFASTINT (len
, nargs
);
973 if (!NILP (Vpurify_flag
))
974 val
= make_pure_vector ((EMACS_INT
) nargs
);
976 val
= Fmake_vector (len
, Qnil
);
978 for (index
= 0; index
< nargs
; index
++)
980 if (!NILP (Vpurify_flag
))
981 args
[index
] = Fpurecopy (args
[index
]);
982 p
->contents
[index
] = args
[index
];
984 XSETCOMPILED (val
, p
);
988 /* Allocation of symbols.
989 Just like allocation of conses!
991 Each symbol_block is just under 1020 bytes long,
992 since malloc really allocates in units of powers of two
993 and uses 4 bytes for its own overhead. */
995 #define SYMBOL_BLOCK_SIZE \
996 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
1000 struct symbol_block
*next
;
1001 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
1004 struct symbol_block
*symbol_block
;
1005 int symbol_block_index
;
1007 struct Lisp_Symbol
*symbol_free_list
;
1009 /* Total number of symbol blocks now in use. */
1010 int n_symbol_blocks
;
1015 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof (struct symbol_block
));
1016 symbol_block
->next
= 0;
1017 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
1018 symbol_block_index
= 0;
1019 symbol_free_list
= 0;
1020 n_symbol_blocks
= 1;
1023 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
1024 "Return a newly allocated uninterned symbol whose name is NAME.\n\
1025 Its value and function definition are void, and its property list is nil.")
1029 register Lisp_Object val
;
1030 register struct Lisp_Symbol
*p
;
1032 CHECK_STRING (name
, 0);
1034 if (symbol_free_list
)
1036 XSETSYMBOL (val
, symbol_free_list
);
1037 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
1041 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
1043 struct symbol_block
*new;
1044 new = (struct symbol_block
*) lisp_malloc (sizeof (struct symbol_block
));
1045 VALIDATE_LISP_STORAGE (new, sizeof *new);
1046 new->next
= symbol_block
;
1048 symbol_block_index
= 0;
1051 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
1054 p
->name
= XSTRING (name
);
1057 p
->value
= Qunbound
;
1058 p
->function
= Qunbound
;
1060 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
1065 /* Allocation of markers and other objects that share that structure.
1066 Works like allocation of conses. */
1068 #define MARKER_BLOCK_SIZE \
1069 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
1073 struct marker_block
*next
;
1074 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
1077 struct marker_block
*marker_block
;
1078 int marker_block_index
;
1080 union Lisp_Misc
*marker_free_list
;
1082 /* Total number of marker blocks now in use. */
1083 int n_marker_blocks
;
1088 marker_block
= (struct marker_block
*) lisp_malloc (sizeof (struct marker_block
));
1089 marker_block
->next
= 0;
1090 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1091 marker_block_index
= 0;
1092 marker_free_list
= 0;
1093 n_marker_blocks
= 1;
1096 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1102 if (marker_free_list
)
1104 XSETMISC (val
, marker_free_list
);
1105 marker_free_list
= marker_free_list
->u_free
.chain
;
1109 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1111 struct marker_block
*new;
1112 new = (struct marker_block
*) lisp_malloc (sizeof (struct marker_block
));
1113 VALIDATE_LISP_STORAGE (new, sizeof *new);
1114 new->next
= marker_block
;
1116 marker_block_index
= 0;
1119 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1121 consing_since_gc
+= sizeof (union Lisp_Misc
);
1122 misc_objects_consed
++;
1126 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1127 "Return a newly allocated marker which does not point at any place.")
1130 register Lisp_Object val
;
1131 register struct Lisp_Marker
*p
;
1133 val
= allocate_misc ();
1134 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1140 p
->insertion_type
= 0;
1144 /* Put MARKER back on the free list after using it temporarily. */
1147 free_marker (marker
)
1150 unchain_marker (marker
);
1152 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1153 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1154 marker_free_list
= XMISC (marker
);
1156 total_free_markers
++;
1159 /* Allocation of strings */
1161 /* Strings reside inside of string_blocks. The entire data of the string,
1162 both the size and the contents, live in part of the `chars' component of a string_block.
1163 The `pos' component is the index within `chars' of the first free byte.
1165 first_string_block points to the first string_block ever allocated.
1166 Each block points to the next one with its `next' field.
1167 The `prev' fields chain in reverse order.
1168 The last one allocated is the one currently being filled.
1169 current_string_block points to it.
1171 The string_blocks that hold individual large strings
1172 go in a separate chain, started by large_string_blocks. */
1175 /* String blocks contain this many useful bytes.
1176 8188 is power of 2, minus 4 for malloc overhead. */
1177 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1179 /* A string bigger than this gets its own specially-made string block
1180 if it doesn't fit in the current one. */
1181 #define STRING_BLOCK_OUTSIZE 1024
1183 struct string_block_head
1185 struct string_block
*next
, *prev
;
1191 struct string_block
*next
, *prev
;
1193 char chars
[STRING_BLOCK_SIZE
];
1196 /* This points to the string block we are now allocating strings. */
1198 struct string_block
*current_string_block
;
1200 /* This points to the oldest string block, the one that starts the chain. */
1202 struct string_block
*first_string_block
;
1204 /* Last string block in chain of those made for individual large strings. */
1206 struct string_block
*large_string_blocks
;
1208 /* If SIZE is the length of a string, this returns how many bytes
1209 the string occupies in a string_block (including padding). */
1211 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1212 & ~(STRING_PAD - 1))
1213 /* Add 1 for the null terminator,
1214 and add STRING_PAD - 1 as part of rounding up. */
1216 #define STRING_PAD (sizeof (EMACS_INT))
1217 /* Size of the stuff in the string not including its data. */
1218 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1221 #define STRING_FULLSIZE(SIZE) \
1222 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1225 /* Total number of string blocks now in use. */
1226 int n_string_blocks
;
1231 current_string_block
= (struct string_block
*) lisp_malloc (sizeof (struct string_block
));
1232 first_string_block
= current_string_block
;
1233 consing_since_gc
+= sizeof (struct string_block
);
1234 current_string_block
->next
= 0;
1235 current_string_block
->prev
= 0;
1236 current_string_block
->pos
= 0;
1237 large_string_blocks
= 0;
1238 n_string_blocks
= 1;
1241 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1242 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1243 Both LENGTH and INIT must be numbers.")
1245 Lisp_Object length
, init
;
1247 register Lisp_Object val
;
1248 register unsigned char *p
, *end
;
1251 CHECK_NATNUM (length
, 0);
1252 CHECK_NUMBER (init
, 1);
1255 if (SINGLE_BYTE_CHAR_P (c
))
1257 nbytes
= XINT (length
);
1258 val
= make_uninit_string (nbytes
);
1259 p
= XSTRING (val
)->data
;
1260 end
= p
+ XSTRING (val
)->size
;
1266 unsigned char work
[4], *str
;
1267 int len
= CHAR_STRING (c
, work
, str
);
1269 nbytes
= len
* XINT (length
);
1270 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1271 p
= XSTRING (val
)->data
;
1275 bcopy (str
, p
, len
);
1283 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1284 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1285 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1287 Lisp_Object length
, init
;
1289 register Lisp_Object val
;
1290 struct Lisp_Bool_Vector
*p
;
1292 int length_in_chars
, length_in_elts
, bits_per_value
;
1294 CHECK_NATNUM (length
, 0);
1296 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1298 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1299 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1301 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1302 slot `size' of the struct Lisp_Bool_Vector. */
1303 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1304 p
= XBOOL_VECTOR (val
);
1305 /* Get rid of any bits that would cause confusion. */
1307 XSETBOOL_VECTOR (val
, p
);
1308 p
->size
= XFASTINT (length
);
1310 real_init
= (NILP (init
) ? 0 : -1);
1311 for (i
= 0; i
< length_in_chars
; i
++)
1312 p
->data
[i
] = real_init
;
1313 /* Clear the extraneous bits in the last byte. */
1314 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1315 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1316 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1321 /* Make a string from NBYTES bytes at CONTENTS,
1322 and compute the number of characters from the contents.
1323 This string may be unibyte or multibyte, depending on the contents. */
1326 make_string (contents
, nbytes
)
1330 register Lisp_Object val
;
1331 int nchars
= chars_in_text (contents
, nbytes
);
1332 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1333 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1334 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1335 SET_STRING_BYTES (XSTRING (val
), -1);
1339 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
1342 make_unibyte_string (contents
, length
)
1346 register Lisp_Object val
;
1347 val
= make_uninit_string (length
);
1348 bcopy (contents
, XSTRING (val
)->data
, length
);
1349 SET_STRING_BYTES (XSTRING (val
), -1);
1353 /* Make a multibyte string from NCHARS characters
1354 occupying NBYTES bytes at CONTENTS. */
1357 make_multibyte_string (contents
, nchars
, nbytes
)
1361 register Lisp_Object val
;
1362 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1363 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1367 /* Make a string from NCHARS characters
1368 occupying NBYTES bytes at CONTENTS.
1369 It is a multibyte string if NBYTES != NCHARS. */
1372 make_string_from_bytes (contents
, nchars
, nbytes
)
1376 register Lisp_Object val
;
1377 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1378 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1379 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1380 SET_STRING_BYTES (XSTRING (val
), -1);
1384 /* Make a multibyte string from NCHARS characters
1385 occupying NBYTES bytes at CONTENTS. */
1388 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1393 register Lisp_Object val
;
1394 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1395 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1397 SET_STRING_BYTES (XSTRING (val
), -1);
1401 /* Make a string from the data at STR,
1402 treating it as multibyte if the data warrants. */
1408 return make_string (str
, strlen (str
));
1412 make_uninit_string (length
)
1416 val
= make_uninit_multibyte_string (length
, length
);
1417 SET_STRING_BYTES (XSTRING (val
), -1);
1422 make_uninit_multibyte_string (length
, length_byte
)
1423 int length
, length_byte
;
1425 register Lisp_Object val
;
1426 register int fullsize
= STRING_FULLSIZE (length_byte
);
1428 if (length
< 0) abort ();
1430 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1431 /* This string can fit in the current string block */
1434 ((struct Lisp_String
*)
1435 (current_string_block
->chars
+ current_string_block
->pos
)));
1436 current_string_block
->pos
+= fullsize
;
1438 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1439 /* This string gets its own string block */
1441 register struct string_block
*new;
1442 #ifdef DOUG_LEA_MALLOC
1443 /* Prevent mmap'ing the chunk (which is potentially very large). */
1444 mallopt (M_MMAP_MAX
, 0);
1446 new = (struct string_block
*) lisp_malloc (sizeof (struct string_block_head
) + fullsize
);
1447 #ifdef DOUG_LEA_MALLOC
1448 /* Back to a reasonable maximum of mmap'ed areas. */
1449 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1452 VALIDATE_LISP_STORAGE (new, 0);
1453 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1454 new->pos
= fullsize
;
1455 new->next
= large_string_blocks
;
1456 large_string_blocks
= new;
1458 ((struct Lisp_String
*)
1459 ((struct string_block_head
*)new + 1)));
1462 /* Make a new current string block and start it off with this string */
1464 register struct string_block
*new;
1465 new = (struct string_block
*) lisp_malloc (sizeof (struct string_block
));
1467 VALIDATE_LISP_STORAGE (new, sizeof *new);
1468 consing_since_gc
+= sizeof (struct string_block
);
1469 current_string_block
->next
= new;
1470 new->prev
= current_string_block
;
1472 current_string_block
= new;
1473 new->pos
= fullsize
;
1475 (struct Lisp_String
*) current_string_block
->chars
);
1478 string_chars_consed
+= fullsize
;
1479 XSTRING (val
)->size
= length
;
1480 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1481 XSTRING (val
)->data
[length_byte
] = 0;
1482 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1487 /* Return a newly created vector or string with specified arguments as
1488 elements. If all the arguments are characters that can fit
1489 in a string of events, make a string; otherwise, make a vector.
1491 Any number of arguments, even zero arguments, are allowed. */
1494 make_event_array (nargs
, args
)
1500 for (i
= 0; i
< nargs
; i
++)
1501 /* The things that fit in a string
1502 are characters that are in 0...127,
1503 after discarding the meta bit and all the bits above it. */
1504 if (!INTEGERP (args
[i
])
1505 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1506 return Fvector (nargs
, args
);
1508 /* Since the loop exited, we know that all the things in it are
1509 characters, so we can make a string. */
1513 result
= Fmake_string (make_number (nargs
), make_number (0));
1514 for (i
= 0; i
< nargs
; i
++)
1516 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1517 /* Move the meta bit to the right place for a string char. */
1518 if (XINT (args
[i
]) & CHAR_META
)
1519 XSTRING (result
)->data
[i
] |= 0x80;
1526 /* Pure storage management. */
1528 /* Must get an error if pure storage is full,
1529 since if it cannot hold a large string
1530 it may be able to hold conses that point to that string;
1531 then the string is not protected from gc. */
1534 make_pure_string (data
, length
, length_byte
, multibyte
)
1541 register Lisp_Object
new;
1542 register int size
= STRING_FULLSIZE (length_byte
);
1544 if (pureptr
+ size
> PURESIZE
)
1545 error ("Pure Lisp storage exhausted");
1546 XSETSTRING (new, PUREBEG
+ pureptr
);
1547 XSTRING (new)->size
= length
;
1548 SET_STRING_BYTES (XSTRING (new), (multibyte
? length_byte
: -1));
1549 bcopy (data
, XSTRING (new)->data
, length_byte
);
1550 XSTRING (new)->data
[length_byte
] = 0;
1552 /* We must give strings in pure storage some kind of interval. So we
1553 give them a null one. */
1554 #if defined (USE_TEXT_PROPERTIES)
1555 XSTRING (new)->intervals
= NULL_INTERVAL
;
1562 pure_cons (car
, cdr
)
1563 Lisp_Object car
, cdr
;
1565 register Lisp_Object
new;
1567 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1568 error ("Pure Lisp storage exhausted");
1569 XSETCONS (new, PUREBEG
+ pureptr
);
1570 pureptr
+= sizeof (struct Lisp_Cons
);
1571 XCONS (new)->car
= Fpurecopy (car
);
1572 XCONS (new)->cdr
= Fpurecopy (cdr
);
1576 #ifdef LISP_FLOAT_TYPE
1579 make_pure_float (num
)
1582 register Lisp_Object
new;
1584 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1585 (double) boundary. Some architectures (like the sparc) require
1586 this, and I suspect that floats are rare enough that it's no
1587 tragedy for those that do. */
1590 char *p
= PUREBEG
+ pureptr
;
1594 alignment
= __alignof (struct Lisp_Float
);
1596 alignment
= sizeof (struct Lisp_Float
);
1599 alignment
= sizeof (struct Lisp_Float
);
1601 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1602 pureptr
= p
- PUREBEG
;
1605 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1606 error ("Pure Lisp storage exhausted");
1607 XSETFLOAT (new, PUREBEG
+ pureptr
);
1608 pureptr
+= sizeof (struct Lisp_Float
);
1609 XFLOAT (new)->data
= num
;
1610 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1614 #endif /* LISP_FLOAT_TYPE */
1617 make_pure_vector (len
)
1620 register Lisp_Object
new;
1621 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1623 if (pureptr
+ size
> PURESIZE
)
1624 error ("Pure Lisp storage exhausted");
1626 XSETVECTOR (new, PUREBEG
+ pureptr
);
1628 XVECTOR (new)->size
= len
;
1632 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1633 "Make a copy of OBJECT in pure storage.\n\
1634 Recursively copies contents of vectors and cons cells.\n\
1635 Does not copy symbols.")
1637 register Lisp_Object obj
;
1639 if (NILP (Vpurify_flag
))
1642 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1643 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1647 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1648 #ifdef LISP_FLOAT_TYPE
1649 else if (FLOATP (obj
))
1650 return make_pure_float (XFLOAT (obj
)->data
);
1651 #endif /* LISP_FLOAT_TYPE */
1652 else if (STRINGP (obj
))
1653 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1654 STRING_BYTES (XSTRING (obj
)),
1655 STRING_MULTIBYTE (obj
));
1656 else if (COMPILEDP (obj
) || VECTORP (obj
))
1658 register struct Lisp_Vector
*vec
;
1659 register int i
, size
;
1661 size
= XVECTOR (obj
)->size
;
1662 if (size
& PSEUDOVECTOR_FLAG
)
1663 size
&= PSEUDOVECTOR_SIZE_MASK
;
1664 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1665 for (i
= 0; i
< size
; i
++)
1666 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1667 if (COMPILEDP (obj
))
1668 XSETCOMPILED (obj
, vec
);
1670 XSETVECTOR (obj
, vec
);
1673 else if (MARKERP (obj
))
1674 error ("Attempt to copy a marker to pure storage");
1679 /* Recording what needs to be marked for gc. */
1681 struct gcpro
*gcprolist
;
1683 #define NSTATICS 1024
1685 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1689 /* Put an entry in staticvec, pointing at the variable whose address is given */
1692 staticpro (varaddress
)
1693 Lisp_Object
*varaddress
;
1695 staticvec
[staticidx
++] = varaddress
;
1696 if (staticidx
>= NSTATICS
)
1704 struct catchtag
*next
;
1705 #if 0 /* We don't need this for GC purposes */
1712 struct backtrace
*next
;
1713 Lisp_Object
*function
;
1714 Lisp_Object
*args
; /* Points to vector of args. */
1715 int nargs
; /* length of vector */
1716 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1720 /* Garbage collection! */
1722 /* Temporarily prevent garbage collection. */
1725 inhibit_garbage_collection ()
1727 int count
= specpdl_ptr
- specpdl
;
1729 int nbits
= min (VALBITS
, BITS_PER_INT
);
1731 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1733 specbind (Qgc_cons_threshold
, number
);
1738 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1739 "Reclaim storage for Lisp objects no longer needed.\n\
1740 Returns info on amount of space in use:\n\
1741 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1742 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1743 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1744 Garbage collection happens automatically if you cons more than\n\
1745 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1748 register struct gcpro
*tail
;
1749 register struct specbinding
*bind
;
1750 struct catchtag
*catch;
1751 struct handler
*handler
;
1752 register struct backtrace
*backlist
;
1753 register Lisp_Object tem
;
1754 char stack_top_variable
;
1758 /* In case user calls debug_print during GC,
1759 don't let that cause a recursive GC. */
1760 consing_since_gc
= 0;
1762 /* Save what's currently displayed in the echo area. */
1763 message_p
= push_message ();
1765 /* Save a copy of the contents of the stack, for debugging. */
1766 #if MAX_SAVE_STACK > 0
1767 if (NILP (Vpurify_flag
))
1769 i
= &stack_top_variable
- stack_bottom
;
1771 if (i
< MAX_SAVE_STACK
)
1773 if (stack_copy
== 0)
1774 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1775 else if (stack_copy_size
< i
)
1776 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1779 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1780 bcopy (stack_bottom
, stack_copy
, i
);
1782 bcopy (&stack_top_variable
, stack_copy
, i
);
1786 #endif /* MAX_SAVE_STACK > 0 */
1788 if (garbage_collection_messages
)
1789 message1_nolog ("Garbage collecting...");
1793 shrink_regexp_cache ();
1795 /* Don't keep undo information around forever. */
1797 register struct buffer
*nextb
= all_buffers
;
1801 /* If a buffer's undo list is Qt, that means that undo is
1802 turned off in that buffer. Calling truncate_undo_list on
1803 Qt tends to return NULL, which effectively turns undo back on.
1804 So don't call truncate_undo_list if undo_list is Qt. */
1805 if (! EQ (nextb
->undo_list
, Qt
))
1807 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1809 nextb
= nextb
->next
;
1815 /* clear_marks (); */
1817 /* In each "large string", set the MARKBIT of the size field.
1818 That enables mark_object to recognize them. */
1820 register struct string_block
*b
;
1821 for (b
= large_string_blocks
; b
; b
= b
->next
)
1822 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1825 /* Mark all the special slots that serve as the roots of accessibility.
1827 Usually the special slots to mark are contained in particular structures.
1828 Then we know no slot is marked twice because the structures don't overlap.
1829 In some cases, the structures point to the slots to be marked.
1830 For these, we use MARKBIT to avoid double marking of the slot. */
1832 for (i
= 0; i
< staticidx
; i
++)
1833 mark_object (staticvec
[i
]);
1834 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1835 for (i
= 0; i
< tail
->nvars
; i
++)
1836 if (!XMARKBIT (tail
->var
[i
]))
1838 mark_object (&tail
->var
[i
]);
1839 XMARK (tail
->var
[i
]);
1841 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1843 mark_object (&bind
->symbol
);
1844 mark_object (&bind
->old_value
);
1846 for (catch = catchlist
; catch; catch = catch->next
)
1848 mark_object (&catch->tag
);
1849 mark_object (&catch->val
);
1851 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1853 mark_object (&handler
->handler
);
1854 mark_object (&handler
->var
);
1856 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1858 if (!XMARKBIT (*backlist
->function
))
1860 mark_object (backlist
->function
);
1861 XMARK (*backlist
->function
);
1863 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1866 i
= backlist
->nargs
- 1;
1868 if (!XMARKBIT (backlist
->args
[i
]))
1870 mark_object (&backlist
->args
[i
]);
1871 XMARK (backlist
->args
[i
]);
1876 /* Look thru every buffer's undo list
1877 for elements that update markers that were not marked,
1880 register struct buffer
*nextb
= all_buffers
;
1884 /* If a buffer's undo list is Qt, that means that undo is
1885 turned off in that buffer. Calling truncate_undo_list on
1886 Qt tends to return NULL, which effectively turns undo back on.
1887 So don't call truncate_undo_list if undo_list is Qt. */
1888 if (! EQ (nextb
->undo_list
, Qt
))
1890 Lisp_Object tail
, prev
;
1891 tail
= nextb
->undo_list
;
1893 while (CONSP (tail
))
1895 if (GC_CONSP (XCONS (tail
)->car
)
1896 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1897 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1900 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1902 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1907 tail
= XCONS (tail
)->cdr
;
1912 nextb
= nextb
->next
;
1918 /* Clear the mark bits that we set in certain root slots. */
1920 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1921 for (i
= 0; i
< tail
->nvars
; i
++)
1922 XUNMARK (tail
->var
[i
]);
1923 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1925 XUNMARK (*backlist
->function
);
1926 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1929 i
= backlist
->nargs
- 1;
1931 XUNMARK (backlist
->args
[i
]);
1933 XUNMARK (buffer_defaults
.name
);
1934 XUNMARK (buffer_local_symbols
.name
);
1938 /* clear_marks (); */
1941 consing_since_gc
= 0;
1942 if (gc_cons_threshold
< 10000)
1943 gc_cons_threshold
= 10000;
1945 if (garbage_collection_messages
)
1947 if (message_p
|| minibuf_level
> 0)
1950 message1_nolog ("Garbage collecting...done");
1955 return Fcons (Fcons (make_number (total_conses
),
1956 make_number (total_free_conses
)),
1957 Fcons (Fcons (make_number (total_symbols
),
1958 make_number (total_free_symbols
)),
1959 Fcons (Fcons (make_number (total_markers
),
1960 make_number (total_free_markers
)),
1961 Fcons (make_number (total_string_size
),
1962 Fcons (make_number (total_vector_size
),
1964 #ifdef LISP_FLOAT_TYPE
1965 (make_number (total_floats
),
1966 make_number (total_free_floats
)),
1967 #else /* not LISP_FLOAT_TYPE */
1968 (make_number (0), make_number (0)),
1969 #endif /* not LISP_FLOAT_TYPE */
1971 #ifdef USE_TEXT_PROPERTIES
1972 (make_number (total_intervals
),
1973 make_number (total_free_intervals
)),
1974 #else /* not USE_TEXT_PROPERTIES */
1975 (make_number (0), make_number (0)),
1976 #endif /* not USE_TEXT_PROPERTIES */
1984 /* Clear marks on all conses */
1986 register struct cons_block
*cblk
;
1987 register int lim
= cons_block_index
;
1989 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1992 for (i
= 0; i
< lim
; i
++)
1993 XUNMARK (cblk
->conses
[i
].car
);
1994 lim
= CONS_BLOCK_SIZE
;
1997 /* Clear marks on all symbols */
1999 register struct symbol_block
*sblk
;
2000 register int lim
= symbol_block_index
;
2002 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2005 for (i
= 0; i
< lim
; i
++)
2007 XUNMARK (sblk
->symbols
[i
].plist
);
2009 lim
= SYMBOL_BLOCK_SIZE
;
2012 /* Clear marks on all markers */
2014 register struct marker_block
*sblk
;
2015 register int lim
= marker_block_index
;
2017 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
2020 for (i
= 0; i
< lim
; i
++)
2021 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2022 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
2023 lim
= MARKER_BLOCK_SIZE
;
2026 /* Clear mark bits on all buffers */
2028 register struct buffer
*nextb
= all_buffers
;
2032 XUNMARK (nextb
->name
);
2033 nextb
= nextb
->next
;
2039 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
2040 only interesting objects referenced from glyphs are strings. */
2043 mark_glyph_matrix (matrix
)
2044 struct glyph_matrix
*matrix
;
2046 struct glyph_row
*row
= matrix
->rows
;
2047 struct glyph_row
*end
= row
+ matrix
->nrows
;
2054 for (area
= LEFT_MARGIN_AREA
; area
< LAST_AREA
; ++area
)
2056 struct glyph
*glyph
= row
->glyphs
[area
];
2057 struct glyph
*end_glyph
= glyph
+ row
->used
[area
];
2059 while (glyph
< end_glyph
)
2061 if (GC_STRINGP (glyph
->object
))
2062 mark_object (&glyph
->object
);
2072 /* Mark Lisp faces in the face cache C. */
2076 struct face_cache
*c
;
2081 for (i
= 0; i
< c
->used
; ++i
)
2083 struct face
*face
= FACE_FROM_ID (c
->f
, i
);
2087 for (j
= 0; j
< LFACE_VECTOR_SIZE
; ++j
)
2088 mark_object (&face
->lface
[j
]);
2089 mark_object (&face
->registry
);
2096 #ifdef HAVE_WINDOW_SYSTEM
2098 /* Mark Lisp objects in image IMG. */
2104 mark_object (&img
->spec
);
2106 if (!NILP (img
->data
.lisp_val
))
2107 mark_object (&img
->data
.lisp_val
);
2111 /* Mark Lisp objects in image cache of frame F. It's done this way so
2112 that we don't have to include xterm.h here. */
2115 mark_image_cache (f
)
2118 forall_images_in_image_cache (f
, mark_image
);
2121 #endif /* HAVE_X_WINDOWS */
2125 /* Mark reference to a Lisp_Object.
2126 If the object referred to has not been seen yet, recursively mark
2127 all the references contained in it.
2129 If the object referenced is a short string, the referencing slot
2130 is threaded into a chain of such slots, pointed to from
2131 the `size' field of the string. The actual string size
2132 lives in the last slot in the chain. We recognize the end
2133 because it is < (unsigned) STRING_BLOCK_SIZE. */
2135 #define LAST_MARKED_SIZE 500
2136 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
2137 int last_marked_index
;
2140 mark_object (argptr
)
2141 Lisp_Object
*argptr
;
2143 Lisp_Object
*objptr
= argptr
;
2144 register Lisp_Object obj
;
2151 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2152 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2155 last_marked
[last_marked_index
++] = objptr
;
2156 if (last_marked_index
== LAST_MARKED_SIZE
)
2157 last_marked_index
= 0;
2159 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2163 register struct Lisp_String
*ptr
= XSTRING (obj
);
2165 MARK_INTERVAL_TREE (ptr
->intervals
);
2166 if (ptr
->size
& MARKBIT
)
2167 /* A large string. Just set ARRAY_MARK_FLAG. */
2168 ptr
->size
|= ARRAY_MARK_FLAG
;
2171 /* A small string. Put this reference
2172 into the chain of references to it.
2173 If the address includes MARKBIT, put that bit elsewhere
2174 when we store OBJPTR into the size field. */
2176 if (XMARKBIT (*objptr
))
2178 XSETFASTINT (*objptr
, ptr
->size
);
2182 XSETFASTINT (*objptr
, ptr
->size
);
2184 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2186 ptr
->size
= (EMACS_INT
) objptr
;
2187 if (ptr
->size
& MARKBIT
)
2188 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2193 case Lisp_Vectorlike
:
2194 if (GC_BUFFERP (obj
))
2196 if (!XMARKBIT (XBUFFER (obj
)->name
))
2199 else if (GC_SUBRP (obj
))
2201 else if (GC_COMPILEDP (obj
))
2202 /* We could treat this just like a vector, but it is better
2203 to save the COMPILED_CONSTANTS element for last and avoid recursion
2206 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2207 register EMACS_INT size
= ptr
->size
;
2208 /* See comment above under Lisp_Vector. */
2209 struct Lisp_Vector
*volatile ptr1
= ptr
;
2212 if (size
& ARRAY_MARK_FLAG
)
2213 break; /* Already marked */
2214 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2215 size
&= PSEUDOVECTOR_SIZE_MASK
;
2216 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2218 if (i
!= COMPILED_CONSTANTS
)
2219 mark_object (&ptr1
->contents
[i
]);
2221 /* This cast should be unnecessary, but some Mips compiler complains
2222 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2223 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2226 else if (GC_FRAMEP (obj
))
2228 /* See comment above under Lisp_Vector for why this is volatile. */
2229 register struct frame
*volatile ptr
= XFRAME (obj
);
2230 register EMACS_INT size
= ptr
->size
;
2232 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2233 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2235 mark_object (&ptr
->name
);
2236 mark_object (&ptr
->icon_name
);
2237 mark_object (&ptr
->title
);
2238 mark_object (&ptr
->focus_frame
);
2239 mark_object (&ptr
->selected_window
);
2240 mark_object (&ptr
->minibuffer_window
);
2241 mark_object (&ptr
->param_alist
);
2242 mark_object (&ptr
->scroll_bars
);
2243 mark_object (&ptr
->condemned_scroll_bars
);
2244 mark_object (&ptr
->menu_bar_items
);
2245 mark_object (&ptr
->face_alist
);
2246 mark_object (&ptr
->menu_bar_vector
);
2247 mark_object (&ptr
->buffer_predicate
);
2248 mark_object (&ptr
->buffer_list
);
2249 mark_object (&ptr
->menu_bar_window
);
2250 mark_object (&ptr
->tool_bar_window
);
2251 mark_face_cache (ptr
->face_cache
);
2252 #ifdef HAVE_WINDOW_SYSTEM
2253 mark_image_cache (ptr
);
2254 mark_object (&ptr
->desired_tool_bar_items
);
2255 mark_object (&ptr
->current_tool_bar_items
);
2256 mark_object (&ptr
->desired_tool_bar_string
);
2257 mark_object (&ptr
->current_tool_bar_string
);
2258 #endif /* HAVE_WINDOW_SYSTEM */
2260 else if (GC_BOOL_VECTOR_P (obj
))
2262 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2264 if (ptr
->size
& ARRAY_MARK_FLAG
)
2265 break; /* Already marked */
2266 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2268 else if (GC_WINDOWP (obj
))
2270 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2271 struct window
*w
= XWINDOW (obj
);
2272 register EMACS_INT size
= ptr
->size
;
2273 /* The reason we use ptr1 is to avoid an apparent hardware bug
2274 that happens occasionally on the FSF's HP 300s.
2275 The bug is that a2 gets clobbered by recursive calls to mark_object.
2276 The clobberage seems to happen during function entry,
2277 perhaps in the moveml instruction.
2278 Yes, this is a crock, but we have to do it. */
2279 struct Lisp_Vector
*volatile ptr1
= ptr
;
2282 /* Stop if already marked. */
2283 if (size
& ARRAY_MARK_FLAG
)
2287 ptr
->size
|= ARRAY_MARK_FLAG
;
2289 /* There is no Lisp data above The member CURRENT_MATRIX in
2290 struct WINDOW. Stop marking when that slot is reached. */
2292 (char *) &ptr1
->contents
[i
] < (char *) &w
->current_matrix
;
2294 mark_object (&ptr1
->contents
[i
]);
2296 /* Mark glyphs for leaf windows. Marking window matrices is
2297 sufficient because frame matrices use the same glyph
2299 if (NILP (w
->hchild
)
2301 && w
->current_matrix
)
2303 mark_glyph_matrix (w
->current_matrix
);
2304 mark_glyph_matrix (w
->desired_matrix
);
2307 else if (GC_HASH_TABLE_P (obj
))
2309 struct Lisp_Hash_Table
*h
= XHASH_TABLE (obj
);
2310 EMACS_INT size
= h
->size
;
2312 /* Stop if already marked. */
2313 if (size
& ARRAY_MARK_FLAG
)
2317 h
->size
|= ARRAY_MARK_FLAG
;
2319 /* Mark contents. */
2320 mark_object (&h
->test
);
2321 mark_object (&h
->weak
);
2322 mark_object (&h
->rehash_size
);
2323 mark_object (&h
->rehash_threshold
);
2324 mark_object (&h
->hash
);
2325 mark_object (&h
->next
);
2326 mark_object (&h
->index
);
2327 mark_object (&h
->user_hash_function
);
2328 mark_object (&h
->user_cmp_function
);
2330 /* If hash table is not weak, mark all keys and values.
2331 For weak tables, mark only the vector. */
2332 if (GC_NILP (h
->weak
))
2333 mark_object (&h
->key_and_value
);
2335 XVECTOR (h
->key_and_value
)->size
|= ARRAY_MARK_FLAG
;
2340 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2341 register EMACS_INT size
= ptr
->size
;
2342 /* The reason we use ptr1 is to avoid an apparent hardware bug
2343 that happens occasionally on the FSF's HP 300s.
2344 The bug is that a2 gets clobbered by recursive calls to mark_object.
2345 The clobberage seems to happen during function entry,
2346 perhaps in the moveml instruction.
2347 Yes, this is a crock, but we have to do it. */
2348 struct Lisp_Vector
*volatile ptr1
= ptr
;
2351 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2352 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2353 if (size
& PSEUDOVECTOR_FLAG
)
2354 size
&= PSEUDOVECTOR_SIZE_MASK
;
2356 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2357 mark_object (&ptr1
->contents
[i
]);
2363 /* See comment above under Lisp_Vector for why this is volatile. */
2364 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2365 struct Lisp_Symbol
*ptrx
;
2367 if (XMARKBIT (ptr
->plist
)) break;
2369 mark_object ((Lisp_Object
*) &ptr
->value
);
2370 mark_object (&ptr
->function
);
2371 mark_object (&ptr
->plist
);
2372 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2373 mark_object ((Lisp_Object
*) &ptr
->name
);
2374 /* Note that we do not mark the obarray of the symbol.
2375 It is safe not to do so because nothing accesses that
2376 slot except to check whether it is nil. */
2380 /* For the benefit of the last_marked log. */
2381 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2382 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2383 XSETSYMBOL (obj
, ptrx
);
2384 /* We can't goto loop here because *objptr doesn't contain an
2385 actual Lisp_Object with valid datatype field. */
2392 switch (XMISCTYPE (obj
))
2394 case Lisp_Misc_Marker
:
2395 XMARK (XMARKER (obj
)->chain
);
2396 /* DO NOT mark thru the marker's chain.
2397 The buffer's markers chain does not preserve markers from gc;
2398 instead, markers are removed from the chain when freed by gc. */
2401 case Lisp_Misc_Buffer_Local_Value
:
2402 case Lisp_Misc_Some_Buffer_Local_Value
:
2404 register struct Lisp_Buffer_Local_Value
*ptr
2405 = XBUFFER_LOCAL_VALUE (obj
);
2406 if (XMARKBIT (ptr
->realvalue
)) break;
2407 XMARK (ptr
->realvalue
);
2408 /* If the cdr is nil, avoid recursion for the car. */
2409 if (EQ (ptr
->cdr
, Qnil
))
2411 objptr
= &ptr
->realvalue
;
2414 mark_object (&ptr
->realvalue
);
2415 mark_object (&ptr
->buffer
);
2416 mark_object (&ptr
->frame
);
2417 /* See comment above under Lisp_Vector for why not use ptr here. */
2418 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2422 case Lisp_Misc_Intfwd
:
2423 case Lisp_Misc_Boolfwd
:
2424 case Lisp_Misc_Objfwd
:
2425 case Lisp_Misc_Buffer_Objfwd
:
2426 case Lisp_Misc_Kboard_Objfwd
:
2427 /* Don't bother with Lisp_Buffer_Objfwd,
2428 since all markable slots in current buffer marked anyway. */
2429 /* Don't need to do Lisp_Objfwd, since the places they point
2430 are protected with staticpro. */
2433 case Lisp_Misc_Overlay
:
2435 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2436 if (!XMARKBIT (ptr
->plist
))
2439 mark_object (&ptr
->start
);
2440 mark_object (&ptr
->end
);
2441 objptr
= &ptr
->plist
;
2454 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2455 if (XMARKBIT (ptr
->car
)) break;
2457 /* If the cdr is nil, avoid recursion for the car. */
2458 if (EQ (ptr
->cdr
, Qnil
))
2463 mark_object (&ptr
->car
);
2464 /* See comment above under Lisp_Vector for why not use ptr here. */
2465 objptr
= &XCONS (obj
)->cdr
;
2469 #ifdef LISP_FLOAT_TYPE
2471 XMARK (XFLOAT (obj
)->type
);
2473 #endif /* LISP_FLOAT_TYPE */
2483 /* Mark the pointers in a buffer structure. */
2489 register struct buffer
*buffer
= XBUFFER (buf
);
2490 register Lisp_Object
*ptr
;
2491 Lisp_Object base_buffer
;
2493 /* This is the buffer's markbit */
2494 mark_object (&buffer
->name
);
2495 XMARK (buffer
->name
);
2497 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2499 if (CONSP (buffer
->undo_list
))
2502 tail
= buffer
->undo_list
;
2504 while (CONSP (tail
))
2506 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2508 if (XMARKBIT (ptr
->car
))
2511 if (GC_CONSP (ptr
->car
)
2512 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2513 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2515 XMARK (XCONS (ptr
->car
)->car
);
2516 mark_object (&XCONS (ptr
->car
)->cdr
);
2519 mark_object (&ptr
->car
);
2521 if (CONSP (ptr
->cdr
))
2527 mark_object (&XCONS (tail
)->cdr
);
2530 mark_object (&buffer
->undo_list
);
2533 mark_object (buffer
->syntax_table
);
2535 /* Mark the various string-pointers in the buffer object.
2536 Since the strings may be relocated, we must mark them
2537 in their actual slots. So gc_sweep must convert each slot
2538 back to an ordinary C pointer. */
2539 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2540 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2541 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2542 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2544 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2545 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2546 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2547 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2550 for (ptr
= &buffer
->name
+ 1;
2551 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2555 /* If this is an indirect buffer, mark its base buffer. */
2556 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2558 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2559 mark_buffer (base_buffer
);
2564 /* Mark the pointers in the kboard objects. */
2571 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2573 if (kb
->kbd_macro_buffer
)
2574 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2576 mark_object (&kb
->Voverriding_terminal_local_map
);
2577 mark_object (&kb
->Vlast_command
);
2578 mark_object (&kb
->Vreal_last_command
);
2579 mark_object (&kb
->Vprefix_arg
);
2580 mark_object (&kb
->Vlast_prefix_arg
);
2581 mark_object (&kb
->kbd_queue
);
2582 mark_object (&kb
->defining_kbd_macro
);
2583 mark_object (&kb
->Vlast_kbd_macro
);
2584 mark_object (&kb
->Vsystem_key_alist
);
2585 mark_object (&kb
->system_key_syms
);
2586 mark_object (&kb
->Vdefault_minibuffer_frame
);
2591 /* Value is non-zero if OBJ will survive the current GC because it's
2592 either marked or does not need to be marked to survive. */
2600 switch (XGCTYPE (obj
))
2607 survives_p
= XMARKBIT (XSYMBOL (obj
)->plist
);
2611 switch (XMISCTYPE (obj
))
2613 case Lisp_Misc_Marker
:
2614 survives_p
= XMARKBIT (obj
);
2617 case Lisp_Misc_Buffer_Local_Value
:
2618 case Lisp_Misc_Some_Buffer_Local_Value
:
2619 survives_p
= XMARKBIT (XBUFFER_LOCAL_VALUE (obj
)->realvalue
);
2622 case Lisp_Misc_Intfwd
:
2623 case Lisp_Misc_Boolfwd
:
2624 case Lisp_Misc_Objfwd
:
2625 case Lisp_Misc_Buffer_Objfwd
:
2626 case Lisp_Misc_Kboard_Objfwd
:
2630 case Lisp_Misc_Overlay
:
2631 survives_p
= XMARKBIT (XOVERLAY (obj
)->plist
);
2641 struct Lisp_String
*s
= XSTRING (obj
);
2643 if (s
->size
& MARKBIT
)
2644 survives_p
= s
->size
& ARRAY_MARK_FLAG
;
2646 survives_p
= (s
->size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
;
2650 case Lisp_Vectorlike
:
2651 if (GC_BUFFERP (obj
))
2652 survives_p
= XMARKBIT (XBUFFER (obj
)->name
);
2653 else if (GC_SUBRP (obj
))
2656 survives_p
= XVECTOR (obj
)->size
& ARRAY_MARK_FLAG
;
2660 survives_p
= XMARKBIT (XCAR (obj
));
2663 #ifdef LISP_FLOAT_TYPE
2665 survives_p
= XMARKBIT (XFLOAT (obj
)->type
);
2667 #endif /* LISP_FLOAT_TYPE */
2678 /* Sweep: find all structures not marked, and free them. */
2683 /* Remove or mark entries in weak hash tables.
2684 This must be done before any object is unmarked. */
2685 sweep_weak_hash_tables ();
2687 total_string_size
= 0;
2690 /* Put all unmarked conses on free list */
2692 register struct cons_block
*cblk
;
2693 struct cons_block
**cprev
= &cons_block
;
2694 register int lim
= cons_block_index
;
2695 register int num_free
= 0, num_used
= 0;
2699 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2703 for (i
= 0; i
< lim
; i
++)
2704 if (!XMARKBIT (cblk
->conses
[i
].car
))
2707 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2708 cons_free_list
= &cblk
->conses
[i
];
2713 XUNMARK (cblk
->conses
[i
].car
);
2715 lim
= CONS_BLOCK_SIZE
;
2716 /* If this block contains only free conses and we have already
2717 seen more than two blocks worth of free conses then deallocate
2719 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2721 *cprev
= cblk
->next
;
2722 /* Unhook from the free list. */
2723 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2729 num_free
+= this_free
;
2730 cprev
= &cblk
->next
;
2733 total_conses
= num_used
;
2734 total_free_conses
= num_free
;
2737 #ifdef LISP_FLOAT_TYPE
2738 /* Put all unmarked floats on free list */
2740 register struct float_block
*fblk
;
2741 struct float_block
**fprev
= &float_block
;
2742 register int lim
= float_block_index
;
2743 register int num_free
= 0, num_used
= 0;
2745 float_free_list
= 0;
2747 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2751 for (i
= 0; i
< lim
; i
++)
2752 if (!XMARKBIT (fblk
->floats
[i
].type
))
2755 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2756 float_free_list
= &fblk
->floats
[i
];
2761 XUNMARK (fblk
->floats
[i
].type
);
2763 lim
= FLOAT_BLOCK_SIZE
;
2764 /* If this block contains only free floats and we have already
2765 seen more than two blocks worth of free floats then deallocate
2767 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2769 *fprev
= fblk
->next
;
2770 /* Unhook from the free list. */
2771 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2777 num_free
+= this_free
;
2778 fprev
= &fblk
->next
;
2781 total_floats
= num_used
;
2782 total_free_floats
= num_free
;
2784 #endif /* LISP_FLOAT_TYPE */
2786 #ifdef USE_TEXT_PROPERTIES
2787 /* Put all unmarked intervals on free list */
2789 register struct interval_block
*iblk
;
2790 struct interval_block
**iprev
= &interval_block
;
2791 register int lim
= interval_block_index
;
2792 register int num_free
= 0, num_used
= 0;
2794 interval_free_list
= 0;
2796 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2801 for (i
= 0; i
< lim
; i
++)
2803 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2805 iblk
->intervals
[i
].parent
= interval_free_list
;
2806 interval_free_list
= &iblk
->intervals
[i
];
2812 XUNMARK (iblk
->intervals
[i
].plist
);
2815 lim
= INTERVAL_BLOCK_SIZE
;
2816 /* If this block contains only free intervals and we have already
2817 seen more than two blocks worth of free intervals then
2818 deallocate this block. */
2819 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2821 *iprev
= iblk
->next
;
2822 /* Unhook from the free list. */
2823 interval_free_list
= iblk
->intervals
[0].parent
;
2825 n_interval_blocks
--;
2829 num_free
+= this_free
;
2830 iprev
= &iblk
->next
;
2833 total_intervals
= num_used
;
2834 total_free_intervals
= num_free
;
2836 #endif /* USE_TEXT_PROPERTIES */
2838 /* Put all unmarked symbols on free list */
2840 register struct symbol_block
*sblk
;
2841 struct symbol_block
**sprev
= &symbol_block
;
2842 register int lim
= symbol_block_index
;
2843 register int num_free
= 0, num_used
= 0;
2845 symbol_free_list
= 0;
2847 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2851 for (i
= 0; i
< lim
; i
++)
2852 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2854 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2855 symbol_free_list
= &sblk
->symbols
[i
];
2861 sblk
->symbols
[i
].name
2862 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2863 XUNMARK (sblk
->symbols
[i
].plist
);
2865 lim
= SYMBOL_BLOCK_SIZE
;
2866 /* If this block contains only free symbols and we have already
2867 seen more than two blocks worth of free symbols then deallocate
2869 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2871 *sprev
= sblk
->next
;
2872 /* Unhook from the free list. */
2873 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2879 num_free
+= this_free
;
2880 sprev
= &sblk
->next
;
2883 total_symbols
= num_used
;
2884 total_free_symbols
= num_free
;
2888 /* Put all unmarked misc's on free list.
2889 For a marker, first unchain it from the buffer it points into. */
2891 register struct marker_block
*mblk
;
2892 struct marker_block
**mprev
= &marker_block
;
2893 register int lim
= marker_block_index
;
2894 register int num_free
= 0, num_used
= 0;
2896 marker_free_list
= 0;
2898 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2902 EMACS_INT already_free
= -1;
2904 for (i
= 0; i
< lim
; i
++)
2906 Lisp_Object
*markword
;
2907 switch (mblk
->markers
[i
].u_marker
.type
)
2909 case Lisp_Misc_Marker
:
2910 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2912 case Lisp_Misc_Buffer_Local_Value
:
2913 case Lisp_Misc_Some_Buffer_Local_Value
:
2914 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2916 case Lisp_Misc_Overlay
:
2917 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2919 case Lisp_Misc_Free
:
2920 /* If the object was already free, keep it
2921 on the free list. */
2922 markword
= (Lisp_Object
*) &already_free
;
2928 if (markword
&& !XMARKBIT (*markword
))
2931 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2933 /* tem1 avoids Sun compiler bug */
2934 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2935 XSETMARKER (tem
, tem1
);
2936 unchain_marker (tem
);
2938 /* Set the type of the freed object to Lisp_Misc_Free.
2939 We could leave the type alone, since nobody checks it,
2940 but this might catch bugs faster. */
2941 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2942 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2943 marker_free_list
= &mblk
->markers
[i
];
2950 XUNMARK (*markword
);
2953 lim
= MARKER_BLOCK_SIZE
;
2954 /* If this block contains only free markers and we have already
2955 seen more than two blocks worth of free markers then deallocate
2957 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2959 *mprev
= mblk
->next
;
2960 /* Unhook from the free list. */
2961 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2967 num_free
+= this_free
;
2968 mprev
= &mblk
->next
;
2972 total_markers
= num_used
;
2973 total_free_markers
= num_free
;
2976 /* Free all unmarked buffers */
2978 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2981 if (!XMARKBIT (buffer
->name
))
2984 prev
->next
= buffer
->next
;
2986 all_buffers
= buffer
->next
;
2987 next
= buffer
->next
;
2993 XUNMARK (buffer
->name
);
2994 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2997 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2998 for purposes of marking and relocation.
2999 Turn them back into C pointers now. */
3000 buffer
->upcase_table
3001 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
3002 buffer
->downcase_table
3003 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
3005 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
3006 buffer
->folding_sort_table
3007 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
3010 prev
= buffer
, buffer
= buffer
->next
;
3014 #endif /* standalone */
3016 /* Free all unmarked vectors */
3018 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
3019 total_vector_size
= 0;
3022 if (!(vector
->size
& ARRAY_MARK_FLAG
))
3025 if ((vector
->size
& (PSEUDOVECTOR_FLAG
| PVEC_HASH_TABLE
))
3026 == (PSEUDOVECTOR_FLAG
| PVEC_HASH_TABLE
))
3027 fprintf (stderr
, "Freeing hash table %p\n", vector
);
3030 prev
->next
= vector
->next
;
3032 all_vectors
= vector
->next
;
3033 next
= vector
->next
;
3041 vector
->size
&= ~ARRAY_MARK_FLAG
;
3042 if (vector
->size
& PSEUDOVECTOR_FLAG
)
3043 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
3045 total_vector_size
+= vector
->size
;
3046 prev
= vector
, vector
= vector
->next
;
3050 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
3052 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
3053 struct Lisp_String
*s
;
3057 s
= (struct Lisp_String
*) &sb
->chars
[0];
3058 if (s
->size
& ARRAY_MARK_FLAG
)
3060 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
3061 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
3062 UNMARK_BALANCE_INTERVALS (s
->intervals
);
3063 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
3064 prev
= sb
, sb
= sb
->next
;
3069 prev
->next
= sb
->next
;
3071 large_string_blocks
= sb
->next
;
3081 /* Compactify strings, relocate references, and free empty string blocks. */
3086 /* String block of old strings we are scanning. */
3087 register struct string_block
*from_sb
;
3088 /* A preceding string block (or maybe the same one)
3089 where we are copying the still-live strings to. */
3090 register struct string_block
*to_sb
;
3094 to_sb
= first_string_block
;
3097 /* Scan each existing string block sequentially, string by string. */
3098 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
3101 /* POS is the index of the next string in the block. */
3102 while (pos
< from_sb
->pos
)
3104 register struct Lisp_String
*nextstr
3105 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
3107 register struct Lisp_String
*newaddr
;
3108 register EMACS_INT size
= nextstr
->size
;
3109 EMACS_INT size_byte
= nextstr
->size_byte
;
3111 /* NEXTSTR is the old address of the next string.
3112 Just skip it if it isn't marked. */
3113 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
3115 /* It is marked, so its size field is really a chain of refs.
3116 Find the end of the chain, where the actual size lives. */
3117 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
3119 if (size
& DONT_COPY_FLAG
)
3120 size
^= MARKBIT
| DONT_COPY_FLAG
;
3121 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
3127 total_string_size
+= size_byte
;
3129 /* If it won't fit in TO_SB, close it out,
3130 and move to the next sb. Keep doing so until
3131 TO_SB reaches a large enough, empty enough string block.
3132 We know that TO_SB cannot advance past FROM_SB here
3133 since FROM_SB is large enough to contain this string.
3134 Any string blocks skipped here
3135 will be patched out and freed later. */
3136 while (to_pos
+ STRING_FULLSIZE (size_byte
)
3137 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
3139 to_sb
->pos
= to_pos
;
3140 to_sb
= to_sb
->next
;
3143 /* Compute new address of this string
3144 and update TO_POS for the space being used. */
3145 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
3146 to_pos
+= STRING_FULLSIZE (size_byte
);
3148 /* Copy the string itself to the new place. */
3149 if (nextstr
!= newaddr
)
3150 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
3152 /* Go through NEXTSTR's chain of references
3153 and make each slot in the chain point to
3154 the new address of this string. */
3155 size
= newaddr
->size
;
3156 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
3158 register Lisp_Object
*objptr
;
3159 if (size
& DONT_COPY_FLAG
)
3160 size
^= MARKBIT
| DONT_COPY_FLAG
;
3161 objptr
= (Lisp_Object
*)size
;
3163 size
= XFASTINT (*objptr
) & ~MARKBIT
;
3164 if (XMARKBIT (*objptr
))
3166 XSETSTRING (*objptr
, newaddr
);
3170 XSETSTRING (*objptr
, newaddr
);
3172 /* Store the actual size in the size field. */
3173 newaddr
->size
= size
;
3175 #ifdef USE_TEXT_PROPERTIES
3176 /* Now that the string has been relocated, rebalance its
3177 interval tree, and update the tree's parent pointer. */
3178 if (! NULL_INTERVAL_P (newaddr
->intervals
))
3180 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
3181 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
3184 #endif /* USE_TEXT_PROPERTIES */
3186 else if (size_byte
< 0)
3189 pos
+= STRING_FULLSIZE (size_byte
);
3193 /* Close out the last string block still used and free any that follow. */
3194 to_sb
->pos
= to_pos
;
3195 current_string_block
= to_sb
;
3197 from_sb
= to_sb
->next
;
3201 to_sb
= from_sb
->next
;
3202 lisp_free (from_sb
);
3207 /* Free any empty string blocks further back in the chain.
3208 This loop will never free first_string_block, but it is very
3209 unlikely that that one will become empty, so why bother checking? */
3211 from_sb
= first_string_block
;
3212 while (to_sb
= from_sb
->next
)
3214 if (to_sb
->pos
== 0)
3216 if (from_sb
->next
= to_sb
->next
)
3217 from_sb
->next
->prev
= from_sb
;
3226 /* Debugging aids. */
3228 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
3229 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
3230 This may be helpful in debugging Emacs's memory usage.\n\
3231 We divide the value by 1024 to make sure it fits in a Lisp integer.")
3236 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
3241 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
3242 "Return a list of counters that measure how much consing there has been.\n\
3243 Each of these counters increments for a certain kind of object.\n\
3244 The counters wrap around from the largest positive integer to zero.\n\
3245 Garbage collection does not decrease them.\n\
3246 The elements of the value are as follows:\n\
3247 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
3248 All are in units of 1 = one object consed\n\
3249 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
3251 MISCS include overlays, markers, and some internal types.\n\
3252 Frames, windows, buffers, and subprocesses count as vectors\n\
3253 (but the contents of a buffer's text do not count here).")
3256 Lisp_Object lisp_cons_cells_consed
;
3257 Lisp_Object lisp_floats_consed
;
3258 Lisp_Object lisp_vector_cells_consed
;
3259 Lisp_Object lisp_symbols_consed
;
3260 Lisp_Object lisp_string_chars_consed
;
3261 Lisp_Object lisp_misc_objects_consed
;
3262 Lisp_Object lisp_intervals_consed
;
3264 XSETINT (lisp_cons_cells_consed
,
3265 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3266 XSETINT (lisp_floats_consed
,
3267 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3268 XSETINT (lisp_vector_cells_consed
,
3269 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3270 XSETINT (lisp_symbols_consed
,
3271 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3272 XSETINT (lisp_string_chars_consed
,
3273 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3274 XSETINT (lisp_misc_objects_consed
,
3275 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3276 XSETINT (lisp_intervals_consed
,
3277 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
3279 return Fcons (lisp_cons_cells_consed
,
3280 Fcons (lisp_floats_consed
,
3281 Fcons (lisp_vector_cells_consed
,
3282 Fcons (lisp_symbols_consed
,
3283 Fcons (lisp_string_chars_consed
,
3284 Fcons (lisp_misc_objects_consed
,
3285 Fcons (lisp_intervals_consed
,
3289 /* Initialization */
3294 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
3297 pure_size
= PURESIZE
;
3300 ignore_warnings
= 1;
3301 #ifdef DOUG_LEA_MALLOC
3302 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
3303 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
3304 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
3310 #ifdef LISP_FLOAT_TYPE
3312 #endif /* LISP_FLOAT_TYPE */
3316 malloc_hysteresis
= 32;
3318 malloc_hysteresis
= 0;
3321 spare_memory
= (char *) malloc (SPARE_MEMORY
);
3323 ignore_warnings
= 0;
3326 consing_since_gc
= 0;
3327 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
3328 #ifdef VIRT_ADDR_VARIES
3329 malloc_sbrk_unused
= 1<<22; /* A large number */
3330 malloc_sbrk_used
= 100000; /* as reasonable as any number */
3331 #endif /* VIRT_ADDR_VARIES */
3343 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
3344 "*Number of bytes of consing between garbage collections.\n\
3345 Garbage collection can happen automatically once this many bytes have been\n\
3346 allocated since the last garbage collection. All data types count.\n\n\
3347 Garbage collection happens automatically only when `eval' is called.\n\n\
3348 By binding this temporarily to a large number, you can effectively\n\
3349 prevent garbage collection during a part of the program.");
3351 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3352 "Number of bytes of sharable Lisp data allocated so far.");
3354 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3355 "Number of cons cells that have been consed so far.");
3357 DEFVAR_INT ("floats-consed", &floats_consed
,
3358 "Number of floats that have been consed so far.");
3360 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3361 "Number of vector cells that have been consed so far.");
3363 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3364 "Number of symbols that have been consed so far.");
3366 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3367 "Number of string characters that have been consed so far.");
3369 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3370 "Number of miscellaneous objects that have been consed so far.");
3372 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3373 "Number of intervals that have been consed so far.");
3376 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3377 "Number of bytes of unshared memory allocated in this session.");
3379 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3380 "Number of bytes of unshared memory remaining available in this session.");
3383 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3384 "Non-nil means loading Lisp code in order to dump an executable.\n\
3385 This means that certain objects should be allocated in shared (pure) space.");
3387 DEFVAR_INT ("undo-limit", &undo_limit
,
3388 "Keep no more undo information once it exceeds this size.\n\
3389 This limit is applied when garbage collection happens.\n\
3390 The size is counted as the number of bytes occupied,\n\
3391 which includes both saved text and other data.");
3394 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3395 "Don't keep more than this much size of undo information.\n\
3396 A command which pushes past this size is itself forgotten.\n\
3397 This limit is applied when garbage collection happens.\n\
3398 The size is counted as the number of bytes occupied,\n\
3399 which includes both saved text and other data.");
3400 undo_strong_limit
= 30000;
3402 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3403 "Non-nil means display messages at start and end of garbage collection.");
3404 garbage_collection_messages
= 0;
3406 /* We build this in advance because if we wait until we need it, we might
3407 not be able to allocate the memory to hold it. */
3409 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3410 staticpro (&memory_signal_data
);
3412 staticpro (&Qgc_cons_threshold
);
3413 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3415 staticpro (&Qchar_table_extra_slots
);
3416 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3421 defsubr (&Smake_byte_code
);
3422 defsubr (&Smake_list
);
3423 defsubr (&Smake_vector
);
3424 defsubr (&Smake_char_table
);
3425 defsubr (&Smake_string
);
3426 defsubr (&Smake_bool_vector
);
3427 defsubr (&Smake_symbol
);
3428 defsubr (&Smake_marker
);
3429 defsubr (&Spurecopy
);
3430 defsubr (&Sgarbage_collect
);
3431 defsubr (&Smemory_limit
);
3432 defsubr (&Smemory_use_counts
);