1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "intervals.h"
30 #include "blockinput.h"
34 #include "syssignal.h"
38 /* The following come from gmalloc.c. */
40 #if defined (__STDC__) && __STDC__
42 #define __malloc_size_t size_t
44 #define __malloc_size_t unsigned int
46 extern __malloc_size_t _bytes_used
;
47 extern int __malloc_extra_blocks
;
49 #define max(A,B) ((A) > (B) ? (A) : (B))
50 #define min(A,B) ((A) < (B) ? (A) : (B))
52 /* Macro to verify that storage intended for Lisp objects is not
53 out of range to fit in the space for a pointer.
54 ADDRESS is the start of the block, and SIZE
55 is the amount of space within which objects can start. */
56 #define VALIDATE_LISP_STORAGE(address, size) \
60 XSETCONS (val, (char *) address + size); \
61 if ((char *) XCONS (val) != (char *) address + size) \
68 /* Value of _bytes_used, when spare_memory was freed. */
69 static __malloc_size_t bytes_used_when_full
;
71 /* Number of bytes of consing done since the last gc */
74 /* Count the amount of consing of various sorts of space. */
75 int cons_cells_consed
;
77 int vector_cells_consed
;
79 int string_chars_consed
;
80 int misc_objects_consed
;
83 /* Number of bytes of consing since gc before another gc should be done. */
84 int gc_cons_threshold
;
86 /* Nonzero during gc */
89 #ifndef VIRT_ADDR_VARIES
91 #endif /* VIRT_ADDR_VARIES */
94 #ifndef VIRT_ADDR_VARIES
96 #endif /* VIRT_ADDR_VARIES */
97 int malloc_sbrk_unused
;
99 /* Two limits controlling how much undo information to keep. */
101 int undo_strong_limit
;
103 /* Points to memory space allocated as "spare",
104 to be freed if we run out of memory. */
105 static char *spare_memory
;
107 /* Amount of spare memory to keep in reserve. */
108 #define SPARE_MEMORY (1 << 14)
110 /* Number of extra blocks malloc should get when it needs more core. */
111 static int malloc_hysteresis
;
113 /* Nonzero when malloc is called for allocating Lisp object space. */
114 int allocating_for_lisp
;
116 /* Non-nil means defun should do purecopy on the function definition */
117 Lisp_Object Vpurify_flag
;
120 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
121 #define PUREBEG (char *) pure
123 #define pure PURE_SEG_BITS /* Use shared memory segment */
124 #define PUREBEG (char *)PURE_SEG_BITS
126 /* This variable is used only by the XPNTR macro when HAVE_SHM is
127 defined. If we used the PURESIZE macro directly there, that would
128 make most of emacs dependent on puresize.h, which we don't want -
129 you should be able to change that without too much recompilation.
130 So map_in_data initializes pure_size, and the dependencies work
133 #endif /* not HAVE_SHM */
135 /* Index in pure at which next pure object will be allocated. */
138 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
139 char *pending_malloc_warning
;
141 /* Pre-computed signal argument for use when memory is exhausted. */
142 Lisp_Object memory_signal_data
;
144 /* Maximum amount of C stack to save when a GC happens. */
146 #ifndef MAX_SAVE_STACK
147 #define MAX_SAVE_STACK 16000
150 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
151 pointer to a Lisp_Object, when that pointer is viewed as an integer.
152 (On most machines, pointers are even, so we can use the low bit.
153 Word-addressible architectures may need to override this in the m-file.)
154 When linking references to small strings through the size field, we
155 use this slot to hold the bit that would otherwise be interpreted as
157 #ifndef DONT_COPY_FLAG
158 #define DONT_COPY_FLAG 1
159 #endif /* no DONT_COPY_FLAG */
161 /* Buffer in which we save a copy of the C stack at each GC. */
166 /* Non-zero means ignore malloc warnings. Set during initialization. */
169 Lisp_Object Qgc_cons_threshold
;
171 static void mark_object (), mark_buffer (), mark_kboards ();
172 static void clear_marks (), gc_sweep ();
173 static void compact_strings ();
175 /* Versions of malloc and realloc that print warnings as memory gets full. */
178 malloc_warning_1 (str
)
181 Fprinc (str
, Vstandard_output
);
182 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
183 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
184 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
188 /* malloc calls this if it finds we are near exhausting storage */
192 pending_malloc_warning
= str
;
195 display_malloc_warning ()
197 register Lisp_Object val
;
199 val
= build_string (pending_malloc_warning
);
200 pending_malloc_warning
= 0;
201 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
204 /* Called if malloc returns zero */
208 #ifndef SYSTEM_MALLOC
209 bytes_used_when_full
= _bytes_used
;
212 /* The first time we get here, free the spare memory. */
219 /* This used to call error, but if we've run out of memory, we could get
220 infinite recursion trying to build the string. */
222 Fsignal (Qerror
, memory_signal_data
);
225 /* Called if we can't allocate relocatable space for a buffer. */
228 buffer_memory_full ()
230 /* If buffers use the relocating allocator,
231 no need to free spare_memory, because we may have plenty of malloc
232 space left that we could get, and if we don't, the malloc that fails
233 will itself cause spare_memory to be freed.
234 If buffers don't use the relocating allocator,
235 treat this like any other failing malloc. */
241 /* This used to call error, but if we've run out of memory, we could get
242 infinite recursion trying to build the string. */
244 Fsignal (Qerror
, memory_signal_data
);
247 /* like malloc routines but check for no memory and block interrupt input. */
256 val
= (long *) malloc (size
);
259 if (!val
&& size
) memory_full ();
264 xrealloc (block
, size
)
271 /* We must call malloc explicitly when BLOCK is 0, since some
272 reallocs don't do this. */
274 val
= (long *) malloc (size
);
276 val
= (long *) realloc (block
, size
);
279 if (!val
&& size
) memory_full ();
293 /* Arranging to disable input signals while we're in malloc.
295 This only works with GNU malloc. To help out systems which can't
296 use GNU malloc, all the calls to malloc, realloc, and free
297 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
298 pairs; unfortunately, we have no idea what C library functions
299 might call malloc, so we can't really protect them unless you're
300 using GNU malloc. Fortunately, most of the major operating can use
303 #ifndef SYSTEM_MALLOC
304 extern void * (*__malloc_hook
) ();
305 static void * (*old_malloc_hook
) ();
306 extern void * (*__realloc_hook
) ();
307 static void * (*old_realloc_hook
) ();
308 extern void (*__free_hook
) ();
309 static void (*old_free_hook
) ();
311 /* This function is used as the hook for free to call. */
314 emacs_blocked_free (ptr
)
318 __free_hook
= old_free_hook
;
320 /* If we released our reserve (due to running out of memory),
321 and we have a fair amount free once again,
322 try to set aside another reserve in case we run out once more. */
323 if (spare_memory
== 0
324 /* Verify there is enough space that even with the malloc
325 hysteresis this call won't run out again.
326 The code here is correct as long as SPARE_MEMORY
327 is substantially larger than the block size malloc uses. */
328 && (bytes_used_when_full
329 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
330 spare_memory
= (char *) malloc (SPARE_MEMORY
);
332 __free_hook
= emacs_blocked_free
;
336 /* If we released our reserve (due to running out of memory),
337 and we have a fair amount free once again,
338 try to set aside another reserve in case we run out once more.
340 This is called when a relocatable block is freed in ralloc.c. */
343 refill_memory_reserve ()
345 if (spare_memory
== 0)
346 spare_memory
= (char *) malloc (SPARE_MEMORY
);
349 /* This function is the malloc hook that Emacs uses. */
352 emacs_blocked_malloc (size
)
358 __malloc_hook
= old_malloc_hook
;
359 __malloc_extra_blocks
= malloc_hysteresis
;
360 value
= (void *) malloc (size
);
361 __malloc_hook
= emacs_blocked_malloc
;
368 emacs_blocked_realloc (ptr
, size
)
375 __realloc_hook
= old_realloc_hook
;
376 value
= (void *) realloc (ptr
, size
);
377 __realloc_hook
= emacs_blocked_realloc
;
384 uninterrupt_malloc ()
386 old_free_hook
= __free_hook
;
387 __free_hook
= emacs_blocked_free
;
389 old_malloc_hook
= __malloc_hook
;
390 __malloc_hook
= emacs_blocked_malloc
;
392 old_realloc_hook
= __realloc_hook
;
393 __realloc_hook
= emacs_blocked_realloc
;
397 /* Interval allocation. */
399 #ifdef USE_TEXT_PROPERTIES
400 #define INTERVAL_BLOCK_SIZE \
401 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
403 struct interval_block
405 struct interval_block
*next
;
406 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
409 struct interval_block
*interval_block
;
410 static int interval_block_index
;
412 INTERVAL interval_free_list
;
417 allocating_for_lisp
= 1;
419 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
420 allocating_for_lisp
= 0;
421 interval_block
->next
= 0;
422 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
423 interval_block_index
= 0;
424 interval_free_list
= 0;
427 #define INIT_INTERVALS init_intervals ()
434 if (interval_free_list
)
436 val
= interval_free_list
;
437 interval_free_list
= interval_free_list
->parent
;
441 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
443 register struct interval_block
*newi
;
445 allocating_for_lisp
= 1;
446 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
448 allocating_for_lisp
= 0;
449 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
450 newi
->next
= interval_block
;
451 interval_block
= newi
;
452 interval_block_index
= 0;
454 val
= &interval_block
->intervals
[interval_block_index
++];
456 consing_since_gc
+= sizeof (struct interval
);
458 RESET_INTERVAL (val
);
462 static int total_free_intervals
, total_intervals
;
464 /* Mark the pointers of one interval. */
467 mark_interval (i
, dummy
)
471 if (XMARKBIT (i
->plist
))
473 mark_object (&i
->plist
);
478 mark_interval_tree (tree
)
479 register INTERVAL tree
;
481 /* No need to test if this tree has been marked already; this
482 function is always called through the MARK_INTERVAL_TREE macro,
483 which takes care of that. */
485 /* XMARK expands to an assignment; the LHS of an assignment can't be
487 XMARK (* (Lisp_Object
*) &tree
->parent
);
489 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
492 #define MARK_INTERVAL_TREE(i) \
494 if (!NULL_INTERVAL_P (i) \
495 && ! XMARKBIT ((Lisp_Object) i->parent)) \
496 mark_interval_tree (i); \
499 /* The oddity in the call to XUNMARK is necessary because XUNMARK
500 expands to an assignment to its argument, and most C compilers don't
501 support casts on the left operand of `='. */
502 #define UNMARK_BALANCE_INTERVALS(i) \
504 if (! NULL_INTERVAL_P (i)) \
506 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
507 (i) = balance_intervals (i); \
511 #else /* no interval use */
513 #define INIT_INTERVALS
515 #define UNMARK_BALANCE_INTERVALS(i)
516 #define MARK_INTERVAL_TREE(i)
518 #endif /* no interval use */
520 /* Floating point allocation. */
522 #ifdef LISP_FLOAT_TYPE
523 /* Allocation of float cells, just like conses */
524 /* We store float cells inside of float_blocks, allocating a new
525 float_block with malloc whenever necessary. Float cells reclaimed by
526 GC are put on a free list to be reallocated before allocating
527 any new float cells from the latest float_block.
529 Each float_block is just under 1020 bytes long,
530 since malloc really allocates in units of powers of two
531 and uses 4 bytes for its own overhead. */
533 #define FLOAT_BLOCK_SIZE \
534 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
538 struct float_block
*next
;
539 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
542 struct float_block
*float_block
;
543 int float_block_index
;
545 struct Lisp_Float
*float_free_list
;
550 allocating_for_lisp
= 1;
551 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
552 allocating_for_lisp
= 0;
553 float_block
->next
= 0;
554 bzero (float_block
->floats
, sizeof float_block
->floats
);
555 float_block_index
= 0;
559 /* Explicitly free a float cell. */
561 struct Lisp_Float
*ptr
;
563 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
564 float_free_list
= ptr
;
568 make_float (float_value
)
571 register Lisp_Object val
;
575 XSETFLOAT (val
, float_free_list
);
576 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
580 if (float_block_index
== FLOAT_BLOCK_SIZE
)
582 register struct float_block
*new;
584 allocating_for_lisp
= 1;
585 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
586 allocating_for_lisp
= 0;
587 VALIDATE_LISP_STORAGE (new, sizeof *new);
588 new->next
= float_block
;
590 float_block_index
= 0;
592 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
594 XFLOAT (val
)->data
= float_value
;
595 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
596 consing_since_gc
+= sizeof (struct Lisp_Float
);
601 #endif /* LISP_FLOAT_TYPE */
603 /* Allocation of cons cells */
604 /* We store cons cells inside of cons_blocks, allocating a new
605 cons_block with malloc whenever necessary. Cons cells reclaimed by
606 GC are put on a free list to be reallocated before allocating
607 any new cons cells from the latest cons_block.
609 Each cons_block is just under 1020 bytes long,
610 since malloc really allocates in units of powers of two
611 and uses 4 bytes for its own overhead. */
613 #define CONS_BLOCK_SIZE \
614 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
618 struct cons_block
*next
;
619 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
622 struct cons_block
*cons_block
;
623 int cons_block_index
;
625 struct Lisp_Cons
*cons_free_list
;
630 allocating_for_lisp
= 1;
631 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
632 allocating_for_lisp
= 0;
633 cons_block
->next
= 0;
634 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
635 cons_block_index
= 0;
639 /* Explicitly free a cons cell. */
641 struct Lisp_Cons
*ptr
;
643 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
644 cons_free_list
= ptr
;
647 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
648 "Create a new cons, give it CAR and CDR as components, and return it.")
650 Lisp_Object car
, cdr
;
652 register Lisp_Object val
;
656 XSETCONS (val
, cons_free_list
);
657 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
661 if (cons_block_index
== CONS_BLOCK_SIZE
)
663 register struct cons_block
*new;
664 allocating_for_lisp
= 1;
665 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
666 allocating_for_lisp
= 0;
667 VALIDATE_LISP_STORAGE (new, sizeof *new);
668 new->next
= cons_block
;
670 cons_block_index
= 0;
672 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
674 XCONS (val
)->car
= car
;
675 XCONS (val
)->cdr
= cdr
;
676 consing_since_gc
+= sizeof (struct Lisp_Cons
);
681 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
682 "Return a newly created list with specified arguments as elements.\n\
683 Any number of arguments, even zero arguments, are allowed.")
686 register Lisp_Object
*args
;
688 register Lisp_Object val
= Qnil
;
691 val
= Fcons (args
[nargs
], val
);
695 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
696 "Return a newly created list of length LENGTH, with each element being INIT.")
698 register Lisp_Object length
, init
;
700 register Lisp_Object val
;
703 CHECK_NATNUM (length
, 0);
704 size
= XFASTINT (length
);
708 val
= Fcons (init
, val
);
712 /* Allocation of vectors */
714 struct Lisp_Vector
*all_vectors
;
717 allocate_vectorlike (len
)
720 struct Lisp_Vector
*p
;
722 allocating_for_lisp
= 1;
723 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
724 + (len
- 1) * sizeof (Lisp_Object
));
725 allocating_for_lisp
= 0;
726 VALIDATE_LISP_STORAGE (p
, 0);
727 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
728 + (len
- 1) * sizeof (Lisp_Object
));
729 vector_cells_consed
+= len
;
731 p
->next
= all_vectors
;
736 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
737 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
738 See also the function `vector'.")
740 register Lisp_Object length
, init
;
743 register EMACS_INT sizei
;
745 register struct Lisp_Vector
*p
;
747 CHECK_NATNUM (length
, 0);
748 sizei
= XFASTINT (length
);
750 p
= allocate_vectorlike (sizei
);
752 for (index
= 0; index
< sizei
; index
++)
753 p
->contents
[index
] = init
;
755 XSETVECTOR (vector
, p
);
759 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
760 "Return a newly created vector with specified arguments as elements.\n\
761 Any number of arguments, even zero arguments, are allowed.")
766 register Lisp_Object len
, val
;
768 register struct Lisp_Vector
*p
;
770 XSETFASTINT (len
, nargs
);
771 val
= Fmake_vector (len
, Qnil
);
773 for (index
= 0; index
< nargs
; index
++)
774 p
->contents
[index
] = args
[index
];
778 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
779 "Create a byte-code object with specified arguments as elements.\n\
780 The arguments should be the arglist, bytecode-string, constant vector,\n\
781 stack size, (optional) doc string, and (optional) interactive spec.\n\
782 The first four arguments are required; at most six have any\n\
788 register Lisp_Object len
, val
;
790 register struct Lisp_Vector
*p
;
792 XSETFASTINT (len
, nargs
);
793 if (!NILP (Vpurify_flag
))
794 val
= make_pure_vector (len
);
796 val
= Fmake_vector (len
, Qnil
);
798 for (index
= 0; index
< nargs
; index
++)
800 if (!NILP (Vpurify_flag
))
801 args
[index
] = Fpurecopy (args
[index
]);
802 p
->contents
[index
] = args
[index
];
804 XSETCOMPILED (val
, val
);
808 /* Allocation of symbols.
809 Just like allocation of conses!
811 Each symbol_block is just under 1020 bytes long,
812 since malloc really allocates in units of powers of two
813 and uses 4 bytes for its own overhead. */
815 #define SYMBOL_BLOCK_SIZE \
816 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
820 struct symbol_block
*next
;
821 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
824 struct symbol_block
*symbol_block
;
825 int symbol_block_index
;
827 struct Lisp_Symbol
*symbol_free_list
;
832 allocating_for_lisp
= 1;
833 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
834 allocating_for_lisp
= 0;
835 symbol_block
->next
= 0;
836 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
837 symbol_block_index
= 0;
838 symbol_free_list
= 0;
841 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
842 "Return a newly allocated uninterned symbol whose name is NAME.\n\
843 Its value and function definition are void, and its property list is nil.")
847 register Lisp_Object val
;
848 register struct Lisp_Symbol
*p
;
850 CHECK_STRING (str
, 0);
852 if (symbol_free_list
)
854 XSETSYMBOL (val
, symbol_free_list
);
855 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
859 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
861 struct symbol_block
*new;
862 allocating_for_lisp
= 1;
863 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
864 allocating_for_lisp
= 0;
865 VALIDATE_LISP_STORAGE (new, sizeof *new);
866 new->next
= symbol_block
;
868 symbol_block_index
= 0;
870 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
873 p
->name
= XSTRING (str
);
876 p
->function
= Qunbound
;
878 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
883 /* Allocation of markers and other objects that share that structure.
884 Works like allocation of conses. */
886 #define MARKER_BLOCK_SIZE \
887 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
891 struct marker_block
*next
;
892 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
895 struct marker_block
*marker_block
;
896 int marker_block_index
;
898 union Lisp_Misc
*marker_free_list
;
903 allocating_for_lisp
= 1;
904 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
905 allocating_for_lisp
= 0;
906 marker_block
->next
= 0;
907 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
908 marker_block_index
= 0;
909 marker_free_list
= 0;
912 /* Return a newly allocated Lisp_Misc object, with no substructure. */
918 if (marker_free_list
)
920 XSETMISC (val
, marker_free_list
);
921 marker_free_list
= marker_free_list
->u_free
.chain
;
925 if (marker_block_index
== MARKER_BLOCK_SIZE
)
927 struct marker_block
*new;
928 allocating_for_lisp
= 1;
929 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
930 allocating_for_lisp
= 0;
931 VALIDATE_LISP_STORAGE (new, sizeof *new);
932 new->next
= marker_block
;
934 marker_block_index
= 0;
936 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
938 consing_since_gc
+= sizeof (union Lisp_Misc
);
939 misc_objects_consed
++;
943 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
944 "Return a newly allocated marker which does not point at any place.")
947 register Lisp_Object val
;
948 register struct Lisp_Marker
*p
;
950 val
= allocate_misc ();
951 XMISCTYPE (val
) = Lisp_Misc_Marker
;
956 p
->insertion_type
= 0;
960 /* Allocation of strings */
962 /* Strings reside inside of string_blocks. The entire data of the string,
963 both the size and the contents, live in part of the `chars' component of a string_block.
964 The `pos' component is the index within `chars' of the first free byte.
966 first_string_block points to the first string_block ever allocated.
967 Each block points to the next one with its `next' field.
968 The `prev' fields chain in reverse order.
969 The last one allocated is the one currently being filled.
970 current_string_block points to it.
972 The string_blocks that hold individual large strings
973 go in a separate chain, started by large_string_blocks. */
976 /* String blocks contain this many useful bytes.
977 8188 is power of 2, minus 4 for malloc overhead. */
978 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
980 /* A string bigger than this gets its own specially-made string block
981 if it doesn't fit in the current one. */
982 #define STRING_BLOCK_OUTSIZE 1024
984 struct string_block_head
986 struct string_block
*next
, *prev
;
992 struct string_block
*next
, *prev
;
994 char chars
[STRING_BLOCK_SIZE
];
997 /* This points to the string block we are now allocating strings. */
999 struct string_block
*current_string_block
;
1001 /* This points to the oldest string block, the one that starts the chain. */
1003 struct string_block
*first_string_block
;
1005 /* Last string block in chain of those made for individual large strings. */
1007 struct string_block
*large_string_blocks
;
1009 /* If SIZE is the length of a string, this returns how many bytes
1010 the string occupies in a string_block (including padding). */
1012 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1014 #define PAD (sizeof (EMACS_INT))
1017 #define STRING_FULLSIZE(SIZE) \
1018 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1024 allocating_for_lisp
= 1;
1025 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1026 allocating_for_lisp
= 0;
1027 first_string_block
= current_string_block
;
1028 consing_since_gc
+= sizeof (struct string_block
);
1029 current_string_block
->next
= 0;
1030 current_string_block
->prev
= 0;
1031 current_string_block
->pos
= 0;
1032 large_string_blocks
= 0;
1035 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1036 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1037 Both LENGTH and INIT must be numbers.")
1039 Lisp_Object length
, init
;
1041 register Lisp_Object val
;
1042 register unsigned char *p
, *end
, c
;
1044 CHECK_NATNUM (length
, 0);
1045 CHECK_NUMBER (init
, 1);
1046 val
= make_uninit_string (XFASTINT (length
));
1048 p
= XSTRING (val
)->data
;
1049 end
= p
+ XSTRING (val
)->size
;
1057 make_string (contents
, length
)
1061 register Lisp_Object val
;
1062 val
= make_uninit_string (length
);
1063 bcopy (contents
, XSTRING (val
)->data
, length
);
1071 return make_string (str
, strlen (str
));
1075 make_uninit_string (length
)
1078 register Lisp_Object val
;
1079 register int fullsize
= STRING_FULLSIZE (length
);
1081 if (length
< 0) abort ();
1083 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1084 /* This string can fit in the current string block */
1087 ((struct Lisp_String
*)
1088 (current_string_block
->chars
+ current_string_block
->pos
)));
1089 current_string_block
->pos
+= fullsize
;
1091 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1092 /* This string gets its own string block */
1094 register struct string_block
*new;
1095 allocating_for_lisp
= 1;
1096 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1097 allocating_for_lisp
= 0;
1098 VALIDATE_LISP_STORAGE (new, 0);
1099 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1100 new->pos
= fullsize
;
1101 new->next
= large_string_blocks
;
1102 large_string_blocks
= new;
1104 ((struct Lisp_String
*)
1105 ((struct string_block_head
*)new + 1)));
1108 /* Make a new current string block and start it off with this string */
1110 register struct string_block
*new;
1111 allocating_for_lisp
= 1;
1112 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1113 allocating_for_lisp
= 0;
1114 VALIDATE_LISP_STORAGE (new, sizeof *new);
1115 consing_since_gc
+= sizeof (struct string_block
);
1116 current_string_block
->next
= new;
1117 new->prev
= current_string_block
;
1119 current_string_block
= new;
1120 new->pos
= fullsize
;
1122 (struct Lisp_String
*) current_string_block
->chars
);
1125 string_chars_consed
+= fullsize
;
1126 XSTRING (val
)->size
= length
;
1127 XSTRING (val
)->data
[length
] = 0;
1128 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1133 /* Return a newly created vector or string with specified arguments as
1134 elements. If all the arguments are characters that can fit
1135 in a string of events, make a string; otherwise, make a vector.
1137 Any number of arguments, even zero arguments, are allowed. */
1140 make_event_array (nargs
, args
)
1146 for (i
= 0; i
< nargs
; i
++)
1147 /* The things that fit in a string
1148 are characters that are in 0...127,
1149 after discarding the meta bit and all the bits above it. */
1150 if (!INTEGERP (args
[i
])
1151 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1152 return Fvector (nargs
, args
);
1154 /* Since the loop exited, we know that all the things in it are
1155 characters, so we can make a string. */
1159 result
= Fmake_string (nargs
, make_number (0));
1160 for (i
= 0; i
< nargs
; i
++)
1162 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1163 /* Move the meta bit to the right place for a string char. */
1164 if (XINT (args
[i
]) & CHAR_META
)
1165 XSTRING (result
)->data
[i
] |= 0x80;
1172 /* Pure storage management. */
1174 /* Must get an error if pure storage is full,
1175 since if it cannot hold a large string
1176 it may be able to hold conses that point to that string;
1177 then the string is not protected from gc. */
1180 make_pure_string (data
, length
)
1184 register Lisp_Object
new;
1185 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1187 if (pureptr
+ size
> PURESIZE
)
1188 error ("Pure Lisp storage exhausted");
1189 XSETSTRING (new, PUREBEG
+ pureptr
);
1190 XSTRING (new)->size
= length
;
1191 bcopy (data
, XSTRING (new)->data
, length
);
1192 XSTRING (new)->data
[length
] = 0;
1194 /* We must give strings in pure storage some kind of interval. So we
1195 give them a null one. */
1196 #if defined (USE_TEXT_PROPERTIES)
1197 XSTRING (new)->intervals
= NULL_INTERVAL
;
1199 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1200 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1205 pure_cons (car
, cdr
)
1206 Lisp_Object car
, cdr
;
1208 register Lisp_Object
new;
1210 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1211 error ("Pure Lisp storage exhausted");
1212 XSETCONS (new, PUREBEG
+ pureptr
);
1213 pureptr
+= sizeof (struct Lisp_Cons
);
1214 XCONS (new)->car
= Fpurecopy (car
);
1215 XCONS (new)->cdr
= Fpurecopy (cdr
);
1219 #ifdef LISP_FLOAT_TYPE
1222 make_pure_float (num
)
1225 register Lisp_Object
new;
1227 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1228 (double) boundary. Some architectures (like the sparc) require
1229 this, and I suspect that floats are rare enough that it's no
1230 tragedy for those that do. */
1233 char *p
= PUREBEG
+ pureptr
;
1237 alignment
= __alignof (struct Lisp_Float
);
1239 alignment
= sizeof (struct Lisp_Float
);
1242 alignment
= sizeof (struct Lisp_Float
);
1244 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1245 pureptr
= p
- PUREBEG
;
1248 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1249 error ("Pure Lisp storage exhausted");
1250 XSETFLOAT (new, PUREBEG
+ pureptr
);
1251 pureptr
+= sizeof (struct Lisp_Float
);
1252 XFLOAT (new)->data
= num
;
1253 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1257 #endif /* LISP_FLOAT_TYPE */
1260 make_pure_vector (len
)
1263 register Lisp_Object
new;
1264 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1266 if (pureptr
+ size
> PURESIZE
)
1267 error ("Pure Lisp storage exhausted");
1269 XSETVECTOR (new, PUREBEG
+ pureptr
);
1271 XVECTOR (new)->size
= len
;
1275 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1276 "Make a copy of OBJECT in pure storage.\n\
1277 Recursively copies contents of vectors and cons cells.\n\
1278 Does not copy symbols.")
1280 register Lisp_Object obj
;
1282 if (NILP (Vpurify_flag
))
1285 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1286 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1290 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1291 #ifdef LISP_FLOAT_TYPE
1292 else if (FLOATP (obj
))
1293 return make_pure_float (XFLOAT (obj
)->data
);
1294 #endif /* LISP_FLOAT_TYPE */
1295 else if (STRINGP (obj
))
1296 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1297 else if (COMPILEDP (obj
) || VECTORP (obj
))
1299 register struct Lisp_Vector
*vec
;
1300 register int i
, size
;
1302 size
= XVECTOR (obj
)->size
;
1303 if (size
& PSEUDOVECTOR_FLAG
)
1304 size
&= PSEUDOVECTOR_SIZE_MASK
;
1305 vec
= XVECTOR (make_pure_vector (size
));
1306 for (i
= 0; i
< size
; i
++)
1307 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1308 if (COMPILEDP (obj
))
1309 XSETCOMPILED (obj
, vec
);
1311 XSETVECTOR (obj
, vec
);
1314 else if (MARKERP (obj
))
1315 error ("Attempt to copy a marker to pure storage");
1320 /* Recording what needs to be marked for gc. */
1322 struct gcpro
*gcprolist
;
1324 #define NSTATICS 768
1326 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1330 /* Put an entry in staticvec, pointing at the variable whose address is given */
1333 staticpro (varaddress
)
1334 Lisp_Object
*varaddress
;
1336 staticvec
[staticidx
++] = varaddress
;
1337 if (staticidx
>= NSTATICS
)
1345 struct catchtag
*next
;
1346 /* jmp_buf jmp; /* We don't need this for GC purposes */
1351 struct backtrace
*next
;
1352 Lisp_Object
*function
;
1353 Lisp_Object
*args
; /* Points to vector of args. */
1354 int nargs
; /* length of vector */
1355 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1359 /* Garbage collection! */
1361 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1362 int total_free_conses
, total_free_markers
, total_free_symbols
;
1363 #ifdef LISP_FLOAT_TYPE
1364 int total_free_floats
, total_floats
;
1365 #endif /* LISP_FLOAT_TYPE */
1367 /* Temporarily prevent garbage collection. */
1370 inhibit_garbage_collection ()
1372 int count
= specpdl_ptr
- specpdl
;
1374 int nbits
= min (VALBITS
, INTBITS
);
1376 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1378 specbind (Qgc_cons_threshold
, number
);
1383 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1384 "Reclaim storage for Lisp objects no longer needed.\n\
1385 Returns info on amount of space in use:\n\
1386 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1387 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1388 (USED-FLOATS . FREE-FLOATS))\n\
1389 Garbage collection happens automatically if you cons more than\n\
1390 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1393 register struct gcpro
*tail
;
1394 register struct specbinding
*bind
;
1395 struct catchtag
*catch;
1396 struct handler
*handler
;
1397 register struct backtrace
*backlist
;
1398 register Lisp_Object tem
;
1399 char *omessage
= echo_area_glyphs
;
1400 int omessage_length
= echo_area_glyphs_length
;
1401 char stack_top_variable
;
1404 /* In case user calls debug_print during GC,
1405 don't let that cause a recursive GC. */
1406 consing_since_gc
= 0;
1408 /* Save a copy of the contents of the stack, for debugging. */
1409 #if MAX_SAVE_STACK > 0
1410 if (NILP (Vpurify_flag
))
1412 i
= &stack_top_variable
- stack_bottom
;
1414 if (i
< MAX_SAVE_STACK
)
1416 if (stack_copy
== 0)
1417 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1418 else if (stack_copy_size
< i
)
1419 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1422 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1423 bcopy (stack_bottom
, stack_copy
, i
);
1425 bcopy (&stack_top_variable
, stack_copy
, i
);
1429 #endif /* MAX_SAVE_STACK > 0 */
1431 if (!noninteractive
)
1432 message1_nolog ("Garbage collecting...");
1434 /* Don't keep command history around forever */
1435 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1437 XCONS (tem
)->cdr
= Qnil
;
1439 /* Likewise for undo information. */
1441 register struct buffer
*nextb
= all_buffers
;
1445 /* If a buffer's undo list is Qt, that means that undo is
1446 turned off in that buffer. Calling truncate_undo_list on
1447 Qt tends to return NULL, which effectively turns undo back on.
1448 So don't call truncate_undo_list if undo_list is Qt. */
1449 if (! EQ (nextb
->undo_list
, Qt
))
1451 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1453 nextb
= nextb
->next
;
1459 /* clear_marks (); */
1461 /* In each "large string", set the MARKBIT of the size field.
1462 That enables mark_object to recognize them. */
1464 register struct string_block
*b
;
1465 for (b
= large_string_blocks
; b
; b
= b
->next
)
1466 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1469 /* Mark all the special slots that serve as the roots of accessibility.
1471 Usually the special slots to mark are contained in particular structures.
1472 Then we know no slot is marked twice because the structures don't overlap.
1473 In some cases, the structures point to the slots to be marked.
1474 For these, we use MARKBIT to avoid double marking of the slot. */
1476 for (i
= 0; i
< staticidx
; i
++)
1477 mark_object (staticvec
[i
]);
1478 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1479 for (i
= 0; i
< tail
->nvars
; i
++)
1480 if (!XMARKBIT (tail
->var
[i
]))
1482 mark_object (&tail
->var
[i
]);
1483 XMARK (tail
->var
[i
]);
1485 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1487 mark_object (&bind
->symbol
);
1488 mark_object (&bind
->old_value
);
1490 for (catch = catchlist
; catch; catch = catch->next
)
1492 mark_object (&catch->tag
);
1493 mark_object (&catch->val
);
1495 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1497 mark_object (&handler
->handler
);
1498 mark_object (&handler
->var
);
1500 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1502 if (!XMARKBIT (*backlist
->function
))
1504 mark_object (backlist
->function
);
1505 XMARK (*backlist
->function
);
1507 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1510 i
= backlist
->nargs
- 1;
1512 if (!XMARKBIT (backlist
->args
[i
]))
1514 mark_object (&backlist
->args
[i
]);
1515 XMARK (backlist
->args
[i
]);
1522 /* Clear the mark bits that we set in certain root slots. */
1524 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1525 for (i
= 0; i
< tail
->nvars
; i
++)
1526 XUNMARK (tail
->var
[i
]);
1527 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1529 XUNMARK (*backlist
->function
);
1530 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1533 i
= backlist
->nargs
- 1;
1535 XUNMARK (backlist
->args
[i
]);
1537 XUNMARK (buffer_defaults
.name
);
1538 XUNMARK (buffer_local_symbols
.name
);
1540 /* clear_marks (); */
1543 consing_since_gc
= 0;
1544 if (gc_cons_threshold
< 10000)
1545 gc_cons_threshold
= 10000;
1547 if (omessage
|| minibuf_level
> 0)
1548 message2_nolog (omessage
, omessage_length
);
1549 else if (!noninteractive
)
1550 message1_nolog ("Garbage collecting...done");
1552 return Fcons (Fcons (make_number (total_conses
),
1553 make_number (total_free_conses
)),
1554 Fcons (Fcons (make_number (total_symbols
),
1555 make_number (total_free_symbols
)),
1556 Fcons (Fcons (make_number (total_markers
),
1557 make_number (total_free_markers
)),
1558 Fcons (make_number (total_string_size
),
1559 Fcons (make_number (total_vector_size
),
1561 #ifdef LISP_FLOAT_TYPE
1562 Fcons (Fcons (make_number (total_floats
),
1563 make_number (total_free_floats
)),
1565 #else /* not LISP_FLOAT_TYPE */
1567 #endif /* not LISP_FLOAT_TYPE */
1575 /* Clear marks on all conses */
1577 register struct cons_block
*cblk
;
1578 register int lim
= cons_block_index
;
1580 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1583 for (i
= 0; i
< lim
; i
++)
1584 XUNMARK (cblk
->conses
[i
].car
);
1585 lim
= CONS_BLOCK_SIZE
;
1588 /* Clear marks on all symbols */
1590 register struct symbol_block
*sblk
;
1591 register int lim
= symbol_block_index
;
1593 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1596 for (i
= 0; i
< lim
; i
++)
1598 XUNMARK (sblk
->symbols
[i
].plist
);
1600 lim
= SYMBOL_BLOCK_SIZE
;
1603 /* Clear marks on all markers */
1605 register struct marker_block
*sblk
;
1606 register int lim
= marker_block_index
;
1608 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1611 for (i
= 0; i
< lim
; i
++)
1612 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1613 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1614 lim
= MARKER_BLOCK_SIZE
;
1617 /* Clear mark bits on all buffers */
1619 register struct buffer
*nextb
= all_buffers
;
1623 XUNMARK (nextb
->name
);
1624 nextb
= nextb
->next
;
1630 /* Mark reference to a Lisp_Object.
1631 If the object referred to has not been seen yet, recursively mark
1632 all the references contained in it.
1634 If the object referenced is a short string, the referencing slot
1635 is threaded into a chain of such slots, pointed to from
1636 the `size' field of the string. The actual string size
1637 lives in the last slot in the chain. We recognize the end
1638 because it is < (unsigned) STRING_BLOCK_SIZE. */
1640 #define LAST_MARKED_SIZE 500
1641 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1642 int last_marked_index
;
1645 mark_object (objptr
)
1646 Lisp_Object
*objptr
;
1648 register Lisp_Object obj
;
1655 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1656 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1659 last_marked
[last_marked_index
++] = objptr
;
1660 if (last_marked_index
== LAST_MARKED_SIZE
)
1661 last_marked_index
= 0;
1663 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1667 register struct Lisp_String
*ptr
= XSTRING (obj
);
1669 MARK_INTERVAL_TREE (ptr
->intervals
);
1670 if (ptr
->size
& MARKBIT
)
1671 /* A large string. Just set ARRAY_MARK_FLAG. */
1672 ptr
->size
|= ARRAY_MARK_FLAG
;
1675 /* A small string. Put this reference
1676 into the chain of references to it.
1677 If the address includes MARKBIT, put that bit elsewhere
1678 when we store OBJPTR into the size field. */
1680 if (XMARKBIT (*objptr
))
1682 XSETFASTINT (*objptr
, ptr
->size
);
1686 XSETFASTINT (*objptr
, ptr
->size
);
1688 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1690 ptr
->size
= (EMACS_INT
) objptr
;
1691 if (ptr
->size
& MARKBIT
)
1692 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1697 case Lisp_Vectorlike
:
1698 if (GC_BUFFERP (obj
))
1700 if (!XMARKBIT (XBUFFER (obj
)->name
))
1703 else if (GC_SUBRP (obj
))
1705 else if (GC_COMPILEDP (obj
))
1706 /* We could treat this just like a vector, but it is better
1707 to save the COMPILED_CONSTANTS element for last and avoid recursion
1710 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1711 register EMACS_INT size
= ptr
->size
;
1712 /* See comment above under Lisp_Vector. */
1713 struct Lisp_Vector
*volatile ptr1
= ptr
;
1716 if (size
& ARRAY_MARK_FLAG
)
1717 break; /* Already marked */
1718 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1719 size
&= PSEUDOVECTOR_SIZE_MASK
;
1720 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1722 if (i
!= COMPILED_CONSTANTS
)
1723 mark_object (&ptr1
->contents
[i
]);
1725 /* This cast should be unnecessary, but some Mips compiler complains
1726 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1727 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1731 else if (GC_FRAMEP (obj
))
1733 /* See comment above under Lisp_Vector for why this is volatile. */
1734 register struct frame
*volatile ptr
= XFRAME (obj
);
1735 register EMACS_INT size
= ptr
->size
;
1737 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1738 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1740 mark_object (&ptr
->name
);
1741 mark_object (&ptr
->icon_name
);
1742 mark_object (&ptr
->focus_frame
);
1743 mark_object (&ptr
->selected_window
);
1744 mark_object (&ptr
->minibuffer_window
);
1745 mark_object (&ptr
->param_alist
);
1746 mark_object (&ptr
->scroll_bars
);
1747 mark_object (&ptr
->condemned_scroll_bars
);
1748 mark_object (&ptr
->menu_bar_items
);
1749 mark_object (&ptr
->face_alist
);
1750 mark_object (&ptr
->menu_bar_vector
);
1751 mark_object (&ptr
->buffer_predicate
);
1753 #endif /* MULTI_FRAME */
1756 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1757 register EMACS_INT size
= ptr
->size
;
1758 /* The reason we use ptr1 is to avoid an apparent hardware bug
1759 that happens occasionally on the FSF's HP 300s.
1760 The bug is that a2 gets clobbered by recursive calls to mark_object.
1761 The clobberage seems to happen during function entry,
1762 perhaps in the moveml instruction.
1763 Yes, this is a crock, but we have to do it. */
1764 struct Lisp_Vector
*volatile ptr1
= ptr
;
1767 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1768 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1769 if (size
& PSEUDOVECTOR_FLAG
)
1770 size
&= PSEUDOVECTOR_SIZE_MASK
;
1771 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1772 mark_object (&ptr1
->contents
[i
]);
1778 /* See comment above under Lisp_Vector for why this is volatile. */
1779 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1780 struct Lisp_Symbol
*ptrx
;
1782 if (XMARKBIT (ptr
->plist
)) break;
1784 mark_object ((Lisp_Object
*) &ptr
->value
);
1785 mark_object (&ptr
->function
);
1786 mark_object (&ptr
->plist
);
1787 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1788 mark_object (&ptr
->name
);
1792 /* For the benefit of the last_marked log. */
1793 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1794 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1795 XSETSYMBOL (obj
, ptrx
);
1796 /* We can't goto loop here because *objptr doesn't contain an
1797 actual Lisp_Object with valid datatype field. */
1804 switch (XMISCTYPE (obj
))
1806 case Lisp_Misc_Marker
:
1807 XMARK (XMARKER (obj
)->chain
);
1808 /* DO NOT mark thru the marker's chain.
1809 The buffer's markers chain does not preserve markers from gc;
1810 instead, markers are removed from the chain when freed by gc. */
1813 case Lisp_Misc_Buffer_Local_Value
:
1814 case Lisp_Misc_Some_Buffer_Local_Value
:
1816 register struct Lisp_Buffer_Local_Value
*ptr
1817 = XBUFFER_LOCAL_VALUE (obj
);
1818 if (XMARKBIT (ptr
->car
)) break;
1820 /* If the cdr is nil, avoid recursion for the car. */
1821 if (EQ (ptr
->cdr
, Qnil
))
1826 mark_object (&ptr
->car
);
1827 /* See comment above under Lisp_Vector for why not use ptr here. */
1828 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1832 case Lisp_Misc_Intfwd
:
1833 case Lisp_Misc_Boolfwd
:
1834 case Lisp_Misc_Objfwd
:
1835 case Lisp_Misc_Buffer_Objfwd
:
1836 case Lisp_Misc_Kboard_Objfwd
:
1837 /* Don't bother with Lisp_Buffer_Objfwd,
1838 since all markable slots in current buffer marked anyway. */
1839 /* Don't need to do Lisp_Objfwd, since the places they point
1840 are protected with staticpro. */
1843 case Lisp_Misc_Overlay
:
1845 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1846 if (!XMARKBIT (ptr
->plist
))
1849 mark_object (&ptr
->start
);
1850 mark_object (&ptr
->end
);
1851 objptr
= &ptr
->plist
;
1864 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1865 if (XMARKBIT (ptr
->car
)) break;
1867 /* If the cdr is nil, avoid recursion for the car. */
1868 if (EQ (ptr
->cdr
, Qnil
))
1873 mark_object (&ptr
->car
);
1874 /* See comment above under Lisp_Vector for why not use ptr here. */
1875 objptr
= &XCONS (obj
)->cdr
;
1879 #ifdef LISP_FLOAT_TYPE
1881 XMARK (XFLOAT (obj
)->type
);
1883 #endif /* LISP_FLOAT_TYPE */
1893 /* Mark the pointers in a buffer structure. */
1899 register struct buffer
*buffer
= XBUFFER (buf
);
1900 register Lisp_Object
*ptr
;
1901 Lisp_Object base_buffer
;
1903 /* This is the buffer's markbit */
1904 mark_object (&buffer
->name
);
1905 XMARK (buffer
->name
);
1907 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1910 mark_object (buffer
->syntax_table
);
1912 /* Mark the various string-pointers in the buffer object.
1913 Since the strings may be relocated, we must mark them
1914 in their actual slots. So gc_sweep must convert each slot
1915 back to an ordinary C pointer. */
1916 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1917 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1918 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1919 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1921 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1922 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1923 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1924 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1927 for (ptr
= &buffer
->name
+ 1;
1928 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1932 /* If this is an indirect buffer, mark its base buffer. */
1933 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1935 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1936 mark_buffer (base_buffer
);
1941 /* Mark the pointers in the kboard objects. */
1948 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
1950 if (kb
->kbd_macro_buffer
)
1951 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
1953 mark_object (&kb
->Vprefix_arg
);
1954 mark_object (&kb
->kbd_queue
);
1955 mark_object (&kb
->Vlast_kbd_macro
);
1956 mark_object (&kb
->Vsystem_key_alist
);
1957 mark_object (&kb
->system_key_syms
);
1961 /* Sweep: find all structures not marked, and free them. */
1966 total_string_size
= 0;
1969 /* Put all unmarked conses on free list */
1971 register struct cons_block
*cblk
;
1972 register int lim
= cons_block_index
;
1973 register int num_free
= 0, num_used
= 0;
1977 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1980 for (i
= 0; i
< lim
; i
++)
1981 if (!XMARKBIT (cblk
->conses
[i
].car
))
1984 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1985 cons_free_list
= &cblk
->conses
[i
];
1990 XUNMARK (cblk
->conses
[i
].car
);
1992 lim
= CONS_BLOCK_SIZE
;
1994 total_conses
= num_used
;
1995 total_free_conses
= num_free
;
1998 #ifdef LISP_FLOAT_TYPE
1999 /* Put all unmarked floats on free list */
2001 register struct float_block
*fblk
;
2002 register int lim
= float_block_index
;
2003 register int num_free
= 0, num_used
= 0;
2005 float_free_list
= 0;
2007 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2010 for (i
= 0; i
< lim
; i
++)
2011 if (!XMARKBIT (fblk
->floats
[i
].type
))
2014 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2015 float_free_list
= &fblk
->floats
[i
];
2020 XUNMARK (fblk
->floats
[i
].type
);
2022 lim
= FLOAT_BLOCK_SIZE
;
2024 total_floats
= num_used
;
2025 total_free_floats
= num_free
;
2027 #endif /* LISP_FLOAT_TYPE */
2029 #ifdef USE_TEXT_PROPERTIES
2030 /* Put all unmarked intervals on free list */
2032 register struct interval_block
*iblk
;
2033 register int lim
= interval_block_index
;
2034 register int num_free
= 0, num_used
= 0;
2036 interval_free_list
= 0;
2038 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2042 for (i
= 0; i
< lim
; i
++)
2044 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2046 iblk
->intervals
[i
].parent
= interval_free_list
;
2047 interval_free_list
= &iblk
->intervals
[i
];
2053 XUNMARK (iblk
->intervals
[i
].plist
);
2056 lim
= INTERVAL_BLOCK_SIZE
;
2058 total_intervals
= num_used
;
2059 total_free_intervals
= num_free
;
2061 #endif /* USE_TEXT_PROPERTIES */
2063 /* Put all unmarked symbols on free list */
2065 register struct symbol_block
*sblk
;
2066 register int lim
= symbol_block_index
;
2067 register int num_free
= 0, num_used
= 0;
2069 symbol_free_list
= 0;
2071 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2074 for (i
= 0; i
< lim
; i
++)
2075 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2077 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2078 symbol_free_list
= &sblk
->symbols
[i
];
2084 sblk
->symbols
[i
].name
2085 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2086 XUNMARK (sblk
->symbols
[i
].plist
);
2088 lim
= SYMBOL_BLOCK_SIZE
;
2090 total_symbols
= num_used
;
2091 total_free_symbols
= num_free
;
2095 /* Put all unmarked markers on free list.
2096 Dechain each one first from the buffer it points into,
2097 but only if it's a real marker. */
2099 register struct marker_block
*mblk
;
2100 register int lim
= marker_block_index
;
2101 register int num_free
= 0, num_used
= 0;
2103 marker_free_list
= 0;
2105 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2108 EMACS_INT already_free
= -1;
2110 for (i
= 0; i
< lim
; i
++)
2112 Lisp_Object
*markword
;
2113 switch (mblk
->markers
[i
].u_marker
.type
)
2115 case Lisp_Misc_Marker
:
2116 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2118 case Lisp_Misc_Buffer_Local_Value
:
2119 case Lisp_Misc_Some_Buffer_Local_Value
:
2120 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2122 case Lisp_Misc_Overlay
:
2123 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2125 case Lisp_Misc_Free
:
2126 /* If the object was already free, keep it
2127 on the free list. */
2128 markword
= &already_free
;
2134 if (markword
&& !XMARKBIT (*markword
))
2137 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2139 /* tem1 avoids Sun compiler bug */
2140 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2141 XSETMARKER (tem
, tem1
);
2142 unchain_marker (tem
);
2144 /* Set the type of the freed object to Lisp_Misc_Free.
2145 We could leave the type alone, since nobody checks it,
2146 but this might catch bugs faster. */
2147 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2148 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2149 marker_free_list
= &mblk
->markers
[i
];
2156 XUNMARK (*markword
);
2159 lim
= MARKER_BLOCK_SIZE
;
2162 total_markers
= num_used
;
2163 total_free_markers
= num_free
;
2166 /* Free all unmarked buffers */
2168 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2171 if (!XMARKBIT (buffer
->name
))
2174 prev
->next
= buffer
->next
;
2176 all_buffers
= buffer
->next
;
2177 next
= buffer
->next
;
2183 XUNMARK (buffer
->name
);
2184 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2187 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2188 for purposes of marking and relocation.
2189 Turn them back into C pointers now. */
2190 buffer
->upcase_table
2191 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2192 buffer
->downcase_table
2193 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2195 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2196 buffer
->folding_sort_table
2197 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2200 prev
= buffer
, buffer
= buffer
->next
;
2204 #endif /* standalone */
2206 /* Free all unmarked vectors */
2208 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2209 total_vector_size
= 0;
2212 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2215 prev
->next
= vector
->next
;
2217 all_vectors
= vector
->next
;
2218 next
= vector
->next
;
2224 vector
->size
&= ~ARRAY_MARK_FLAG
;
2225 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2226 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2228 total_vector_size
+= vector
->size
;
2229 prev
= vector
, vector
= vector
->next
;
2233 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2235 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2236 struct Lisp_String
*s
;
2240 s
= (struct Lisp_String
*) &sb
->chars
[0];
2241 if (s
->size
& ARRAY_MARK_FLAG
)
2243 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2244 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2245 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2246 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2247 prev
= sb
, sb
= sb
->next
;
2252 prev
->next
= sb
->next
;
2254 large_string_blocks
= sb
->next
;
2263 /* Compactify strings, relocate references, and free empty string blocks. */
2268 /* String block of old strings we are scanning. */
2269 register struct string_block
*from_sb
;
2270 /* A preceding string block (or maybe the same one)
2271 where we are copying the still-live strings to. */
2272 register struct string_block
*to_sb
;
2276 to_sb
= first_string_block
;
2279 /* Scan each existing string block sequentially, string by string. */
2280 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2283 /* POS is the index of the next string in the block. */
2284 while (pos
< from_sb
->pos
)
2286 register struct Lisp_String
*nextstr
2287 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2289 register struct Lisp_String
*newaddr
;
2290 register EMACS_INT size
= nextstr
->size
;
2292 /* NEXTSTR is the old address of the next string.
2293 Just skip it if it isn't marked. */
2294 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2296 /* It is marked, so its size field is really a chain of refs.
2297 Find the end of the chain, where the actual size lives. */
2298 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2300 if (size
& DONT_COPY_FLAG
)
2301 size
^= MARKBIT
| DONT_COPY_FLAG
;
2302 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2305 total_string_size
+= size
;
2307 /* If it won't fit in TO_SB, close it out,
2308 and move to the next sb. Keep doing so until
2309 TO_SB reaches a large enough, empty enough string block.
2310 We know that TO_SB cannot advance past FROM_SB here
2311 since FROM_SB is large enough to contain this string.
2312 Any string blocks skipped here
2313 will be patched out and freed later. */
2314 while (to_pos
+ STRING_FULLSIZE (size
)
2315 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2317 to_sb
->pos
= to_pos
;
2318 to_sb
= to_sb
->next
;
2321 /* Compute new address of this string
2322 and update TO_POS for the space being used. */
2323 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2324 to_pos
+= STRING_FULLSIZE (size
);
2326 /* Copy the string itself to the new place. */
2327 if (nextstr
!= newaddr
)
2328 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2329 + INTERVAL_PTR_SIZE
);
2331 /* Go through NEXTSTR's chain of references
2332 and make each slot in the chain point to
2333 the new address of this string. */
2334 size
= newaddr
->size
;
2335 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2337 register Lisp_Object
*objptr
;
2338 if (size
& DONT_COPY_FLAG
)
2339 size
^= MARKBIT
| DONT_COPY_FLAG
;
2340 objptr
= (Lisp_Object
*)size
;
2342 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2343 if (XMARKBIT (*objptr
))
2345 XSETSTRING (*objptr
, newaddr
);
2349 XSETSTRING (*objptr
, newaddr
);
2351 /* Store the actual size in the size field. */
2352 newaddr
->size
= size
;
2354 #ifdef USE_TEXT_PROPERTIES
2355 /* Now that the string has been relocated, rebalance its
2356 interval tree, and update the tree's parent pointer. */
2357 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2359 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2360 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2363 #endif /* USE_TEXT_PROPERTIES */
2365 pos
+= STRING_FULLSIZE (size
);
2369 /* Close out the last string block still used and free any that follow. */
2370 to_sb
->pos
= to_pos
;
2371 current_string_block
= to_sb
;
2373 from_sb
= to_sb
->next
;
2377 to_sb
= from_sb
->next
;
2382 /* Free any empty string blocks further back in the chain.
2383 This loop will never free first_string_block, but it is very
2384 unlikely that that one will become empty, so why bother checking? */
2386 from_sb
= first_string_block
;
2387 while (to_sb
= from_sb
->next
)
2389 if (to_sb
->pos
== 0)
2391 if (from_sb
->next
= to_sb
->next
)
2392 from_sb
->next
->prev
= from_sb
;
2400 /* Debugging aids. */
2402 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2403 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2404 This may be helpful in debugging Emacs's memory usage.\n\
2405 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2410 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2415 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2416 "Return a list of counters that measure how much consing there has been.\n\
2417 Each of these counters increments for a certain kind of object.\n\
2418 The counters wrap around from the largest positive integer to zero.\n\
2419 Garbage collection does not decrease them.\n\
2420 The elements of the value are as follows:\n\
2421 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2422 All are in units of 1 = one object consed\n\
2423 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2425 MISCS include overlays, markers, and some internal types.\n\
2426 Frames, windows, buffers, and subprocesses count as vectors\n\
2427 (but the contents of a buffer's text do not count here).")
2430 Lisp_Object lisp_cons_cells_consed
;
2431 Lisp_Object lisp_floats_consed
;
2432 Lisp_Object lisp_vector_cells_consed
;
2433 Lisp_Object lisp_symbols_consed
;
2434 Lisp_Object lisp_string_chars_consed
;
2435 Lisp_Object lisp_misc_objects_consed
;
2436 Lisp_Object lisp_intervals_consed
;
2438 XSETINT (lisp_cons_cells_consed
,
2439 cons_cells_consed
& ~(1 << (VALBITS
- 1)));
2440 XSETINT (lisp_floats_consed
,
2441 floats_consed
& ~(1 << (VALBITS
- 1)));
2442 XSETINT (lisp_vector_cells_consed
,
2443 vector_cells_consed
& ~(1 << (VALBITS
- 1)));
2444 XSETINT (lisp_symbols_consed
,
2445 symbols_consed
& ~(1 << (VALBITS
- 1)));
2446 XSETINT (lisp_string_chars_consed
,
2447 string_chars_consed
& ~(1 << (VALBITS
- 1)));
2448 XSETINT (lisp_misc_objects_consed
,
2449 misc_objects_consed
& ~(1 << (VALBITS
- 1)));
2450 XSETINT (lisp_intervals_consed
,
2451 intervals_consed
& ~(1 << (VALBITS
- 1)));
2453 return Fcons (lisp_cons_cells_consed
,
2454 Fcons (lisp_floats_consed
,
2455 Fcons (lisp_vector_cells_consed
,
2456 Fcons (lisp_symbols_consed
,
2457 Fcons (lisp_string_chars_consed
,
2458 Fcons (lisp_misc_objects_consed
,
2459 Fcons (lisp_intervals_consed
,
2463 /* Initialization */
2467 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2470 pure_size
= PURESIZE
;
2473 ignore_warnings
= 1;
2478 #ifdef LISP_FLOAT_TYPE
2480 #endif /* LISP_FLOAT_TYPE */
2484 malloc_hysteresis
= 32;
2486 malloc_hysteresis
= 0;
2489 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2491 ignore_warnings
= 0;
2494 consing_since_gc
= 0;
2495 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2496 #ifdef VIRT_ADDR_VARIES
2497 malloc_sbrk_unused
= 1<<22; /* A large number */
2498 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2499 #endif /* VIRT_ADDR_VARIES */
2510 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2511 "*Number of bytes of consing between garbage collections.\n\
2512 Garbage collection can happen automatically once this many bytes have been\n\
2513 allocated since the last garbage collection. All data types count.\n\n\
2514 Garbage collection happens automatically only when `eval' is called.\n\n\
2515 By binding this temporarily to a large number, you can effectively\n\
2516 prevent garbage collection during a part of the program.");
2518 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2519 "Number of bytes of sharable Lisp data allocated so far.");
2522 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2523 "Number of bytes of unshared memory allocated in this session.");
2525 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2526 "Number of bytes of unshared memory remaining available in this session.");
2529 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2530 "Non-nil means loading Lisp code in order to dump an executable.\n\
2531 This means that certain objects should be allocated in shared (pure) space.");
2533 DEFVAR_INT ("undo-limit", &undo_limit
,
2534 "Keep no more undo information once it exceeds this size.\n\
2535 This limit is applied when garbage collection happens.\n\
2536 The size is counted as the number of bytes occupied,\n\
2537 which includes both saved text and other data.");
2540 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2541 "Don't keep more than this much size of undo information.\n\
2542 A command which pushes past this size is itself forgotten.\n\
2543 This limit is applied when garbage collection happens.\n\
2544 The size is counted as the number of bytes occupied,\n\
2545 which includes both saved text and other data.");
2546 undo_strong_limit
= 30000;
2548 /* We build this in advance because if we wait until we need it, we might
2549 not be able to allocate the memory to hold it. */
2551 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2552 staticpro (&memory_signal_data
);
2554 staticpro (&Qgc_cons_threshold
);
2555 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2560 defsubr (&Smake_byte_code
);
2561 defsubr (&Smake_list
);
2562 defsubr (&Smake_vector
);
2563 defsubr (&Smake_string
);
2564 defsubr (&Smake_symbol
);
2565 defsubr (&Smake_marker
);
2566 defsubr (&Spurecopy
);
2567 defsubr (&Sgarbage_collect
);
2568 defsubr (&Smemory_limit
);
2569 defsubr (&Smemory_use_counts
);