1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
21 /* Note that this declares bzero on OSF/1. How dumb. */
26 #include "intervals.h"
32 #include "blockinput.h"
36 #include "syssignal.h"
40 /* The following come from gmalloc.c. */
42 #if defined (__STDC__) && __STDC__
44 #define __malloc_size_t size_t
46 #define __malloc_size_t unsigned int
48 extern __malloc_size_t _bytes_used
;
49 extern int __malloc_extra_blocks
;
51 #define max(A,B) ((A) > (B) ? (A) : (B))
52 #define min(A,B) ((A) < (B) ? (A) : (B))
54 /* Macro to verify that storage intended for Lisp objects is not
55 out of range to fit in the space for a pointer.
56 ADDRESS is the start of the block, and SIZE
57 is the amount of space within which objects can start. */
58 #define VALIDATE_LISP_STORAGE(address, size) \
62 XSETCONS (val, (char *) address + size); \
63 if ((char *) XCONS (val) != (char *) address + size) \
70 /* Value of _bytes_used, when spare_memory was freed. */
71 static __malloc_size_t bytes_used_when_full
;
73 /* Number of bytes of consing done since the last gc */
76 /* Count the amount of consing of various sorts of space. */
77 int cons_cells_consed
;
79 int vector_cells_consed
;
81 int string_chars_consed
;
82 int misc_objects_consed
;
85 /* Number of bytes of consing since gc before another gc should be done. */
86 int gc_cons_threshold
;
88 /* Nonzero during gc */
91 #ifndef VIRT_ADDR_VARIES
93 #endif /* VIRT_ADDR_VARIES */
96 #ifndef VIRT_ADDR_VARIES
98 #endif /* VIRT_ADDR_VARIES */
99 int malloc_sbrk_unused
;
101 /* Two limits controlling how much undo information to keep. */
103 int undo_strong_limit
;
105 /* Points to memory space allocated as "spare",
106 to be freed if we run out of memory. */
107 static char *spare_memory
;
109 /* Amount of spare memory to keep in reserve. */
110 #define SPARE_MEMORY (1 << 14)
112 /* Number of extra blocks malloc should get when it needs more core. */
113 static int malloc_hysteresis
;
115 /* Nonzero when malloc is called for allocating Lisp object space. */
116 int allocating_for_lisp
;
118 /* Non-nil means defun should do purecopy on the function definition */
119 Lisp_Object Vpurify_flag
;
122 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
123 #define PUREBEG (char *) pure
125 #define pure PURE_SEG_BITS /* Use shared memory segment */
126 #define PUREBEG (char *)PURE_SEG_BITS
128 /* This variable is used only by the XPNTR macro when HAVE_SHM is
129 defined. If we used the PURESIZE macro directly there, that would
130 make most of emacs dependent on puresize.h, which we don't want -
131 you should be able to change that without too much recompilation.
132 So map_in_data initializes pure_size, and the dependencies work
135 #endif /* not HAVE_SHM */
137 /* Index in pure at which next pure object will be allocated. */
140 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
141 char *pending_malloc_warning
;
143 /* Pre-computed signal argument for use when memory is exhausted. */
144 Lisp_Object memory_signal_data
;
146 /* Maximum amount of C stack to save when a GC happens. */
148 #ifndef MAX_SAVE_STACK
149 #define MAX_SAVE_STACK 16000
152 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
153 pointer to a Lisp_Object, when that pointer is viewed as an integer.
154 (On most machines, pointers are even, so we can use the low bit.
155 Word-addressable architectures may need to override this in the m-file.)
156 When linking references to small strings through the size field, we
157 use this slot to hold the bit that would otherwise be interpreted as
159 #ifndef DONT_COPY_FLAG
160 #define DONT_COPY_FLAG 1
161 #endif /* no DONT_COPY_FLAG */
163 /* Buffer in which we save a copy of the C stack at each GC. */
168 /* Non-zero means ignore malloc warnings. Set during initialization. */
171 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
173 static void mark_object (), mark_buffer (), mark_kboards ();
174 static void clear_marks (), gc_sweep ();
175 static void compact_strings ();
177 /* Versions of malloc and realloc that print warnings as memory gets full. */
180 malloc_warning_1 (str
)
183 Fprinc (str
, Vstandard_output
);
184 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
185 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
186 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
190 /* malloc calls this if it finds we are near exhausting storage */
194 pending_malloc_warning
= str
;
197 display_malloc_warning ()
199 register Lisp_Object val
;
201 val
= build_string (pending_malloc_warning
);
202 pending_malloc_warning
= 0;
203 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
206 /* Called if malloc returns zero */
210 #ifndef SYSTEM_MALLOC
211 bytes_used_when_full
= _bytes_used
;
214 /* The first time we get here, free the spare memory. */
221 /* This used to call error, but if we've run out of memory, we could get
222 infinite recursion trying to build the string. */
224 Fsignal (Qerror
, memory_signal_data
);
227 /* Called if we can't allocate relocatable space for a buffer. */
230 buffer_memory_full ()
232 /* If buffers use the relocating allocator,
233 no need to free spare_memory, because we may have plenty of malloc
234 space left that we could get, and if we don't, the malloc that fails
235 will itself cause spare_memory to be freed.
236 If buffers don't use the relocating allocator,
237 treat this like any other failing malloc. */
243 /* This used to call error, but if we've run out of memory, we could get
244 infinite recursion trying to build the string. */
246 Fsignal (Qerror
, memory_signal_data
);
249 /* like malloc routines but check for no memory and block interrupt input. */
258 val
= (long *) malloc (size
);
261 if (!val
&& size
) memory_full ();
266 xrealloc (block
, size
)
273 /* We must call malloc explicitly when BLOCK is 0, since some
274 reallocs don't do this. */
276 val
= (long *) malloc (size
);
278 val
= (long *) realloc (block
, size
);
281 if (!val
&& size
) memory_full ();
295 /* Arranging to disable input signals while we're in malloc.
297 This only works with GNU malloc. To help out systems which can't
298 use GNU malloc, all the calls to malloc, realloc, and free
299 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
300 pairs; unfortunately, we have no idea what C library functions
301 might call malloc, so we can't really protect them unless you're
302 using GNU malloc. Fortunately, most of the major operating can use
305 #ifndef SYSTEM_MALLOC
306 extern void * (*__malloc_hook
) ();
307 static void * (*old_malloc_hook
) ();
308 extern void * (*__realloc_hook
) ();
309 static void * (*old_realloc_hook
) ();
310 extern void (*__free_hook
) ();
311 static void (*old_free_hook
) ();
313 /* This function is used as the hook for free to call. */
316 emacs_blocked_free (ptr
)
320 __free_hook
= old_free_hook
;
322 /* If we released our reserve (due to running out of memory),
323 and we have a fair amount free once again,
324 try to set aside another reserve in case we run out once more. */
325 if (spare_memory
== 0
326 /* Verify there is enough space that even with the malloc
327 hysteresis this call won't run out again.
328 The code here is correct as long as SPARE_MEMORY
329 is substantially larger than the block size malloc uses. */
330 && (bytes_used_when_full
331 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
332 spare_memory
= (char *) malloc (SPARE_MEMORY
);
334 __free_hook
= emacs_blocked_free
;
338 /* If we released our reserve (due to running out of memory),
339 and we have a fair amount free once again,
340 try to set aside another reserve in case we run out once more.
342 This is called when a relocatable block is freed in ralloc.c. */
345 refill_memory_reserve ()
347 if (spare_memory
== 0)
348 spare_memory
= (char *) malloc (SPARE_MEMORY
);
351 /* This function is the malloc hook that Emacs uses. */
354 emacs_blocked_malloc (size
)
360 __malloc_hook
= old_malloc_hook
;
361 __malloc_extra_blocks
= malloc_hysteresis
;
362 value
= (void *) malloc (size
);
363 __malloc_hook
= emacs_blocked_malloc
;
370 emacs_blocked_realloc (ptr
, size
)
377 __realloc_hook
= old_realloc_hook
;
378 value
= (void *) realloc (ptr
, size
);
379 __realloc_hook
= emacs_blocked_realloc
;
386 uninterrupt_malloc ()
388 old_free_hook
= __free_hook
;
389 __free_hook
= emacs_blocked_free
;
391 old_malloc_hook
= __malloc_hook
;
392 __malloc_hook
= emacs_blocked_malloc
;
394 old_realloc_hook
= __realloc_hook
;
395 __realloc_hook
= emacs_blocked_realloc
;
399 /* Interval allocation. */
401 #ifdef USE_TEXT_PROPERTIES
402 #define INTERVAL_BLOCK_SIZE \
403 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
405 struct interval_block
407 struct interval_block
*next
;
408 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
411 struct interval_block
*interval_block
;
412 static int interval_block_index
;
414 INTERVAL interval_free_list
;
419 allocating_for_lisp
= 1;
421 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
422 allocating_for_lisp
= 0;
423 interval_block
->next
= 0;
424 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
425 interval_block_index
= 0;
426 interval_free_list
= 0;
429 #define INIT_INTERVALS init_intervals ()
436 if (interval_free_list
)
438 val
= interval_free_list
;
439 interval_free_list
= interval_free_list
->parent
;
443 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
445 register struct interval_block
*newi
;
447 allocating_for_lisp
= 1;
448 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
450 allocating_for_lisp
= 0;
451 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
452 newi
->next
= interval_block
;
453 interval_block
= newi
;
454 interval_block_index
= 0;
456 val
= &interval_block
->intervals
[interval_block_index
++];
458 consing_since_gc
+= sizeof (struct interval
);
460 RESET_INTERVAL (val
);
464 static int total_free_intervals
, total_intervals
;
466 /* Mark the pointers of one interval. */
469 mark_interval (i
, dummy
)
473 if (XMARKBIT (i
->plist
))
475 mark_object (&i
->plist
);
480 mark_interval_tree (tree
)
481 register INTERVAL tree
;
483 /* No need to test if this tree has been marked already; this
484 function is always called through the MARK_INTERVAL_TREE macro,
485 which takes care of that. */
487 /* XMARK expands to an assignment; the LHS of an assignment can't be
489 XMARK (* (Lisp_Object
*) &tree
->parent
);
491 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
494 #define MARK_INTERVAL_TREE(i) \
496 if (!NULL_INTERVAL_P (i) \
497 && ! XMARKBIT ((Lisp_Object) i->parent)) \
498 mark_interval_tree (i); \
501 /* The oddity in the call to XUNMARK is necessary because XUNMARK
502 expands to an assignment to its argument, and most C compilers don't
503 support casts on the left operand of `='. */
504 #define UNMARK_BALANCE_INTERVALS(i) \
506 if (! NULL_INTERVAL_P (i)) \
508 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
509 (i) = balance_intervals (i); \
513 #else /* no interval use */
515 #define INIT_INTERVALS
517 #define UNMARK_BALANCE_INTERVALS(i)
518 #define MARK_INTERVAL_TREE(i)
520 #endif /* no interval use */
522 /* Floating point allocation. */
524 #ifdef LISP_FLOAT_TYPE
525 /* Allocation of float cells, just like conses */
526 /* We store float cells inside of float_blocks, allocating a new
527 float_block with malloc whenever necessary. Float cells reclaimed by
528 GC are put on a free list to be reallocated before allocating
529 any new float cells from the latest float_block.
531 Each float_block is just under 1020 bytes long,
532 since malloc really allocates in units of powers of two
533 and uses 4 bytes for its own overhead. */
535 #define FLOAT_BLOCK_SIZE \
536 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
540 struct float_block
*next
;
541 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
544 struct float_block
*float_block
;
545 int float_block_index
;
547 struct Lisp_Float
*float_free_list
;
552 allocating_for_lisp
= 1;
553 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
554 allocating_for_lisp
= 0;
555 float_block
->next
= 0;
556 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
557 float_block_index
= 0;
561 /* Explicitly free a float cell. */
563 struct Lisp_Float
*ptr
;
565 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
566 float_free_list
= ptr
;
570 make_float (float_value
)
573 register Lisp_Object val
;
577 XSETFLOAT (val
, float_free_list
);
578 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
582 if (float_block_index
== FLOAT_BLOCK_SIZE
)
584 register struct float_block
*new;
586 allocating_for_lisp
= 1;
587 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
588 allocating_for_lisp
= 0;
589 VALIDATE_LISP_STORAGE (new, sizeof *new);
590 new->next
= float_block
;
592 float_block_index
= 0;
594 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
596 XFLOAT (val
)->data
= float_value
;
597 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
598 consing_since_gc
+= sizeof (struct Lisp_Float
);
603 #endif /* LISP_FLOAT_TYPE */
605 /* Allocation of cons cells */
606 /* We store cons cells inside of cons_blocks, allocating a new
607 cons_block with malloc whenever necessary. Cons cells reclaimed by
608 GC are put on a free list to be reallocated before allocating
609 any new cons cells from the latest cons_block.
611 Each cons_block is just under 1020 bytes long,
612 since malloc really allocates in units of powers of two
613 and uses 4 bytes for its own overhead. */
615 #define CONS_BLOCK_SIZE \
616 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
620 struct cons_block
*next
;
621 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
624 struct cons_block
*cons_block
;
625 int cons_block_index
;
627 struct Lisp_Cons
*cons_free_list
;
632 allocating_for_lisp
= 1;
633 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
634 allocating_for_lisp
= 0;
635 cons_block
->next
= 0;
636 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
637 cons_block_index
= 0;
641 /* Explicitly free a cons cell. */
643 struct Lisp_Cons
*ptr
;
645 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
646 cons_free_list
= ptr
;
649 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
650 "Create a new cons, give it CAR and CDR as components, and return it.")
652 Lisp_Object car
, cdr
;
654 register Lisp_Object val
;
658 XSETCONS (val
, cons_free_list
);
659 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
663 if (cons_block_index
== CONS_BLOCK_SIZE
)
665 register struct cons_block
*new;
666 allocating_for_lisp
= 1;
667 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
668 allocating_for_lisp
= 0;
669 VALIDATE_LISP_STORAGE (new, sizeof *new);
670 new->next
= cons_block
;
672 cons_block_index
= 0;
674 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
676 XCONS (val
)->car
= car
;
677 XCONS (val
)->cdr
= cdr
;
678 consing_since_gc
+= sizeof (struct Lisp_Cons
);
683 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
684 "Return a newly created list with specified arguments as elements.\n\
685 Any number of arguments, even zero arguments, are allowed.")
688 register Lisp_Object
*args
;
690 register Lisp_Object val
;
696 val
= Fcons (args
[nargs
], val
);
701 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
702 "Return a newly created list of length LENGTH, with each element being INIT.")
704 register Lisp_Object length
, init
;
706 register Lisp_Object val
;
709 CHECK_NATNUM (length
, 0);
710 size
= XFASTINT (length
);
714 val
= Fcons (init
, val
);
718 /* Allocation of vectors */
720 struct Lisp_Vector
*all_vectors
;
723 allocate_vectorlike (len
)
726 struct Lisp_Vector
*p
;
728 allocating_for_lisp
= 1;
729 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
730 + (len
- 1) * sizeof (Lisp_Object
));
731 allocating_for_lisp
= 0;
732 VALIDATE_LISP_STORAGE (p
, 0);
733 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
734 + (len
- 1) * sizeof (Lisp_Object
));
735 vector_cells_consed
+= len
;
737 p
->next
= all_vectors
;
742 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
743 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
744 See also the function `vector'.")
746 register Lisp_Object length
, init
;
749 register EMACS_INT sizei
;
751 register struct Lisp_Vector
*p
;
753 CHECK_NATNUM (length
, 0);
754 sizei
= XFASTINT (length
);
756 p
= allocate_vectorlike (sizei
);
758 for (index
= 0; index
< sizei
; index
++)
759 p
->contents
[index
] = init
;
761 XSETVECTOR (vector
, p
);
765 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
766 "Return a newly created char-table, with purpose PURPOSE.\n\
767 Each element is initialized to INIT, which defaults to nil.\n\
768 PURPOSE should be a symbol which has a `char-table-extra-slot' property.\n\
769 The property's value should be an integer between 0 and 10.")
771 register Lisp_Object purpose
, init
;
775 CHECK_SYMBOL (purpose
, 1);
776 n
= Fget (purpose
, Qchar_table_extra_slots
);
778 if (XINT (n
) < 0 || XINT (n
) > 10)
779 args_out_of_range (n
, Qnil
);
780 /* Add 2 to the size for the defalt and parent slots. */
781 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
783 XCHAR_TABLE (vector
)->parent
= Qnil
;
784 XCHAR_TABLE (vector
)->purpose
= purpose
;
785 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
789 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
790 "Return a newly created vector with specified arguments as elements.\n\
791 Any number of arguments, even zero arguments, are allowed.")
796 register Lisp_Object len
, val
;
798 register struct Lisp_Vector
*p
;
800 XSETFASTINT (len
, nargs
);
801 val
= Fmake_vector (len
, Qnil
);
803 for (index
= 0; index
< nargs
; index
++)
804 p
->contents
[index
] = args
[index
];
808 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
809 "Create a byte-code object with specified arguments as elements.\n\
810 The arguments should be the arglist, bytecode-string, constant vector,\n\
811 stack size, (optional) doc string, and (optional) interactive spec.\n\
812 The first four arguments are required; at most six have any\n\
818 register Lisp_Object len
, val
;
820 register struct Lisp_Vector
*p
;
822 XSETFASTINT (len
, nargs
);
823 if (!NILP (Vpurify_flag
))
824 val
= make_pure_vector (len
);
826 val
= Fmake_vector (len
, Qnil
);
828 for (index
= 0; index
< nargs
; index
++)
830 if (!NILP (Vpurify_flag
))
831 args
[index
] = Fpurecopy (args
[index
]);
832 p
->contents
[index
] = args
[index
];
834 XSETCOMPILED (val
, val
);
838 /* Allocation of symbols.
839 Just like allocation of conses!
841 Each symbol_block is just under 1020 bytes long,
842 since malloc really allocates in units of powers of two
843 and uses 4 bytes for its own overhead. */
845 #define SYMBOL_BLOCK_SIZE \
846 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
850 struct symbol_block
*next
;
851 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
854 struct symbol_block
*symbol_block
;
855 int symbol_block_index
;
857 struct Lisp_Symbol
*symbol_free_list
;
862 allocating_for_lisp
= 1;
863 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
864 allocating_for_lisp
= 0;
865 symbol_block
->next
= 0;
866 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
867 symbol_block_index
= 0;
868 symbol_free_list
= 0;
871 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
872 "Return a newly allocated uninterned symbol whose name is NAME.\n\
873 Its value and function definition are void, and its property list is nil.")
877 register Lisp_Object val
;
878 register struct Lisp_Symbol
*p
;
880 CHECK_STRING (name
, 0);
882 if (symbol_free_list
)
884 XSETSYMBOL (val
, symbol_free_list
);
885 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
889 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
891 struct symbol_block
*new;
892 allocating_for_lisp
= 1;
893 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
894 allocating_for_lisp
= 0;
895 VALIDATE_LISP_STORAGE (new, sizeof *new);
896 new->next
= symbol_block
;
898 symbol_block_index
= 0;
900 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
903 p
->name
= XSTRING (name
);
906 p
->function
= Qunbound
;
908 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
913 /* Allocation of markers and other objects that share that structure.
914 Works like allocation of conses. */
916 #define MARKER_BLOCK_SIZE \
917 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
921 struct marker_block
*next
;
922 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
925 struct marker_block
*marker_block
;
926 int marker_block_index
;
928 union Lisp_Misc
*marker_free_list
;
933 allocating_for_lisp
= 1;
934 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
935 allocating_for_lisp
= 0;
936 marker_block
->next
= 0;
937 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
938 marker_block_index
= 0;
939 marker_free_list
= 0;
942 /* Return a newly allocated Lisp_Misc object, with no substructure. */
948 if (marker_free_list
)
950 XSETMISC (val
, marker_free_list
);
951 marker_free_list
= marker_free_list
->u_free
.chain
;
955 if (marker_block_index
== MARKER_BLOCK_SIZE
)
957 struct marker_block
*new;
958 allocating_for_lisp
= 1;
959 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
960 allocating_for_lisp
= 0;
961 VALIDATE_LISP_STORAGE (new, sizeof *new);
962 new->next
= marker_block
;
964 marker_block_index
= 0;
966 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
968 consing_since_gc
+= sizeof (union Lisp_Misc
);
969 misc_objects_consed
++;
973 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
974 "Return a newly allocated marker which does not point at any place.")
977 register Lisp_Object val
;
978 register struct Lisp_Marker
*p
;
980 val
= allocate_misc ();
981 XMISCTYPE (val
) = Lisp_Misc_Marker
;
986 p
->insertion_type
= 0;
990 /* Allocation of strings */
992 /* Strings reside inside of string_blocks. The entire data of the string,
993 both the size and the contents, live in part of the `chars' component of a string_block.
994 The `pos' component is the index within `chars' of the first free byte.
996 first_string_block points to the first string_block ever allocated.
997 Each block points to the next one with its `next' field.
998 The `prev' fields chain in reverse order.
999 The last one allocated is the one currently being filled.
1000 current_string_block points to it.
1002 The string_blocks that hold individual large strings
1003 go in a separate chain, started by large_string_blocks. */
1006 /* String blocks contain this many useful bytes.
1007 8188 is power of 2, minus 4 for malloc overhead. */
1008 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1010 /* A string bigger than this gets its own specially-made string block
1011 if it doesn't fit in the current one. */
1012 #define STRING_BLOCK_OUTSIZE 1024
1014 struct string_block_head
1016 struct string_block
*next
, *prev
;
1022 struct string_block
*next
, *prev
;
1024 char chars
[STRING_BLOCK_SIZE
];
1027 /* This points to the string block we are now allocating strings. */
1029 struct string_block
*current_string_block
;
1031 /* This points to the oldest string block, the one that starts the chain. */
1033 struct string_block
*first_string_block
;
1035 /* Last string block in chain of those made for individual large strings. */
1037 struct string_block
*large_string_blocks
;
1039 /* If SIZE is the length of a string, this returns how many bytes
1040 the string occupies in a string_block (including padding). */
1042 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1044 #define PAD (sizeof (EMACS_INT))
1047 #define STRING_FULLSIZE(SIZE) \
1048 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1054 allocating_for_lisp
= 1;
1055 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1056 allocating_for_lisp
= 0;
1057 first_string_block
= current_string_block
;
1058 consing_since_gc
+= sizeof (struct string_block
);
1059 current_string_block
->next
= 0;
1060 current_string_block
->prev
= 0;
1061 current_string_block
->pos
= 0;
1062 large_string_blocks
= 0;
1065 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1066 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1067 Both LENGTH and INIT must be numbers.")
1069 Lisp_Object length
, init
;
1071 register Lisp_Object val
;
1072 register unsigned char *p
, *end
, c
;
1074 CHECK_NATNUM (length
, 0);
1075 CHECK_NUMBER (init
, 1);
1076 val
= make_uninit_string (XFASTINT (length
));
1078 p
= XSTRING (val
)->data
;
1079 end
= p
+ XSTRING (val
)->size
;
1086 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1087 "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\
1088 Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.")
1090 Lisp_Object length
, init
;
1092 register Lisp_Object val
;
1093 struct Lisp_Bool_Vector
*p
;
1095 int length_in_chars
, length_in_elts
, bits_per_value
;
1097 CHECK_NATNUM (length
, 0);
1099 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1101 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1102 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1104 val
= Fmake_vector (make_number (length_in_elts
), Qnil
);
1105 p
= XBOOL_VECTOR (val
);
1106 /* Get rid of any bits that would cause confusion. */
1108 XSETBOOL_VECTOR (val
, p
);
1109 p
->size
= XFASTINT (length
);
1111 real_init
= (NILP (init
) ? 0 : -1);
1112 for (i
= 0; i
< length_in_chars
; i
++)
1113 p
->data
[i
] = real_init
;
1119 make_string (contents
, length
)
1123 register Lisp_Object val
;
1124 val
= make_uninit_string (length
);
1125 bcopy (contents
, XSTRING (val
)->data
, length
);
1133 return make_string (str
, strlen (str
));
1137 make_uninit_string (length
)
1140 register Lisp_Object val
;
1141 register int fullsize
= STRING_FULLSIZE (length
);
1143 if (length
< 0) abort ();
1145 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1146 /* This string can fit in the current string block */
1149 ((struct Lisp_String
*)
1150 (current_string_block
->chars
+ current_string_block
->pos
)));
1151 current_string_block
->pos
+= fullsize
;
1153 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1154 /* This string gets its own string block */
1156 register struct string_block
*new;
1157 allocating_for_lisp
= 1;
1158 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1159 allocating_for_lisp
= 0;
1160 VALIDATE_LISP_STORAGE (new, 0);
1161 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1162 new->pos
= fullsize
;
1163 new->next
= large_string_blocks
;
1164 large_string_blocks
= new;
1166 ((struct Lisp_String
*)
1167 ((struct string_block_head
*)new + 1)));
1170 /* Make a new current string block and start it off with this string */
1172 register struct string_block
*new;
1173 allocating_for_lisp
= 1;
1174 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1175 allocating_for_lisp
= 0;
1176 VALIDATE_LISP_STORAGE (new, sizeof *new);
1177 consing_since_gc
+= sizeof (struct string_block
);
1178 current_string_block
->next
= new;
1179 new->prev
= current_string_block
;
1181 current_string_block
= new;
1182 new->pos
= fullsize
;
1184 (struct Lisp_String
*) current_string_block
->chars
);
1187 string_chars_consed
+= fullsize
;
1188 XSTRING (val
)->size
= length
;
1189 XSTRING (val
)->data
[length
] = 0;
1190 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1195 /* Return a newly created vector or string with specified arguments as
1196 elements. If all the arguments are characters that can fit
1197 in a string of events, make a string; otherwise, make a vector.
1199 Any number of arguments, even zero arguments, are allowed. */
1202 make_event_array (nargs
, args
)
1208 for (i
= 0; i
< nargs
; i
++)
1209 /* The things that fit in a string
1210 are characters that are in 0...127,
1211 after discarding the meta bit and all the bits above it. */
1212 if (!INTEGERP (args
[i
])
1213 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1214 return Fvector (nargs
, args
);
1216 /* Since the loop exited, we know that all the things in it are
1217 characters, so we can make a string. */
1221 result
= Fmake_string (nargs
, make_number (0));
1222 for (i
= 0; i
< nargs
; i
++)
1224 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1225 /* Move the meta bit to the right place for a string char. */
1226 if (XINT (args
[i
]) & CHAR_META
)
1227 XSTRING (result
)->data
[i
] |= 0x80;
1234 /* Pure storage management. */
1236 /* Must get an error if pure storage is full,
1237 since if it cannot hold a large string
1238 it may be able to hold conses that point to that string;
1239 then the string is not protected from gc. */
1242 make_pure_string (data
, length
)
1246 register Lisp_Object
new;
1247 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1249 if (pureptr
+ size
> PURESIZE
)
1250 error ("Pure Lisp storage exhausted");
1251 XSETSTRING (new, PUREBEG
+ pureptr
);
1252 XSTRING (new)->size
= length
;
1253 bcopy (data
, XSTRING (new)->data
, length
);
1254 XSTRING (new)->data
[length
] = 0;
1256 /* We must give strings in pure storage some kind of interval. So we
1257 give them a null one. */
1258 #if defined (USE_TEXT_PROPERTIES)
1259 XSTRING (new)->intervals
= NULL_INTERVAL
;
1261 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1262 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1267 pure_cons (car
, cdr
)
1268 Lisp_Object car
, cdr
;
1270 register Lisp_Object
new;
1272 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1273 error ("Pure Lisp storage exhausted");
1274 XSETCONS (new, PUREBEG
+ pureptr
);
1275 pureptr
+= sizeof (struct Lisp_Cons
);
1276 XCONS (new)->car
= Fpurecopy (car
);
1277 XCONS (new)->cdr
= Fpurecopy (cdr
);
1281 #ifdef LISP_FLOAT_TYPE
1284 make_pure_float (num
)
1287 register Lisp_Object
new;
1289 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1290 (double) boundary. Some architectures (like the sparc) require
1291 this, and I suspect that floats are rare enough that it's no
1292 tragedy for those that do. */
1295 char *p
= PUREBEG
+ pureptr
;
1299 alignment
= __alignof (struct Lisp_Float
);
1301 alignment
= sizeof (struct Lisp_Float
);
1304 alignment
= sizeof (struct Lisp_Float
);
1306 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1307 pureptr
= p
- PUREBEG
;
1310 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1311 error ("Pure Lisp storage exhausted");
1312 XSETFLOAT (new, PUREBEG
+ pureptr
);
1313 pureptr
+= sizeof (struct Lisp_Float
);
1314 XFLOAT (new)->data
= num
;
1315 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1319 #endif /* LISP_FLOAT_TYPE */
1322 make_pure_vector (len
)
1325 register Lisp_Object
new;
1326 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1328 if (pureptr
+ size
> PURESIZE
)
1329 error ("Pure Lisp storage exhausted");
1331 XSETVECTOR (new, PUREBEG
+ pureptr
);
1333 XVECTOR (new)->size
= len
;
1337 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1338 "Make a copy of OBJECT in pure storage.\n\
1339 Recursively copies contents of vectors and cons cells.\n\
1340 Does not copy symbols.")
1342 register Lisp_Object obj
;
1344 if (NILP (Vpurify_flag
))
1347 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1348 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1352 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1353 #ifdef LISP_FLOAT_TYPE
1354 else if (FLOATP (obj
))
1355 return make_pure_float (XFLOAT (obj
)->data
);
1356 #endif /* LISP_FLOAT_TYPE */
1357 else if (STRINGP (obj
))
1358 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1359 else if (COMPILEDP (obj
) || VECTORP (obj
))
1361 register struct Lisp_Vector
*vec
;
1362 register int i
, size
;
1364 size
= XVECTOR (obj
)->size
;
1365 if (size
& PSEUDOVECTOR_FLAG
)
1366 size
&= PSEUDOVECTOR_SIZE_MASK
;
1367 vec
= XVECTOR (make_pure_vector (size
));
1368 for (i
= 0; i
< size
; i
++)
1369 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1370 if (COMPILEDP (obj
))
1371 XSETCOMPILED (obj
, vec
);
1373 XSETVECTOR (obj
, vec
);
1376 else if (MARKERP (obj
))
1377 error ("Attempt to copy a marker to pure storage");
1382 /* Recording what needs to be marked for gc. */
1384 struct gcpro
*gcprolist
;
1386 #define NSTATICS 768
1388 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1392 /* Put an entry in staticvec, pointing at the variable whose address is given */
1395 staticpro (varaddress
)
1396 Lisp_Object
*varaddress
;
1398 staticvec
[staticidx
++] = varaddress
;
1399 if (staticidx
>= NSTATICS
)
1407 struct catchtag
*next
;
1408 /* jmp_buf jmp; /* We don't need this for GC purposes */
1413 struct backtrace
*next
;
1414 Lisp_Object
*function
;
1415 Lisp_Object
*args
; /* Points to vector of args. */
1416 int nargs
; /* length of vector */
1417 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1421 /* Garbage collection! */
1423 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1424 int total_free_conses
, total_free_markers
, total_free_symbols
;
1425 #ifdef LISP_FLOAT_TYPE
1426 int total_free_floats
, total_floats
;
1427 #endif /* LISP_FLOAT_TYPE */
1429 /* Temporarily prevent garbage collection. */
1432 inhibit_garbage_collection ()
1434 int count
= specpdl_ptr
- specpdl
;
1436 int nbits
= min (VALBITS
, BITS_PER_INT
);
1438 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1440 specbind (Qgc_cons_threshold
, number
);
1445 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1446 "Reclaim storage for Lisp objects no longer needed.\n\
1447 Returns info on amount of space in use:\n\
1448 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1449 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1450 (USED-FLOATS . FREE-FLOATS))\n\
1451 Garbage collection happens automatically if you cons more than\n\
1452 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1455 register struct gcpro
*tail
;
1456 register struct specbinding
*bind
;
1457 struct catchtag
*catch;
1458 struct handler
*handler
;
1459 register struct backtrace
*backlist
;
1460 register Lisp_Object tem
;
1461 char *omessage
= echo_area_glyphs
;
1462 int omessage_length
= echo_area_glyphs_length
;
1463 char stack_top_variable
;
1466 /* In case user calls debug_print during GC,
1467 don't let that cause a recursive GC. */
1468 consing_since_gc
= 0;
1470 /* Save a copy of the contents of the stack, for debugging. */
1471 #if MAX_SAVE_STACK > 0
1472 if (NILP (Vpurify_flag
))
1474 i
= &stack_top_variable
- stack_bottom
;
1476 if (i
< MAX_SAVE_STACK
)
1478 if (stack_copy
== 0)
1479 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1480 else if (stack_copy_size
< i
)
1481 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1484 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1485 bcopy (stack_bottom
, stack_copy
, i
);
1487 bcopy (&stack_top_variable
, stack_copy
, i
);
1491 #endif /* MAX_SAVE_STACK > 0 */
1493 if (!noninteractive
)
1494 message1_nolog ("Garbage collecting...");
1496 /* Don't keep command history around forever */
1497 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1499 XCONS (tem
)->cdr
= Qnil
;
1501 /* Likewise for undo information. */
1503 register struct buffer
*nextb
= all_buffers
;
1507 /* If a buffer's undo list is Qt, that means that undo is
1508 turned off in that buffer. Calling truncate_undo_list on
1509 Qt tends to return NULL, which effectively turns undo back on.
1510 So don't call truncate_undo_list if undo_list is Qt. */
1511 if (! EQ (nextb
->undo_list
, Qt
))
1513 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1515 nextb
= nextb
->next
;
1521 /* clear_marks (); */
1523 /* In each "large string", set the MARKBIT of the size field.
1524 That enables mark_object to recognize them. */
1526 register struct string_block
*b
;
1527 for (b
= large_string_blocks
; b
; b
= b
->next
)
1528 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1531 /* Mark all the special slots that serve as the roots of accessibility.
1533 Usually the special slots to mark are contained in particular structures.
1534 Then we know no slot is marked twice because the structures don't overlap.
1535 In some cases, the structures point to the slots to be marked.
1536 For these, we use MARKBIT to avoid double marking of the slot. */
1538 for (i
= 0; i
< staticidx
; i
++)
1539 mark_object (staticvec
[i
]);
1540 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1541 for (i
= 0; i
< tail
->nvars
; i
++)
1542 if (!XMARKBIT (tail
->var
[i
]))
1544 mark_object (&tail
->var
[i
]);
1545 XMARK (tail
->var
[i
]);
1547 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1549 mark_object (&bind
->symbol
);
1550 mark_object (&bind
->old_value
);
1552 for (catch = catchlist
; catch; catch = catch->next
)
1554 mark_object (&catch->tag
);
1555 mark_object (&catch->val
);
1557 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1559 mark_object (&handler
->handler
);
1560 mark_object (&handler
->var
);
1562 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1564 if (!XMARKBIT (*backlist
->function
))
1566 mark_object (backlist
->function
);
1567 XMARK (*backlist
->function
);
1569 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1572 i
= backlist
->nargs
- 1;
1574 if (!XMARKBIT (backlist
->args
[i
]))
1576 mark_object (&backlist
->args
[i
]);
1577 XMARK (backlist
->args
[i
]);
1584 /* Clear the mark bits that we set in certain root slots. */
1586 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1587 for (i
= 0; i
< tail
->nvars
; i
++)
1588 XUNMARK (tail
->var
[i
]);
1589 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1591 XUNMARK (*backlist
->function
);
1592 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1595 i
= backlist
->nargs
- 1;
1597 XUNMARK (backlist
->args
[i
]);
1599 XUNMARK (buffer_defaults
.name
);
1600 XUNMARK (buffer_local_symbols
.name
);
1602 /* clear_marks (); */
1605 consing_since_gc
= 0;
1606 if (gc_cons_threshold
< 10000)
1607 gc_cons_threshold
= 10000;
1609 if (omessage
|| minibuf_level
> 0)
1610 message2_nolog (omessage
, omessage_length
);
1611 else if (!noninteractive
)
1612 message1_nolog ("Garbage collecting...done");
1614 return Fcons (Fcons (make_number (total_conses
),
1615 make_number (total_free_conses
)),
1616 Fcons (Fcons (make_number (total_symbols
),
1617 make_number (total_free_symbols
)),
1618 Fcons (Fcons (make_number (total_markers
),
1619 make_number (total_free_markers
)),
1620 Fcons (make_number (total_string_size
),
1621 Fcons (make_number (total_vector_size
),
1623 #ifdef LISP_FLOAT_TYPE
1624 Fcons (Fcons (make_number (total_floats
),
1625 make_number (total_free_floats
)),
1627 #else /* not LISP_FLOAT_TYPE */
1629 #endif /* not LISP_FLOAT_TYPE */
1637 /* Clear marks on all conses */
1639 register struct cons_block
*cblk
;
1640 register int lim
= cons_block_index
;
1642 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1645 for (i
= 0; i
< lim
; i
++)
1646 XUNMARK (cblk
->conses
[i
].car
);
1647 lim
= CONS_BLOCK_SIZE
;
1650 /* Clear marks on all symbols */
1652 register struct symbol_block
*sblk
;
1653 register int lim
= symbol_block_index
;
1655 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1658 for (i
= 0; i
< lim
; i
++)
1660 XUNMARK (sblk
->symbols
[i
].plist
);
1662 lim
= SYMBOL_BLOCK_SIZE
;
1665 /* Clear marks on all markers */
1667 register struct marker_block
*sblk
;
1668 register int lim
= marker_block_index
;
1670 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1673 for (i
= 0; i
< lim
; i
++)
1674 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1675 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1676 lim
= MARKER_BLOCK_SIZE
;
1679 /* Clear mark bits on all buffers */
1681 register struct buffer
*nextb
= all_buffers
;
1685 XUNMARK (nextb
->name
);
1686 nextb
= nextb
->next
;
1692 /* Mark reference to a Lisp_Object.
1693 If the object referred to has not been seen yet, recursively mark
1694 all the references contained in it.
1696 If the object referenced is a short string, the referencing slot
1697 is threaded into a chain of such slots, pointed to from
1698 the `size' field of the string. The actual string size
1699 lives in the last slot in the chain. We recognize the end
1700 because it is < (unsigned) STRING_BLOCK_SIZE. */
1702 #define LAST_MARKED_SIZE 500
1703 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1704 int last_marked_index
;
1707 mark_object (argptr
)
1708 Lisp_Object
*argptr
;
1710 Lisp_Object
*objptr
= argptr
;
1711 register Lisp_Object obj
;
1718 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1719 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1722 last_marked
[last_marked_index
++] = objptr
;
1723 if (last_marked_index
== LAST_MARKED_SIZE
)
1724 last_marked_index
= 0;
1726 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1730 register struct Lisp_String
*ptr
= XSTRING (obj
);
1732 MARK_INTERVAL_TREE (ptr
->intervals
);
1733 if (ptr
->size
& MARKBIT
)
1734 /* A large string. Just set ARRAY_MARK_FLAG. */
1735 ptr
->size
|= ARRAY_MARK_FLAG
;
1738 /* A small string. Put this reference
1739 into the chain of references to it.
1740 If the address includes MARKBIT, put that bit elsewhere
1741 when we store OBJPTR into the size field. */
1743 if (XMARKBIT (*objptr
))
1745 XSETFASTINT (*objptr
, ptr
->size
);
1749 XSETFASTINT (*objptr
, ptr
->size
);
1751 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1753 ptr
->size
= (EMACS_INT
) objptr
;
1754 if (ptr
->size
& MARKBIT
)
1755 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1760 case Lisp_Vectorlike
:
1761 if (GC_BUFFERP (obj
))
1763 if (!XMARKBIT (XBUFFER (obj
)->name
))
1766 else if (GC_SUBRP (obj
))
1768 else if (GC_COMPILEDP (obj
))
1769 /* We could treat this just like a vector, but it is better
1770 to save the COMPILED_CONSTANTS element for last and avoid recursion
1773 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1774 register EMACS_INT size
= ptr
->size
;
1775 /* See comment above under Lisp_Vector. */
1776 struct Lisp_Vector
*volatile ptr1
= ptr
;
1779 if (size
& ARRAY_MARK_FLAG
)
1780 break; /* Already marked */
1781 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1782 size
&= PSEUDOVECTOR_SIZE_MASK
;
1783 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1785 if (i
!= COMPILED_CONSTANTS
)
1786 mark_object (&ptr1
->contents
[i
]);
1788 /* This cast should be unnecessary, but some Mips compiler complains
1789 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1790 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1794 else if (GC_FRAMEP (obj
))
1796 /* See comment above under Lisp_Vector for why this is volatile. */
1797 register struct frame
*volatile ptr
= XFRAME (obj
);
1798 register EMACS_INT size
= ptr
->size
;
1800 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1801 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1803 mark_object (&ptr
->name
);
1804 mark_object (&ptr
->icon_name
);
1805 mark_object (&ptr
->focus_frame
);
1806 mark_object (&ptr
->selected_window
);
1807 mark_object (&ptr
->minibuffer_window
);
1808 mark_object (&ptr
->param_alist
);
1809 mark_object (&ptr
->scroll_bars
);
1810 mark_object (&ptr
->condemned_scroll_bars
);
1811 mark_object (&ptr
->menu_bar_items
);
1812 mark_object (&ptr
->face_alist
);
1813 mark_object (&ptr
->menu_bar_vector
);
1814 mark_object (&ptr
->buffer_predicate
);
1816 #endif /* MULTI_FRAME */
1817 else if (GC_BOOL_VECTOR_P (obj
))
1821 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1822 register EMACS_INT size
= ptr
->size
;
1823 /* The reason we use ptr1 is to avoid an apparent hardware bug
1824 that happens occasionally on the FSF's HP 300s.
1825 The bug is that a2 gets clobbered by recursive calls to mark_object.
1826 The clobberage seems to happen during function entry,
1827 perhaps in the moveml instruction.
1828 Yes, this is a crock, but we have to do it. */
1829 struct Lisp_Vector
*volatile ptr1
= ptr
;
1832 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1833 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1834 if (size
& PSEUDOVECTOR_FLAG
)
1835 size
&= PSEUDOVECTOR_SIZE_MASK
;
1836 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1837 mark_object (&ptr1
->contents
[i
]);
1843 /* See comment above under Lisp_Vector for why this is volatile. */
1844 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1845 struct Lisp_Symbol
*ptrx
;
1847 if (XMARKBIT (ptr
->plist
)) break;
1849 mark_object ((Lisp_Object
*) &ptr
->value
);
1850 mark_object (&ptr
->function
);
1851 mark_object (&ptr
->plist
);
1852 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1853 mark_object (&ptr
->name
);
1857 /* For the benefit of the last_marked log. */
1858 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1859 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1860 XSETSYMBOL (obj
, ptrx
);
1861 /* We can't goto loop here because *objptr doesn't contain an
1862 actual Lisp_Object with valid datatype field. */
1869 switch (XMISCTYPE (obj
))
1871 case Lisp_Misc_Marker
:
1872 XMARK (XMARKER (obj
)->chain
);
1873 /* DO NOT mark thru the marker's chain.
1874 The buffer's markers chain does not preserve markers from gc;
1875 instead, markers are removed from the chain when freed by gc. */
1878 case Lisp_Misc_Buffer_Local_Value
:
1879 case Lisp_Misc_Some_Buffer_Local_Value
:
1881 register struct Lisp_Buffer_Local_Value
*ptr
1882 = XBUFFER_LOCAL_VALUE (obj
);
1883 if (XMARKBIT (ptr
->car
)) break;
1885 /* If the cdr is nil, avoid recursion for the car. */
1886 if (EQ (ptr
->cdr
, Qnil
))
1891 mark_object (&ptr
->car
);
1892 /* See comment above under Lisp_Vector for why not use ptr here. */
1893 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1897 case Lisp_Misc_Intfwd
:
1898 case Lisp_Misc_Boolfwd
:
1899 case Lisp_Misc_Objfwd
:
1900 case Lisp_Misc_Buffer_Objfwd
:
1901 case Lisp_Misc_Kboard_Objfwd
:
1902 /* Don't bother with Lisp_Buffer_Objfwd,
1903 since all markable slots in current buffer marked anyway. */
1904 /* Don't need to do Lisp_Objfwd, since the places they point
1905 are protected with staticpro. */
1908 case Lisp_Misc_Overlay
:
1910 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1911 if (!XMARKBIT (ptr
->plist
))
1914 mark_object (&ptr
->start
);
1915 mark_object (&ptr
->end
);
1916 objptr
= &ptr
->plist
;
1929 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1930 if (XMARKBIT (ptr
->car
)) break;
1932 /* If the cdr is nil, avoid recursion for the car. */
1933 if (EQ (ptr
->cdr
, Qnil
))
1938 mark_object (&ptr
->car
);
1939 /* See comment above under Lisp_Vector for why not use ptr here. */
1940 objptr
= &XCONS (obj
)->cdr
;
1944 #ifdef LISP_FLOAT_TYPE
1946 XMARK (XFLOAT (obj
)->type
);
1948 #endif /* LISP_FLOAT_TYPE */
1958 /* Mark the pointers in a buffer structure. */
1964 register struct buffer
*buffer
= XBUFFER (buf
);
1965 register Lisp_Object
*ptr
;
1966 Lisp_Object base_buffer
;
1968 /* This is the buffer's markbit */
1969 mark_object (&buffer
->name
);
1970 XMARK (buffer
->name
);
1972 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1975 mark_object (buffer
->syntax_table
);
1977 /* Mark the various string-pointers in the buffer object.
1978 Since the strings may be relocated, we must mark them
1979 in their actual slots. So gc_sweep must convert each slot
1980 back to an ordinary C pointer. */
1981 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1982 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1983 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1984 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1986 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1987 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1988 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1989 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1992 for (ptr
= &buffer
->name
+ 1;
1993 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1997 /* If this is an indirect buffer, mark its base buffer. */
1998 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2000 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2001 mark_buffer (base_buffer
);
2006 /* Mark the pointers in the kboard objects. */
2013 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2015 if (kb
->kbd_macro_buffer
)
2016 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2018 mark_object (&kb
->Vprefix_arg
);
2019 mark_object (&kb
->kbd_queue
);
2020 mark_object (&kb
->Vlast_kbd_macro
);
2021 mark_object (&kb
->Vsystem_key_alist
);
2022 mark_object (&kb
->system_key_syms
);
2026 /* Sweep: find all structures not marked, and free them. */
2031 total_string_size
= 0;
2034 /* Put all unmarked conses on free list */
2036 register struct cons_block
*cblk
;
2037 register int lim
= cons_block_index
;
2038 register int num_free
= 0, num_used
= 0;
2042 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
2045 for (i
= 0; i
< lim
; i
++)
2046 if (!XMARKBIT (cblk
->conses
[i
].car
))
2049 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
2050 cons_free_list
= &cblk
->conses
[i
];
2055 XUNMARK (cblk
->conses
[i
].car
);
2057 lim
= CONS_BLOCK_SIZE
;
2059 total_conses
= num_used
;
2060 total_free_conses
= num_free
;
2063 #ifdef LISP_FLOAT_TYPE
2064 /* Put all unmarked floats on free list */
2066 register struct float_block
*fblk
;
2067 register int lim
= float_block_index
;
2068 register int num_free
= 0, num_used
= 0;
2070 float_free_list
= 0;
2072 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2075 for (i
= 0; i
< lim
; i
++)
2076 if (!XMARKBIT (fblk
->floats
[i
].type
))
2079 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2080 float_free_list
= &fblk
->floats
[i
];
2085 XUNMARK (fblk
->floats
[i
].type
);
2087 lim
= FLOAT_BLOCK_SIZE
;
2089 total_floats
= num_used
;
2090 total_free_floats
= num_free
;
2092 #endif /* LISP_FLOAT_TYPE */
2094 #ifdef USE_TEXT_PROPERTIES
2095 /* Put all unmarked intervals on free list */
2097 register struct interval_block
*iblk
;
2098 register int lim
= interval_block_index
;
2099 register int num_free
= 0, num_used
= 0;
2101 interval_free_list
= 0;
2103 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2107 for (i
= 0; i
< lim
; i
++)
2109 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2111 iblk
->intervals
[i
].parent
= interval_free_list
;
2112 interval_free_list
= &iblk
->intervals
[i
];
2118 XUNMARK (iblk
->intervals
[i
].plist
);
2121 lim
= INTERVAL_BLOCK_SIZE
;
2123 total_intervals
= num_used
;
2124 total_free_intervals
= num_free
;
2126 #endif /* USE_TEXT_PROPERTIES */
2128 /* Put all unmarked symbols on free list */
2130 register struct symbol_block
*sblk
;
2131 register int lim
= symbol_block_index
;
2132 register int num_free
= 0, num_used
= 0;
2134 symbol_free_list
= 0;
2136 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2139 for (i
= 0; i
< lim
; i
++)
2140 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2142 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2143 symbol_free_list
= &sblk
->symbols
[i
];
2149 sblk
->symbols
[i
].name
2150 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2151 XUNMARK (sblk
->symbols
[i
].plist
);
2153 lim
= SYMBOL_BLOCK_SIZE
;
2155 total_symbols
= num_used
;
2156 total_free_symbols
= num_free
;
2160 /* Put all unmarked markers on free list.
2161 Unchain each one first from the buffer it points into,
2162 but only if it's a real marker. */
2164 register struct marker_block
*mblk
;
2165 register int lim
= marker_block_index
;
2166 register int num_free
= 0, num_used
= 0;
2168 marker_free_list
= 0;
2170 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2173 EMACS_INT already_free
= -1;
2175 for (i
= 0; i
< lim
; i
++)
2177 Lisp_Object
*markword
;
2178 switch (mblk
->markers
[i
].u_marker
.type
)
2180 case Lisp_Misc_Marker
:
2181 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2183 case Lisp_Misc_Buffer_Local_Value
:
2184 case Lisp_Misc_Some_Buffer_Local_Value
:
2185 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2187 case Lisp_Misc_Overlay
:
2188 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2190 case Lisp_Misc_Free
:
2191 /* If the object was already free, keep it
2192 on the free list. */
2193 markword
= &already_free
;
2199 if (markword
&& !XMARKBIT (*markword
))
2202 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2204 /* tem1 avoids Sun compiler bug */
2205 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2206 XSETMARKER (tem
, tem1
);
2207 unchain_marker (tem
);
2209 /* Set the type of the freed object to Lisp_Misc_Free.
2210 We could leave the type alone, since nobody checks it,
2211 but this might catch bugs faster. */
2212 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2213 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2214 marker_free_list
= &mblk
->markers
[i
];
2221 XUNMARK (*markword
);
2224 lim
= MARKER_BLOCK_SIZE
;
2227 total_markers
= num_used
;
2228 total_free_markers
= num_free
;
2231 /* Free all unmarked buffers */
2233 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2236 if (!XMARKBIT (buffer
->name
))
2239 prev
->next
= buffer
->next
;
2241 all_buffers
= buffer
->next
;
2242 next
= buffer
->next
;
2248 XUNMARK (buffer
->name
);
2249 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2252 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2253 for purposes of marking and relocation.
2254 Turn them back into C pointers now. */
2255 buffer
->upcase_table
2256 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2257 buffer
->downcase_table
2258 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2260 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2261 buffer
->folding_sort_table
2262 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2265 prev
= buffer
, buffer
= buffer
->next
;
2269 #endif /* standalone */
2271 /* Free all unmarked vectors */
2273 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2274 total_vector_size
= 0;
2277 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2280 prev
->next
= vector
->next
;
2282 all_vectors
= vector
->next
;
2283 next
= vector
->next
;
2289 vector
->size
&= ~ARRAY_MARK_FLAG
;
2290 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2291 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2293 total_vector_size
+= vector
->size
;
2294 prev
= vector
, vector
= vector
->next
;
2298 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2300 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2301 struct Lisp_String
*s
;
2305 s
= (struct Lisp_String
*) &sb
->chars
[0];
2306 if (s
->size
& ARRAY_MARK_FLAG
)
2308 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2309 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2310 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2311 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2312 prev
= sb
, sb
= sb
->next
;
2317 prev
->next
= sb
->next
;
2319 large_string_blocks
= sb
->next
;
2328 /* Compactify strings, relocate references, and free empty string blocks. */
2333 /* String block of old strings we are scanning. */
2334 register struct string_block
*from_sb
;
2335 /* A preceding string block (or maybe the same one)
2336 where we are copying the still-live strings to. */
2337 register struct string_block
*to_sb
;
2341 to_sb
= first_string_block
;
2344 /* Scan each existing string block sequentially, string by string. */
2345 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2348 /* POS is the index of the next string in the block. */
2349 while (pos
< from_sb
->pos
)
2351 register struct Lisp_String
*nextstr
2352 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2354 register struct Lisp_String
*newaddr
;
2355 register EMACS_INT size
= nextstr
->size
;
2357 /* NEXTSTR is the old address of the next string.
2358 Just skip it if it isn't marked. */
2359 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2361 /* It is marked, so its size field is really a chain of refs.
2362 Find the end of the chain, where the actual size lives. */
2363 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2365 if (size
& DONT_COPY_FLAG
)
2366 size
^= MARKBIT
| DONT_COPY_FLAG
;
2367 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2370 total_string_size
+= size
;
2372 /* If it won't fit in TO_SB, close it out,
2373 and move to the next sb. Keep doing so until
2374 TO_SB reaches a large enough, empty enough string block.
2375 We know that TO_SB cannot advance past FROM_SB here
2376 since FROM_SB is large enough to contain this string.
2377 Any string blocks skipped here
2378 will be patched out and freed later. */
2379 while (to_pos
+ STRING_FULLSIZE (size
)
2380 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2382 to_sb
->pos
= to_pos
;
2383 to_sb
= to_sb
->next
;
2386 /* Compute new address of this string
2387 and update TO_POS for the space being used. */
2388 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2389 to_pos
+= STRING_FULLSIZE (size
);
2391 /* Copy the string itself to the new place. */
2392 if (nextstr
!= newaddr
)
2393 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2394 + INTERVAL_PTR_SIZE
);
2396 /* Go through NEXTSTR's chain of references
2397 and make each slot in the chain point to
2398 the new address of this string. */
2399 size
= newaddr
->size
;
2400 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2402 register Lisp_Object
*objptr
;
2403 if (size
& DONT_COPY_FLAG
)
2404 size
^= MARKBIT
| DONT_COPY_FLAG
;
2405 objptr
= (Lisp_Object
*)size
;
2407 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2408 if (XMARKBIT (*objptr
))
2410 XSETSTRING (*objptr
, newaddr
);
2414 XSETSTRING (*objptr
, newaddr
);
2416 /* Store the actual size in the size field. */
2417 newaddr
->size
= size
;
2419 #ifdef USE_TEXT_PROPERTIES
2420 /* Now that the string has been relocated, rebalance its
2421 interval tree, and update the tree's parent pointer. */
2422 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2424 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2425 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2428 #endif /* USE_TEXT_PROPERTIES */
2430 pos
+= STRING_FULLSIZE (size
);
2434 /* Close out the last string block still used and free any that follow. */
2435 to_sb
->pos
= to_pos
;
2436 current_string_block
= to_sb
;
2438 from_sb
= to_sb
->next
;
2442 to_sb
= from_sb
->next
;
2447 /* Free any empty string blocks further back in the chain.
2448 This loop will never free first_string_block, but it is very
2449 unlikely that that one will become empty, so why bother checking? */
2451 from_sb
= first_string_block
;
2452 while (to_sb
= from_sb
->next
)
2454 if (to_sb
->pos
== 0)
2456 if (from_sb
->next
= to_sb
->next
)
2457 from_sb
->next
->prev
= from_sb
;
2465 /* Debugging aids. */
2467 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2468 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2469 This may be helpful in debugging Emacs's memory usage.\n\
2470 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2475 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2480 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2481 "Return a list of counters that measure how much consing there has been.\n\
2482 Each of these counters increments for a certain kind of object.\n\
2483 The counters wrap around from the largest positive integer to zero.\n\
2484 Garbage collection does not decrease them.\n\
2485 The elements of the value are as follows:\n\
2486 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2487 All are in units of 1 = one object consed\n\
2488 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2490 MISCS include overlays, markers, and some internal types.\n\
2491 Frames, windows, buffers, and subprocesses count as vectors\n\
2492 (but the contents of a buffer's text do not count here).")
2495 Lisp_Object lisp_cons_cells_consed
;
2496 Lisp_Object lisp_floats_consed
;
2497 Lisp_Object lisp_vector_cells_consed
;
2498 Lisp_Object lisp_symbols_consed
;
2499 Lisp_Object lisp_string_chars_consed
;
2500 Lisp_Object lisp_misc_objects_consed
;
2501 Lisp_Object lisp_intervals_consed
;
2503 XSETINT (lisp_cons_cells_consed
,
2504 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2505 XSETINT (lisp_floats_consed
,
2506 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2507 XSETINT (lisp_vector_cells_consed
,
2508 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2509 XSETINT (lisp_symbols_consed
,
2510 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2511 XSETINT (lisp_string_chars_consed
,
2512 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2513 XSETINT (lisp_misc_objects_consed
,
2514 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2515 XSETINT (lisp_intervals_consed
,
2516 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2518 return Fcons (lisp_cons_cells_consed
,
2519 Fcons (lisp_floats_consed
,
2520 Fcons (lisp_vector_cells_consed
,
2521 Fcons (lisp_symbols_consed
,
2522 Fcons (lisp_string_chars_consed
,
2523 Fcons (lisp_misc_objects_consed
,
2524 Fcons (lisp_intervals_consed
,
2528 /* Initialization */
2532 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2535 pure_size
= PURESIZE
;
2538 ignore_warnings
= 1;
2543 #ifdef LISP_FLOAT_TYPE
2545 #endif /* LISP_FLOAT_TYPE */
2549 malloc_hysteresis
= 32;
2551 malloc_hysteresis
= 0;
2554 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2556 ignore_warnings
= 0;
2559 consing_since_gc
= 0;
2560 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2561 #ifdef VIRT_ADDR_VARIES
2562 malloc_sbrk_unused
= 1<<22; /* A large number */
2563 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2564 #endif /* VIRT_ADDR_VARIES */
2575 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2576 "*Number of bytes of consing between garbage collections.\n\
2577 Garbage collection can happen automatically once this many bytes have been\n\
2578 allocated since the last garbage collection. All data types count.\n\n\
2579 Garbage collection happens automatically only when `eval' is called.\n\n\
2580 By binding this temporarily to a large number, you can effectively\n\
2581 prevent garbage collection during a part of the program.");
2583 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2584 "Number of bytes of sharable Lisp data allocated so far.");
2587 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2588 "Number of bytes of unshared memory allocated in this session.");
2590 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2591 "Number of bytes of unshared memory remaining available in this session.");
2594 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2595 "Non-nil means loading Lisp code in order to dump an executable.\n\
2596 This means that certain objects should be allocated in shared (pure) space.");
2598 DEFVAR_INT ("undo-limit", &undo_limit
,
2599 "Keep no more undo information once it exceeds this size.\n\
2600 This limit is applied when garbage collection happens.\n\
2601 The size is counted as the number of bytes occupied,\n\
2602 which includes both saved text and other data.");
2605 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2606 "Don't keep more than this much size of undo information.\n\
2607 A command which pushes past this size is itself forgotten.\n\
2608 This limit is applied when garbage collection happens.\n\
2609 The size is counted as the number of bytes occupied,\n\
2610 which includes both saved text and other data.");
2611 undo_strong_limit
= 30000;
2613 /* We build this in advance because if we wait until we need it, we might
2614 not be able to allocate the memory to hold it. */
2616 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2617 staticpro (&memory_signal_data
);
2619 staticpro (&Qgc_cons_threshold
);
2620 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2622 staticpro (&Qchar_table_extra_slots
);
2623 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2628 defsubr (&Smake_byte_code
);
2629 defsubr (&Smake_list
);
2630 defsubr (&Smake_vector
);
2631 defsubr (&Smake_char_table
);
2632 defsubr (&Smake_string
);
2633 defsubr (&Smake_bool_vector
);
2634 defsubr (&Smake_symbol
);
2635 defsubr (&Smake_marker
);
2636 defsubr (&Spurecopy
);
2637 defsubr (&Sgarbage_collect
);
2638 defsubr (&Smemory_limit
);
2639 defsubr (&Smemory_use_counts
);