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. */
20 /* Note that this declares bzero on OSF/1. How dumb. */
25 #include "intervals.h"
31 #include "blockinput.h"
35 #include "syssignal.h"
39 /* The following come from gmalloc.c. */
41 #if defined (__STDC__) && __STDC__
43 #define __malloc_size_t size_t
45 #define __malloc_size_t unsigned int
47 extern __malloc_size_t _bytes_used
;
48 extern int __malloc_extra_blocks
;
50 #define max(A,B) ((A) > (B) ? (A) : (B))
51 #define min(A,B) ((A) < (B) ? (A) : (B))
53 /* Macro to verify that storage intended for Lisp objects is not
54 out of range to fit in the space for a pointer.
55 ADDRESS is the start of the block, and SIZE
56 is the amount of space within which objects can start. */
57 #define VALIDATE_LISP_STORAGE(address, size) \
61 XSETCONS (val, (char *) address + size); \
62 if ((char *) XCONS (val) != (char *) address + size) \
69 /* Value of _bytes_used, when spare_memory was freed. */
70 static __malloc_size_t bytes_used_when_full
;
72 /* Number of bytes of consing done since the last gc */
75 /* Count the amount of consing of various sorts of space. */
76 int cons_cells_consed
;
78 int vector_cells_consed
;
80 int string_chars_consed
;
81 int misc_objects_consed
;
84 /* Number of bytes of consing since gc before another gc should be done. */
85 int gc_cons_threshold
;
87 /* Nonzero during gc */
90 #ifndef VIRT_ADDR_VARIES
92 #endif /* VIRT_ADDR_VARIES */
95 #ifndef VIRT_ADDR_VARIES
97 #endif /* VIRT_ADDR_VARIES */
98 int malloc_sbrk_unused
;
100 /* Two limits controlling how much undo information to keep. */
102 int undo_strong_limit
;
104 /* Points to memory space allocated as "spare",
105 to be freed if we run out of memory. */
106 static char *spare_memory
;
108 /* Amount of spare memory to keep in reserve. */
109 #define SPARE_MEMORY (1 << 14)
111 /* Number of extra blocks malloc should get when it needs more core. */
112 static int malloc_hysteresis
;
114 /* Nonzero when malloc is called for allocating Lisp object space. */
115 int allocating_for_lisp
;
117 /* Non-nil means defun should do purecopy on the function definition */
118 Lisp_Object Vpurify_flag
;
121 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
122 #define PUREBEG (char *) pure
124 #define pure PURE_SEG_BITS /* Use shared memory segment */
125 #define PUREBEG (char *)PURE_SEG_BITS
127 /* This variable is used only by the XPNTR macro when HAVE_SHM is
128 defined. If we used the PURESIZE macro directly there, that would
129 make most of emacs dependent on puresize.h, which we don't want -
130 you should be able to change that without too much recompilation.
131 So map_in_data initializes pure_size, and the dependencies work
134 #endif /* not HAVE_SHM */
136 /* Index in pure at which next pure object will be allocated. */
139 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
140 char *pending_malloc_warning
;
142 /* Pre-computed signal argument for use when memory is exhausted. */
143 Lisp_Object memory_signal_data
;
145 /* Maximum amount of C stack to save when a GC happens. */
147 #ifndef MAX_SAVE_STACK
148 #define MAX_SAVE_STACK 16000
151 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
152 pointer to a Lisp_Object, when that pointer is viewed as an integer.
153 (On most machines, pointers are even, so we can use the low bit.
154 Word-addressible architectures may need to override this in the m-file.)
155 When linking references to small strings through the size field, we
156 use this slot to hold the bit that would otherwise be interpreted as
158 #ifndef DONT_COPY_FLAG
159 #define DONT_COPY_FLAG 1
160 #endif /* no DONT_COPY_FLAG */
162 /* Buffer in which we save a copy of the C stack at each GC. */
167 /* Non-zero means ignore malloc warnings. Set during initialization. */
170 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
172 static void mark_object (), mark_buffer (), mark_kboards ();
173 static void clear_marks (), gc_sweep ();
174 static void compact_strings ();
176 /* Versions of malloc and realloc that print warnings as memory gets full. */
179 malloc_warning_1 (str
)
182 Fprinc (str
, Vstandard_output
);
183 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
184 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
185 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
189 /* malloc calls this if it finds we are near exhausting storage */
193 pending_malloc_warning
= str
;
196 display_malloc_warning ()
198 register Lisp_Object val
;
200 val
= build_string (pending_malloc_warning
);
201 pending_malloc_warning
= 0;
202 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
205 /* Called if malloc returns zero */
209 #ifndef SYSTEM_MALLOC
210 bytes_used_when_full
= _bytes_used
;
213 /* The first time we get here, free the spare memory. */
220 /* This used to call error, but if we've run out of memory, we could get
221 infinite recursion trying to build the string. */
223 Fsignal (Qerror
, memory_signal_data
);
226 /* Called if we can't allocate relocatable space for a buffer. */
229 buffer_memory_full ()
231 /* If buffers use the relocating allocator,
232 no need to free spare_memory, because we may have plenty of malloc
233 space left that we could get, and if we don't, the malloc that fails
234 will itself cause spare_memory to be freed.
235 If buffers don't use the relocating allocator,
236 treat this like any other failing malloc. */
242 /* This used to call error, but if we've run out of memory, we could get
243 infinite recursion trying to build the string. */
245 Fsignal (Qerror
, memory_signal_data
);
248 /* like malloc routines but check for no memory and block interrupt input. */
257 val
= (long *) malloc (size
);
260 if (!val
&& size
) memory_full ();
265 xrealloc (block
, size
)
272 /* We must call malloc explicitly when BLOCK is 0, since some
273 reallocs don't do this. */
275 val
= (long *) malloc (size
);
277 val
= (long *) realloc (block
, size
);
280 if (!val
&& size
) memory_full ();
294 /* Arranging to disable input signals while we're in malloc.
296 This only works with GNU malloc. To help out systems which can't
297 use GNU malloc, all the calls to malloc, realloc, and free
298 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
299 pairs; unfortunately, we have no idea what C library functions
300 might call malloc, so we can't really protect them unless you're
301 using GNU malloc. Fortunately, most of the major operating can use
304 #ifndef SYSTEM_MALLOC
305 extern void * (*__malloc_hook
) ();
306 static void * (*old_malloc_hook
) ();
307 extern void * (*__realloc_hook
) ();
308 static void * (*old_realloc_hook
) ();
309 extern void (*__free_hook
) ();
310 static void (*old_free_hook
) ();
312 /* This function is used as the hook for free to call. */
315 emacs_blocked_free (ptr
)
319 __free_hook
= old_free_hook
;
321 /* If we released our reserve (due to running out of memory),
322 and we have a fair amount free once again,
323 try to set aside another reserve in case we run out once more. */
324 if (spare_memory
== 0
325 /* Verify there is enough space that even with the malloc
326 hysteresis this call won't run out again.
327 The code here is correct as long as SPARE_MEMORY
328 is substantially larger than the block size malloc uses. */
329 && (bytes_used_when_full
330 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
331 spare_memory
= (char *) malloc (SPARE_MEMORY
);
333 __free_hook
= emacs_blocked_free
;
337 /* If we released our reserve (due to running out of memory),
338 and we have a fair amount free once again,
339 try to set aside another reserve in case we run out once more.
341 This is called when a relocatable block is freed in ralloc.c. */
344 refill_memory_reserve ()
346 if (spare_memory
== 0)
347 spare_memory
= (char *) malloc (SPARE_MEMORY
);
350 /* This function is the malloc hook that Emacs uses. */
353 emacs_blocked_malloc (size
)
359 __malloc_hook
= old_malloc_hook
;
360 __malloc_extra_blocks
= malloc_hysteresis
;
361 value
= (void *) malloc (size
);
362 __malloc_hook
= emacs_blocked_malloc
;
369 emacs_blocked_realloc (ptr
, size
)
376 __realloc_hook
= old_realloc_hook
;
377 value
= (void *) realloc (ptr
, size
);
378 __realloc_hook
= emacs_blocked_realloc
;
385 uninterrupt_malloc ()
387 old_free_hook
= __free_hook
;
388 __free_hook
= emacs_blocked_free
;
390 old_malloc_hook
= __malloc_hook
;
391 __malloc_hook
= emacs_blocked_malloc
;
393 old_realloc_hook
= __realloc_hook
;
394 __realloc_hook
= emacs_blocked_realloc
;
398 /* Interval allocation. */
400 #ifdef USE_TEXT_PROPERTIES
401 #define INTERVAL_BLOCK_SIZE \
402 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
404 struct interval_block
406 struct interval_block
*next
;
407 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
410 struct interval_block
*interval_block
;
411 static int interval_block_index
;
413 INTERVAL interval_free_list
;
418 allocating_for_lisp
= 1;
420 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
421 allocating_for_lisp
= 0;
422 interval_block
->next
= 0;
423 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
424 interval_block_index
= 0;
425 interval_free_list
= 0;
428 #define INIT_INTERVALS init_intervals ()
435 if (interval_free_list
)
437 val
= interval_free_list
;
438 interval_free_list
= interval_free_list
->parent
;
442 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
444 register struct interval_block
*newi
;
446 allocating_for_lisp
= 1;
447 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
449 allocating_for_lisp
= 0;
450 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
451 newi
->next
= interval_block
;
452 interval_block
= newi
;
453 interval_block_index
= 0;
455 val
= &interval_block
->intervals
[interval_block_index
++];
457 consing_since_gc
+= sizeof (struct interval
);
459 RESET_INTERVAL (val
);
463 static int total_free_intervals
, total_intervals
;
465 /* Mark the pointers of one interval. */
468 mark_interval (i
, dummy
)
472 if (XMARKBIT (i
->plist
))
474 mark_object (&i
->plist
);
479 mark_interval_tree (tree
)
480 register INTERVAL tree
;
482 /* No need to test if this tree has been marked already; this
483 function is always called through the MARK_INTERVAL_TREE macro,
484 which takes care of that. */
486 /* XMARK expands to an assignment; the LHS of an assignment can't be
488 XMARK (* (Lisp_Object
*) &tree
->parent
);
490 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
493 #define MARK_INTERVAL_TREE(i) \
495 if (!NULL_INTERVAL_P (i) \
496 && ! XMARKBIT ((Lisp_Object) i->parent)) \
497 mark_interval_tree (i); \
500 /* The oddity in the call to XUNMARK is necessary because XUNMARK
501 expands to an assignment to its argument, and most C compilers don't
502 support casts on the left operand of `='. */
503 #define UNMARK_BALANCE_INTERVALS(i) \
505 if (! NULL_INTERVAL_P (i)) \
507 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
508 (i) = balance_intervals (i); \
512 #else /* no interval use */
514 #define INIT_INTERVALS
516 #define UNMARK_BALANCE_INTERVALS(i)
517 #define MARK_INTERVAL_TREE(i)
519 #endif /* no interval use */
521 /* Floating point allocation. */
523 #ifdef LISP_FLOAT_TYPE
524 /* Allocation of float cells, just like conses */
525 /* We store float cells inside of float_blocks, allocating a new
526 float_block with malloc whenever necessary. Float cells reclaimed by
527 GC are put on a free list to be reallocated before allocating
528 any new float cells from the latest float_block.
530 Each float_block is just under 1020 bytes long,
531 since malloc really allocates in units of powers of two
532 and uses 4 bytes for its own overhead. */
534 #define FLOAT_BLOCK_SIZE \
535 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
539 struct float_block
*next
;
540 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
543 struct float_block
*float_block
;
544 int float_block_index
;
546 struct Lisp_Float
*float_free_list
;
551 allocating_for_lisp
= 1;
552 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
553 allocating_for_lisp
= 0;
554 float_block
->next
= 0;
555 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
556 float_block_index
= 0;
560 /* Explicitly free a float cell. */
562 struct Lisp_Float
*ptr
;
564 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
565 float_free_list
= ptr
;
569 make_float (float_value
)
572 register Lisp_Object val
;
576 XSETFLOAT (val
, float_free_list
);
577 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
581 if (float_block_index
== FLOAT_BLOCK_SIZE
)
583 register struct float_block
*new;
585 allocating_for_lisp
= 1;
586 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
587 allocating_for_lisp
= 0;
588 VALIDATE_LISP_STORAGE (new, sizeof *new);
589 new->next
= float_block
;
591 float_block_index
= 0;
593 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
595 XFLOAT (val
)->data
= float_value
;
596 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
597 consing_since_gc
+= sizeof (struct Lisp_Float
);
602 #endif /* LISP_FLOAT_TYPE */
604 /* Allocation of cons cells */
605 /* We store cons cells inside of cons_blocks, allocating a new
606 cons_block with malloc whenever necessary. Cons cells reclaimed by
607 GC are put on a free list to be reallocated before allocating
608 any new cons cells from the latest cons_block.
610 Each cons_block is just under 1020 bytes long,
611 since malloc really allocates in units of powers of two
612 and uses 4 bytes for its own overhead. */
614 #define CONS_BLOCK_SIZE \
615 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
619 struct cons_block
*next
;
620 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
623 struct cons_block
*cons_block
;
624 int cons_block_index
;
626 struct Lisp_Cons
*cons_free_list
;
631 allocating_for_lisp
= 1;
632 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
633 allocating_for_lisp
= 0;
634 cons_block
->next
= 0;
635 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
636 cons_block_index
= 0;
640 /* Explicitly free a cons cell. */
642 struct Lisp_Cons
*ptr
;
644 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
645 cons_free_list
= ptr
;
648 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
649 "Create a new cons, give it CAR and CDR as components, and return it.")
651 Lisp_Object car
, cdr
;
653 register Lisp_Object val
;
657 XSETCONS (val
, cons_free_list
);
658 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
662 if (cons_block_index
== CONS_BLOCK_SIZE
)
664 register struct cons_block
*new;
665 allocating_for_lisp
= 1;
666 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
667 allocating_for_lisp
= 0;
668 VALIDATE_LISP_STORAGE (new, sizeof *new);
669 new->next
= cons_block
;
671 cons_block_index
= 0;
673 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
675 XCONS (val
)->car
= car
;
676 XCONS (val
)->cdr
= cdr
;
677 consing_since_gc
+= sizeof (struct Lisp_Cons
);
682 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
683 "Return a newly created list with specified arguments as elements.\n\
684 Any number of arguments, even zero arguments, are allowed.")
687 register Lisp_Object
*args
;
689 register Lisp_Object val
;
695 val
= Fcons (args
[nargs
], val
);
700 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
701 "Return a newly created list of length LENGTH, with each element being INIT.")
703 register Lisp_Object length
, init
;
705 register Lisp_Object val
;
708 CHECK_NATNUM (length
, 0);
709 size
= XFASTINT (length
);
713 val
= Fcons (init
, val
);
717 /* Allocation of vectors */
719 struct Lisp_Vector
*all_vectors
;
722 allocate_vectorlike (len
)
725 struct Lisp_Vector
*p
;
727 allocating_for_lisp
= 1;
728 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
729 + (len
- 1) * sizeof (Lisp_Object
));
730 allocating_for_lisp
= 0;
731 VALIDATE_LISP_STORAGE (p
, 0);
732 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
733 + (len
- 1) * sizeof (Lisp_Object
));
734 vector_cells_consed
+= len
;
736 p
->next
= all_vectors
;
741 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
742 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
743 See also the function `vector'.")
745 register Lisp_Object length
, init
;
748 register EMACS_INT sizei
;
750 register struct Lisp_Vector
*p
;
752 CHECK_NATNUM (length
, 0);
753 sizei
= XFASTINT (length
);
755 p
= allocate_vectorlike (sizei
);
757 for (index
= 0; index
< sizei
; index
++)
758 p
->contents
[index
] = init
;
760 XSETVECTOR (vector
, p
);
764 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
765 "Return a newly created char-table, with purpose PURPOSE.\n\
766 Each element is initialized to INIT, which defaults to nil.\n\
767 PURPOSE should be a symbol which has a `char-table-extra-slot' property.\n\
768 The property's value should be an integer between 0 and 10.")
770 register Lisp_Object purpose
, init
;
774 CHECK_SYMBOL (purpose
, 1);
775 n
= Fget (purpose
, Qchar_table_extra_slots
);
777 if (XINT (n
) < 0 || XINT (n
) > 10)
778 args_out_of_range (n
, Qnil
);
779 /* Add 2 to the size for the defalt and parent slots. */
780 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
782 XCHAR_TABLE (vector
)->parent
= Qnil
;
783 XCHAR_TABLE (vector
)->purpose
= purpose
;
784 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
788 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
789 "Return a newly created vector with specified arguments as elements.\n\
790 Any number of arguments, even zero arguments, are allowed.")
795 register Lisp_Object len
, val
;
797 register struct Lisp_Vector
*p
;
799 XSETFASTINT (len
, nargs
);
800 val
= Fmake_vector (len
, Qnil
);
802 for (index
= 0; index
< nargs
; index
++)
803 p
->contents
[index
] = args
[index
];
807 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
808 "Create a byte-code object with specified arguments as elements.\n\
809 The arguments should be the arglist, bytecode-string, constant vector,\n\
810 stack size, (optional) doc string, and (optional) interactive spec.\n\
811 The first four arguments are required; at most six have any\n\
817 register Lisp_Object len
, val
;
819 register struct Lisp_Vector
*p
;
821 XSETFASTINT (len
, nargs
);
822 if (!NILP (Vpurify_flag
))
823 val
= make_pure_vector (len
);
825 val
= Fmake_vector (len
, Qnil
);
827 for (index
= 0; index
< nargs
; index
++)
829 if (!NILP (Vpurify_flag
))
830 args
[index
] = Fpurecopy (args
[index
]);
831 p
->contents
[index
] = args
[index
];
833 XSETCOMPILED (val
, val
);
837 /* Allocation of symbols.
838 Just like allocation of conses!
840 Each symbol_block is just under 1020 bytes long,
841 since malloc really allocates in units of powers of two
842 and uses 4 bytes for its own overhead. */
844 #define SYMBOL_BLOCK_SIZE \
845 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
849 struct symbol_block
*next
;
850 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
853 struct symbol_block
*symbol_block
;
854 int symbol_block_index
;
856 struct Lisp_Symbol
*symbol_free_list
;
861 allocating_for_lisp
= 1;
862 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
863 allocating_for_lisp
= 0;
864 symbol_block
->next
= 0;
865 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
866 symbol_block_index
= 0;
867 symbol_free_list
= 0;
870 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
871 "Return a newly allocated uninterned symbol whose name is NAME.\n\
872 Its value and function definition are void, and its property list is nil.")
876 register Lisp_Object val
;
877 register struct Lisp_Symbol
*p
;
879 CHECK_STRING (str
, 0);
881 if (symbol_free_list
)
883 XSETSYMBOL (val
, symbol_free_list
);
884 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
888 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
890 struct symbol_block
*new;
891 allocating_for_lisp
= 1;
892 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
893 allocating_for_lisp
= 0;
894 VALIDATE_LISP_STORAGE (new, sizeof *new);
895 new->next
= symbol_block
;
897 symbol_block_index
= 0;
899 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
902 p
->name
= XSTRING (str
);
905 p
->function
= Qunbound
;
907 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
912 /* Allocation of markers and other objects that share that structure.
913 Works like allocation of conses. */
915 #define MARKER_BLOCK_SIZE \
916 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
920 struct marker_block
*next
;
921 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
924 struct marker_block
*marker_block
;
925 int marker_block_index
;
927 union Lisp_Misc
*marker_free_list
;
932 allocating_for_lisp
= 1;
933 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
934 allocating_for_lisp
= 0;
935 marker_block
->next
= 0;
936 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
937 marker_block_index
= 0;
938 marker_free_list
= 0;
941 /* Return a newly allocated Lisp_Misc object, with no substructure. */
947 if (marker_free_list
)
949 XSETMISC (val
, marker_free_list
);
950 marker_free_list
= marker_free_list
->u_free
.chain
;
954 if (marker_block_index
== MARKER_BLOCK_SIZE
)
956 struct marker_block
*new;
957 allocating_for_lisp
= 1;
958 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
959 allocating_for_lisp
= 0;
960 VALIDATE_LISP_STORAGE (new, sizeof *new);
961 new->next
= marker_block
;
963 marker_block_index
= 0;
965 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
967 consing_since_gc
+= sizeof (union Lisp_Misc
);
968 misc_objects_consed
++;
972 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
973 "Return a newly allocated marker which does not point at any place.")
976 register Lisp_Object val
;
977 register struct Lisp_Marker
*p
;
979 val
= allocate_misc ();
980 XMISCTYPE (val
) = Lisp_Misc_Marker
;
985 p
->insertion_type
= 0;
989 /* Allocation of strings */
991 /* Strings reside inside of string_blocks. The entire data of the string,
992 both the size and the contents, live in part of the `chars' component of a string_block.
993 The `pos' component is the index within `chars' of the first free byte.
995 first_string_block points to the first string_block ever allocated.
996 Each block points to the next one with its `next' field.
997 The `prev' fields chain in reverse order.
998 The last one allocated is the one currently being filled.
999 current_string_block points to it.
1001 The string_blocks that hold individual large strings
1002 go in a separate chain, started by large_string_blocks. */
1005 /* String blocks contain this many useful bytes.
1006 8188 is power of 2, minus 4 for malloc overhead. */
1007 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1009 /* A string bigger than this gets its own specially-made string block
1010 if it doesn't fit in the current one. */
1011 #define STRING_BLOCK_OUTSIZE 1024
1013 struct string_block_head
1015 struct string_block
*next
, *prev
;
1021 struct string_block
*next
, *prev
;
1023 char chars
[STRING_BLOCK_SIZE
];
1026 /* This points to the string block we are now allocating strings. */
1028 struct string_block
*current_string_block
;
1030 /* This points to the oldest string block, the one that starts the chain. */
1032 struct string_block
*first_string_block
;
1034 /* Last string block in chain of those made for individual large strings. */
1036 struct string_block
*large_string_blocks
;
1038 /* If SIZE is the length of a string, this returns how many bytes
1039 the string occupies in a string_block (including padding). */
1041 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
1043 #define PAD (sizeof (EMACS_INT))
1046 #define STRING_FULLSIZE(SIZE) \
1047 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1053 allocating_for_lisp
= 1;
1054 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1055 allocating_for_lisp
= 0;
1056 first_string_block
= current_string_block
;
1057 consing_since_gc
+= sizeof (struct string_block
);
1058 current_string_block
->next
= 0;
1059 current_string_block
->prev
= 0;
1060 current_string_block
->pos
= 0;
1061 large_string_blocks
= 0;
1064 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1065 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1066 Both LENGTH and INIT must be numbers.")
1068 Lisp_Object length
, init
;
1070 register Lisp_Object val
;
1071 register unsigned char *p
, *end
, c
;
1073 CHECK_NATNUM (length
, 0);
1074 CHECK_NUMBER (init
, 1);
1075 val
= make_uninit_string (XFASTINT (length
));
1077 p
= XSTRING (val
)->data
;
1078 end
= p
+ XSTRING (val
)->size
;
1085 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1086 "Return a newly created bitstring of length LENGTH, with INIT as each element.\n\
1087 Both LENGTH and INIT must be numbers. INIT matters only in whether it is t or nil.")
1089 Lisp_Object length
, init
;
1091 register Lisp_Object val
;
1092 struct Lisp_Bool_Vector
*p
;
1094 int length_in_chars
, length_in_elts
, bits_per_value
;
1096 CHECK_NATNUM (length
, 0);
1098 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1100 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1101 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1103 val
= Fmake_vector (make_number (length_in_elts
), Qnil
);
1104 p
= XBOOL_VECTOR (val
);
1105 /* Get rid of any bits that would cause confusion. */
1107 XSETBOOL_VECTOR (val
, p
);
1108 p
->size
= XFASTINT (length
);
1110 real_init
= (NILP (init
) ? 0 : -1);
1111 for (i
= 0; i
< length_in_chars
; i
++)
1112 p
->data
[i
] = real_init
;
1118 make_string (contents
, length
)
1122 register Lisp_Object val
;
1123 val
= make_uninit_string (length
);
1124 bcopy (contents
, XSTRING (val
)->data
, length
);
1132 return make_string (str
, strlen (str
));
1136 make_uninit_string (length
)
1139 register Lisp_Object val
;
1140 register int fullsize
= STRING_FULLSIZE (length
);
1142 if (length
< 0) abort ();
1144 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1145 /* This string can fit in the current string block */
1148 ((struct Lisp_String
*)
1149 (current_string_block
->chars
+ current_string_block
->pos
)));
1150 current_string_block
->pos
+= fullsize
;
1152 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1153 /* This string gets its own string block */
1155 register struct string_block
*new;
1156 allocating_for_lisp
= 1;
1157 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1158 allocating_for_lisp
= 0;
1159 VALIDATE_LISP_STORAGE (new, 0);
1160 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1161 new->pos
= fullsize
;
1162 new->next
= large_string_blocks
;
1163 large_string_blocks
= new;
1165 ((struct Lisp_String
*)
1166 ((struct string_block_head
*)new + 1)));
1169 /* Make a new current string block and start it off with this string */
1171 register struct string_block
*new;
1172 allocating_for_lisp
= 1;
1173 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1174 allocating_for_lisp
= 0;
1175 VALIDATE_LISP_STORAGE (new, sizeof *new);
1176 consing_since_gc
+= sizeof (struct string_block
);
1177 current_string_block
->next
= new;
1178 new->prev
= current_string_block
;
1180 current_string_block
= new;
1181 new->pos
= fullsize
;
1183 (struct Lisp_String
*) current_string_block
->chars
);
1186 string_chars_consed
+= fullsize
;
1187 XSTRING (val
)->size
= length
;
1188 XSTRING (val
)->data
[length
] = 0;
1189 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1194 /* Return a newly created vector or string with specified arguments as
1195 elements. If all the arguments are characters that can fit
1196 in a string of events, make a string; otherwise, make a vector.
1198 Any number of arguments, even zero arguments, are allowed. */
1201 make_event_array (nargs
, args
)
1207 for (i
= 0; i
< nargs
; i
++)
1208 /* The things that fit in a string
1209 are characters that are in 0...127,
1210 after discarding the meta bit and all the bits above it. */
1211 if (!INTEGERP (args
[i
])
1212 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1213 return Fvector (nargs
, args
);
1215 /* Since the loop exited, we know that all the things in it are
1216 characters, so we can make a string. */
1220 result
= Fmake_string (nargs
, make_number (0));
1221 for (i
= 0; i
< nargs
; i
++)
1223 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1224 /* Move the meta bit to the right place for a string char. */
1225 if (XINT (args
[i
]) & CHAR_META
)
1226 XSTRING (result
)->data
[i
] |= 0x80;
1233 /* Pure storage management. */
1235 /* Must get an error if pure storage is full,
1236 since if it cannot hold a large string
1237 it may be able to hold conses that point to that string;
1238 then the string is not protected from gc. */
1241 make_pure_string (data
, length
)
1245 register Lisp_Object
new;
1246 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1248 if (pureptr
+ size
> PURESIZE
)
1249 error ("Pure Lisp storage exhausted");
1250 XSETSTRING (new, PUREBEG
+ pureptr
);
1251 XSTRING (new)->size
= length
;
1252 bcopy (data
, XSTRING (new)->data
, length
);
1253 XSTRING (new)->data
[length
] = 0;
1255 /* We must give strings in pure storage some kind of interval. So we
1256 give them a null one. */
1257 #if defined (USE_TEXT_PROPERTIES)
1258 XSTRING (new)->intervals
= NULL_INTERVAL
;
1260 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1261 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1266 pure_cons (car
, cdr
)
1267 Lisp_Object car
, cdr
;
1269 register Lisp_Object
new;
1271 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1272 error ("Pure Lisp storage exhausted");
1273 XSETCONS (new, PUREBEG
+ pureptr
);
1274 pureptr
+= sizeof (struct Lisp_Cons
);
1275 XCONS (new)->car
= Fpurecopy (car
);
1276 XCONS (new)->cdr
= Fpurecopy (cdr
);
1280 #ifdef LISP_FLOAT_TYPE
1283 make_pure_float (num
)
1286 register Lisp_Object
new;
1288 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1289 (double) boundary. Some architectures (like the sparc) require
1290 this, and I suspect that floats are rare enough that it's no
1291 tragedy for those that do. */
1294 char *p
= PUREBEG
+ pureptr
;
1298 alignment
= __alignof (struct Lisp_Float
);
1300 alignment
= sizeof (struct Lisp_Float
);
1303 alignment
= sizeof (struct Lisp_Float
);
1305 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1306 pureptr
= p
- PUREBEG
;
1309 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1310 error ("Pure Lisp storage exhausted");
1311 XSETFLOAT (new, PUREBEG
+ pureptr
);
1312 pureptr
+= sizeof (struct Lisp_Float
);
1313 XFLOAT (new)->data
= num
;
1314 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1318 #endif /* LISP_FLOAT_TYPE */
1321 make_pure_vector (len
)
1324 register Lisp_Object
new;
1325 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1327 if (pureptr
+ size
> PURESIZE
)
1328 error ("Pure Lisp storage exhausted");
1330 XSETVECTOR (new, PUREBEG
+ pureptr
);
1332 XVECTOR (new)->size
= len
;
1336 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1337 "Make a copy of OBJECT in pure storage.\n\
1338 Recursively copies contents of vectors and cons cells.\n\
1339 Does not copy symbols.")
1341 register Lisp_Object obj
;
1343 if (NILP (Vpurify_flag
))
1346 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1347 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1351 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1352 #ifdef LISP_FLOAT_TYPE
1353 else if (FLOATP (obj
))
1354 return make_pure_float (XFLOAT (obj
)->data
);
1355 #endif /* LISP_FLOAT_TYPE */
1356 else if (STRINGP (obj
))
1357 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1358 else if (COMPILEDP (obj
) || VECTORP (obj
))
1360 register struct Lisp_Vector
*vec
;
1361 register int i
, size
;
1363 size
= XVECTOR (obj
)->size
;
1364 if (size
& PSEUDOVECTOR_FLAG
)
1365 size
&= PSEUDOVECTOR_SIZE_MASK
;
1366 vec
= XVECTOR (make_pure_vector (size
));
1367 for (i
= 0; i
< size
; i
++)
1368 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1369 if (COMPILEDP (obj
))
1370 XSETCOMPILED (obj
, vec
);
1372 XSETVECTOR (obj
, vec
);
1375 else if (MARKERP (obj
))
1376 error ("Attempt to copy a marker to pure storage");
1381 /* Recording what needs to be marked for gc. */
1383 struct gcpro
*gcprolist
;
1385 #define NSTATICS 768
1387 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1391 /* Put an entry in staticvec, pointing at the variable whose address is given */
1394 staticpro (varaddress
)
1395 Lisp_Object
*varaddress
;
1397 staticvec
[staticidx
++] = varaddress
;
1398 if (staticidx
>= NSTATICS
)
1406 struct catchtag
*next
;
1407 /* jmp_buf jmp; /* We don't need this for GC purposes */
1412 struct backtrace
*next
;
1413 Lisp_Object
*function
;
1414 Lisp_Object
*args
; /* Points to vector of args. */
1415 int nargs
; /* length of vector */
1416 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1420 /* Garbage collection! */
1422 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1423 int total_free_conses
, total_free_markers
, total_free_symbols
;
1424 #ifdef LISP_FLOAT_TYPE
1425 int total_free_floats
, total_floats
;
1426 #endif /* LISP_FLOAT_TYPE */
1428 /* Temporarily prevent garbage collection. */
1431 inhibit_garbage_collection ()
1433 int count
= specpdl_ptr
- specpdl
;
1435 int nbits
= min (VALBITS
, BITS_PER_INT
);
1437 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1439 specbind (Qgc_cons_threshold
, number
);
1444 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1445 "Reclaim storage for Lisp objects no longer needed.\n\
1446 Returns info on amount of space in use:\n\
1447 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1448 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1449 (USED-FLOATS . FREE-FLOATS))\n\
1450 Garbage collection happens automatically if you cons more than\n\
1451 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1454 register struct gcpro
*tail
;
1455 register struct specbinding
*bind
;
1456 struct catchtag
*catch;
1457 struct handler
*handler
;
1458 register struct backtrace
*backlist
;
1459 register Lisp_Object tem
;
1460 char *omessage
= echo_area_glyphs
;
1461 int omessage_length
= echo_area_glyphs_length
;
1462 char stack_top_variable
;
1465 /* In case user calls debug_print during GC,
1466 don't let that cause a recursive GC. */
1467 consing_since_gc
= 0;
1469 /* Save a copy of the contents of the stack, for debugging. */
1470 #if MAX_SAVE_STACK > 0
1471 if (NILP (Vpurify_flag
))
1473 i
= &stack_top_variable
- stack_bottom
;
1475 if (i
< MAX_SAVE_STACK
)
1477 if (stack_copy
== 0)
1478 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1479 else if (stack_copy_size
< i
)
1480 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1483 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1484 bcopy (stack_bottom
, stack_copy
, i
);
1486 bcopy (&stack_top_variable
, stack_copy
, i
);
1490 #endif /* MAX_SAVE_STACK > 0 */
1492 if (!noninteractive
)
1493 message1_nolog ("Garbage collecting...");
1495 /* Don't keep command history around forever */
1496 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1498 XCONS (tem
)->cdr
= Qnil
;
1500 /* Likewise for undo information. */
1502 register struct buffer
*nextb
= all_buffers
;
1506 /* If a buffer's undo list is Qt, that means that undo is
1507 turned off in that buffer. Calling truncate_undo_list on
1508 Qt tends to return NULL, which effectively turns undo back on.
1509 So don't call truncate_undo_list if undo_list is Qt. */
1510 if (! EQ (nextb
->undo_list
, Qt
))
1512 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1514 nextb
= nextb
->next
;
1520 /* clear_marks (); */
1522 /* In each "large string", set the MARKBIT of the size field.
1523 That enables mark_object to recognize them. */
1525 register struct string_block
*b
;
1526 for (b
= large_string_blocks
; b
; b
= b
->next
)
1527 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1530 /* Mark all the special slots that serve as the roots of accessibility.
1532 Usually the special slots to mark are contained in particular structures.
1533 Then we know no slot is marked twice because the structures don't overlap.
1534 In some cases, the structures point to the slots to be marked.
1535 For these, we use MARKBIT to avoid double marking of the slot. */
1537 for (i
= 0; i
< staticidx
; i
++)
1538 mark_object (staticvec
[i
]);
1539 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1540 for (i
= 0; i
< tail
->nvars
; i
++)
1541 if (!XMARKBIT (tail
->var
[i
]))
1543 mark_object (&tail
->var
[i
]);
1544 XMARK (tail
->var
[i
]);
1546 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1548 mark_object (&bind
->symbol
);
1549 mark_object (&bind
->old_value
);
1551 for (catch = catchlist
; catch; catch = catch->next
)
1553 mark_object (&catch->tag
);
1554 mark_object (&catch->val
);
1556 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1558 mark_object (&handler
->handler
);
1559 mark_object (&handler
->var
);
1561 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1563 if (!XMARKBIT (*backlist
->function
))
1565 mark_object (backlist
->function
);
1566 XMARK (*backlist
->function
);
1568 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1571 i
= backlist
->nargs
- 1;
1573 if (!XMARKBIT (backlist
->args
[i
]))
1575 mark_object (&backlist
->args
[i
]);
1576 XMARK (backlist
->args
[i
]);
1583 /* Clear the mark bits that we set in certain root slots. */
1585 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1586 for (i
= 0; i
< tail
->nvars
; i
++)
1587 XUNMARK (tail
->var
[i
]);
1588 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1590 XUNMARK (*backlist
->function
);
1591 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1594 i
= backlist
->nargs
- 1;
1596 XUNMARK (backlist
->args
[i
]);
1598 XUNMARK (buffer_defaults
.name
);
1599 XUNMARK (buffer_local_symbols
.name
);
1601 /* clear_marks (); */
1604 consing_since_gc
= 0;
1605 if (gc_cons_threshold
< 10000)
1606 gc_cons_threshold
= 10000;
1608 if (omessage
|| minibuf_level
> 0)
1609 message2_nolog (omessage
, omessage_length
);
1610 else if (!noninteractive
)
1611 message1_nolog ("Garbage collecting...done");
1613 return Fcons (Fcons (make_number (total_conses
),
1614 make_number (total_free_conses
)),
1615 Fcons (Fcons (make_number (total_symbols
),
1616 make_number (total_free_symbols
)),
1617 Fcons (Fcons (make_number (total_markers
),
1618 make_number (total_free_markers
)),
1619 Fcons (make_number (total_string_size
),
1620 Fcons (make_number (total_vector_size
),
1622 #ifdef LISP_FLOAT_TYPE
1623 Fcons (Fcons (make_number (total_floats
),
1624 make_number (total_free_floats
)),
1626 #else /* not LISP_FLOAT_TYPE */
1628 #endif /* not LISP_FLOAT_TYPE */
1636 /* Clear marks on all conses */
1638 register struct cons_block
*cblk
;
1639 register int lim
= cons_block_index
;
1641 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1644 for (i
= 0; i
< lim
; i
++)
1645 XUNMARK (cblk
->conses
[i
].car
);
1646 lim
= CONS_BLOCK_SIZE
;
1649 /* Clear marks on all symbols */
1651 register struct symbol_block
*sblk
;
1652 register int lim
= symbol_block_index
;
1654 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1657 for (i
= 0; i
< lim
; i
++)
1659 XUNMARK (sblk
->symbols
[i
].plist
);
1661 lim
= SYMBOL_BLOCK_SIZE
;
1664 /* Clear marks on all markers */
1666 register struct marker_block
*sblk
;
1667 register int lim
= marker_block_index
;
1669 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1672 for (i
= 0; i
< lim
; i
++)
1673 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1674 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1675 lim
= MARKER_BLOCK_SIZE
;
1678 /* Clear mark bits on all buffers */
1680 register struct buffer
*nextb
= all_buffers
;
1684 XUNMARK (nextb
->name
);
1685 nextb
= nextb
->next
;
1691 /* Mark reference to a Lisp_Object.
1692 If the object referred to has not been seen yet, recursively mark
1693 all the references contained in it.
1695 If the object referenced is a short string, the referencing slot
1696 is threaded into a chain of such slots, pointed to from
1697 the `size' field of the string. The actual string size
1698 lives in the last slot in the chain. We recognize the end
1699 because it is < (unsigned) STRING_BLOCK_SIZE. */
1701 #define LAST_MARKED_SIZE 500
1702 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1703 int last_marked_index
;
1706 mark_object (argptr
)
1707 Lisp_Object
*argptr
;
1709 Lisp_Object
*objptr
= argptr
;
1710 register Lisp_Object obj
;
1717 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1718 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1721 last_marked
[last_marked_index
++] = objptr
;
1722 if (last_marked_index
== LAST_MARKED_SIZE
)
1723 last_marked_index
= 0;
1725 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1729 register struct Lisp_String
*ptr
= XSTRING (obj
);
1731 MARK_INTERVAL_TREE (ptr
->intervals
);
1732 if (ptr
->size
& MARKBIT
)
1733 /* A large string. Just set ARRAY_MARK_FLAG. */
1734 ptr
->size
|= ARRAY_MARK_FLAG
;
1737 /* A small string. Put this reference
1738 into the chain of references to it.
1739 If the address includes MARKBIT, put that bit elsewhere
1740 when we store OBJPTR into the size field. */
1742 if (XMARKBIT (*objptr
))
1744 XSETFASTINT (*objptr
, ptr
->size
);
1748 XSETFASTINT (*objptr
, ptr
->size
);
1750 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1752 ptr
->size
= (EMACS_INT
) objptr
;
1753 if (ptr
->size
& MARKBIT
)
1754 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1759 case Lisp_Vectorlike
:
1760 if (GC_BUFFERP (obj
))
1762 if (!XMARKBIT (XBUFFER (obj
)->name
))
1765 else if (GC_SUBRP (obj
))
1767 else if (GC_COMPILEDP (obj
))
1768 /* We could treat this just like a vector, but it is better
1769 to save the COMPILED_CONSTANTS element for last and avoid recursion
1772 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1773 register EMACS_INT size
= ptr
->size
;
1774 /* See comment above under Lisp_Vector. */
1775 struct Lisp_Vector
*volatile ptr1
= ptr
;
1778 if (size
& ARRAY_MARK_FLAG
)
1779 break; /* Already marked */
1780 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1781 size
&= PSEUDOVECTOR_SIZE_MASK
;
1782 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1784 if (i
!= COMPILED_CONSTANTS
)
1785 mark_object (&ptr1
->contents
[i
]);
1787 /* This cast should be unnecessary, but some Mips compiler complains
1788 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1789 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1793 else if (GC_FRAMEP (obj
))
1795 /* See comment above under Lisp_Vector for why this is volatile. */
1796 register struct frame
*volatile ptr
= XFRAME (obj
);
1797 register EMACS_INT size
= ptr
->size
;
1799 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1800 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1802 mark_object (&ptr
->name
);
1803 mark_object (&ptr
->icon_name
);
1804 mark_object (&ptr
->focus_frame
);
1805 mark_object (&ptr
->selected_window
);
1806 mark_object (&ptr
->minibuffer_window
);
1807 mark_object (&ptr
->param_alist
);
1808 mark_object (&ptr
->scroll_bars
);
1809 mark_object (&ptr
->condemned_scroll_bars
);
1810 mark_object (&ptr
->menu_bar_items
);
1811 mark_object (&ptr
->face_alist
);
1812 mark_object (&ptr
->menu_bar_vector
);
1813 mark_object (&ptr
->buffer_predicate
);
1815 #endif /* MULTI_FRAME */
1816 else if (GC_BOOL_VECTOR_P (obj
))
1820 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1821 register EMACS_INT size
= ptr
->size
;
1822 /* The reason we use ptr1 is to avoid an apparent hardware bug
1823 that happens occasionally on the FSF's HP 300s.
1824 The bug is that a2 gets clobbered by recursive calls to mark_object.
1825 The clobberage seems to happen during function entry,
1826 perhaps in the moveml instruction.
1827 Yes, this is a crock, but we have to do it. */
1828 struct Lisp_Vector
*volatile ptr1
= ptr
;
1831 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1832 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1833 if (size
& PSEUDOVECTOR_FLAG
)
1834 size
&= PSEUDOVECTOR_SIZE_MASK
;
1835 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1836 mark_object (&ptr1
->contents
[i
]);
1842 /* See comment above under Lisp_Vector for why this is volatile. */
1843 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1844 struct Lisp_Symbol
*ptrx
;
1846 if (XMARKBIT (ptr
->plist
)) break;
1848 mark_object ((Lisp_Object
*) &ptr
->value
);
1849 mark_object (&ptr
->function
);
1850 mark_object (&ptr
->plist
);
1851 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1852 mark_object (&ptr
->name
);
1856 /* For the benefit of the last_marked log. */
1857 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1858 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1859 XSETSYMBOL (obj
, ptrx
);
1860 /* We can't goto loop here because *objptr doesn't contain an
1861 actual Lisp_Object with valid datatype field. */
1868 switch (XMISCTYPE (obj
))
1870 case Lisp_Misc_Marker
:
1871 XMARK (XMARKER (obj
)->chain
);
1872 /* DO NOT mark thru the marker's chain.
1873 The buffer's markers chain does not preserve markers from gc;
1874 instead, markers are removed from the chain when freed by gc. */
1877 case Lisp_Misc_Buffer_Local_Value
:
1878 case Lisp_Misc_Some_Buffer_Local_Value
:
1880 register struct Lisp_Buffer_Local_Value
*ptr
1881 = XBUFFER_LOCAL_VALUE (obj
);
1882 if (XMARKBIT (ptr
->car
)) break;
1884 /* If the cdr is nil, avoid recursion for the car. */
1885 if (EQ (ptr
->cdr
, Qnil
))
1890 mark_object (&ptr
->car
);
1891 /* See comment above under Lisp_Vector for why not use ptr here. */
1892 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1896 case Lisp_Misc_Intfwd
:
1897 case Lisp_Misc_Boolfwd
:
1898 case Lisp_Misc_Objfwd
:
1899 case Lisp_Misc_Buffer_Objfwd
:
1900 case Lisp_Misc_Kboard_Objfwd
:
1901 /* Don't bother with Lisp_Buffer_Objfwd,
1902 since all markable slots in current buffer marked anyway. */
1903 /* Don't need to do Lisp_Objfwd, since the places they point
1904 are protected with staticpro. */
1907 case Lisp_Misc_Overlay
:
1909 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1910 if (!XMARKBIT (ptr
->plist
))
1913 mark_object (&ptr
->start
);
1914 mark_object (&ptr
->end
);
1915 objptr
= &ptr
->plist
;
1928 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1929 if (XMARKBIT (ptr
->car
)) break;
1931 /* If the cdr is nil, avoid recursion for the car. */
1932 if (EQ (ptr
->cdr
, Qnil
))
1937 mark_object (&ptr
->car
);
1938 /* See comment above under Lisp_Vector for why not use ptr here. */
1939 objptr
= &XCONS (obj
)->cdr
;
1943 #ifdef LISP_FLOAT_TYPE
1945 XMARK (XFLOAT (obj
)->type
);
1947 #endif /* LISP_FLOAT_TYPE */
1957 /* Mark the pointers in a buffer structure. */
1963 register struct buffer
*buffer
= XBUFFER (buf
);
1964 register Lisp_Object
*ptr
;
1965 Lisp_Object base_buffer
;
1967 /* This is the buffer's markbit */
1968 mark_object (&buffer
->name
);
1969 XMARK (buffer
->name
);
1971 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1974 mark_object (buffer
->syntax_table
);
1976 /* Mark the various string-pointers in the buffer object.
1977 Since the strings may be relocated, we must mark them
1978 in their actual slots. So gc_sweep must convert each slot
1979 back to an ordinary C pointer. */
1980 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1981 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1982 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1983 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1985 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1986 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1987 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1988 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1991 for (ptr
= &buffer
->name
+ 1;
1992 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1996 /* If this is an indirect buffer, mark its base buffer. */
1997 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1999 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2000 mark_buffer (base_buffer
);
2005 /* Mark the pointers in the kboard objects. */
2012 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2014 if (kb
->kbd_macro_buffer
)
2015 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2017 mark_object (&kb
->Vprefix_arg
);
2018 mark_object (&kb
->kbd_queue
);
2019 mark_object (&kb
->Vlast_kbd_macro
);
2020 mark_object (&kb
->Vsystem_key_alist
);
2021 mark_object (&kb
->system_key_syms
);
2025 /* Sweep: find all structures not marked, and free them. */
2030 total_string_size
= 0;
2033 /* Put all unmarked conses on free list */
2035 register struct cons_block
*cblk
;
2036 register int lim
= cons_block_index
;
2037 register int num_free
= 0, num_used
= 0;
2041 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
2044 for (i
= 0; i
< lim
; i
++)
2045 if (!XMARKBIT (cblk
->conses
[i
].car
))
2048 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
2049 cons_free_list
= &cblk
->conses
[i
];
2054 XUNMARK (cblk
->conses
[i
].car
);
2056 lim
= CONS_BLOCK_SIZE
;
2058 total_conses
= num_used
;
2059 total_free_conses
= num_free
;
2062 #ifdef LISP_FLOAT_TYPE
2063 /* Put all unmarked floats on free list */
2065 register struct float_block
*fblk
;
2066 register int lim
= float_block_index
;
2067 register int num_free
= 0, num_used
= 0;
2069 float_free_list
= 0;
2071 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
2074 for (i
= 0; i
< lim
; i
++)
2075 if (!XMARKBIT (fblk
->floats
[i
].type
))
2078 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
2079 float_free_list
= &fblk
->floats
[i
];
2084 XUNMARK (fblk
->floats
[i
].type
);
2086 lim
= FLOAT_BLOCK_SIZE
;
2088 total_floats
= num_used
;
2089 total_free_floats
= num_free
;
2091 #endif /* LISP_FLOAT_TYPE */
2093 #ifdef USE_TEXT_PROPERTIES
2094 /* Put all unmarked intervals on free list */
2096 register struct interval_block
*iblk
;
2097 register int lim
= interval_block_index
;
2098 register int num_free
= 0, num_used
= 0;
2100 interval_free_list
= 0;
2102 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
2106 for (i
= 0; i
< lim
; i
++)
2108 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2110 iblk
->intervals
[i
].parent
= interval_free_list
;
2111 interval_free_list
= &iblk
->intervals
[i
];
2117 XUNMARK (iblk
->intervals
[i
].plist
);
2120 lim
= INTERVAL_BLOCK_SIZE
;
2122 total_intervals
= num_used
;
2123 total_free_intervals
= num_free
;
2125 #endif /* USE_TEXT_PROPERTIES */
2127 /* Put all unmarked symbols on free list */
2129 register struct symbol_block
*sblk
;
2130 register int lim
= symbol_block_index
;
2131 register int num_free
= 0, num_used
= 0;
2133 symbol_free_list
= 0;
2135 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2138 for (i
= 0; i
< lim
; i
++)
2139 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2141 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2142 symbol_free_list
= &sblk
->symbols
[i
];
2148 sblk
->symbols
[i
].name
2149 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2150 XUNMARK (sblk
->symbols
[i
].plist
);
2152 lim
= SYMBOL_BLOCK_SIZE
;
2154 total_symbols
= num_used
;
2155 total_free_symbols
= num_free
;
2159 /* Put all unmarked markers on free list.
2160 Dechain each one first from the buffer it points into,
2161 but only if it's a real marker. */
2163 register struct marker_block
*mblk
;
2164 register int lim
= marker_block_index
;
2165 register int num_free
= 0, num_used
= 0;
2167 marker_free_list
= 0;
2169 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2172 EMACS_INT already_free
= -1;
2174 for (i
= 0; i
< lim
; i
++)
2176 Lisp_Object
*markword
;
2177 switch (mblk
->markers
[i
].u_marker
.type
)
2179 case Lisp_Misc_Marker
:
2180 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2182 case Lisp_Misc_Buffer_Local_Value
:
2183 case Lisp_Misc_Some_Buffer_Local_Value
:
2184 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2186 case Lisp_Misc_Overlay
:
2187 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2189 case Lisp_Misc_Free
:
2190 /* If the object was already free, keep it
2191 on the free list. */
2192 markword
= &already_free
;
2198 if (markword
&& !XMARKBIT (*markword
))
2201 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2203 /* tem1 avoids Sun compiler bug */
2204 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2205 XSETMARKER (tem
, tem1
);
2206 unchain_marker (tem
);
2208 /* Set the type of the freed object to Lisp_Misc_Free.
2209 We could leave the type alone, since nobody checks it,
2210 but this might catch bugs faster. */
2211 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2212 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2213 marker_free_list
= &mblk
->markers
[i
];
2220 XUNMARK (*markword
);
2223 lim
= MARKER_BLOCK_SIZE
;
2226 total_markers
= num_used
;
2227 total_free_markers
= num_free
;
2230 /* Free all unmarked buffers */
2232 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2235 if (!XMARKBIT (buffer
->name
))
2238 prev
->next
= buffer
->next
;
2240 all_buffers
= buffer
->next
;
2241 next
= buffer
->next
;
2247 XUNMARK (buffer
->name
);
2248 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2251 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2252 for purposes of marking and relocation.
2253 Turn them back into C pointers now. */
2254 buffer
->upcase_table
2255 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2256 buffer
->downcase_table
2257 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2259 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2260 buffer
->folding_sort_table
2261 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2264 prev
= buffer
, buffer
= buffer
->next
;
2268 #endif /* standalone */
2270 /* Free all unmarked vectors */
2272 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2273 total_vector_size
= 0;
2276 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2279 prev
->next
= vector
->next
;
2281 all_vectors
= vector
->next
;
2282 next
= vector
->next
;
2288 vector
->size
&= ~ARRAY_MARK_FLAG
;
2289 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2290 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2292 total_vector_size
+= vector
->size
;
2293 prev
= vector
, vector
= vector
->next
;
2297 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2299 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2300 struct Lisp_String
*s
;
2304 s
= (struct Lisp_String
*) &sb
->chars
[0];
2305 if (s
->size
& ARRAY_MARK_FLAG
)
2307 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2308 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2309 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2310 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2311 prev
= sb
, sb
= sb
->next
;
2316 prev
->next
= sb
->next
;
2318 large_string_blocks
= sb
->next
;
2327 /* Compactify strings, relocate references, and free empty string blocks. */
2332 /* String block of old strings we are scanning. */
2333 register struct string_block
*from_sb
;
2334 /* A preceding string block (or maybe the same one)
2335 where we are copying the still-live strings to. */
2336 register struct string_block
*to_sb
;
2340 to_sb
= first_string_block
;
2343 /* Scan each existing string block sequentially, string by string. */
2344 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2347 /* POS is the index of the next string in the block. */
2348 while (pos
< from_sb
->pos
)
2350 register struct Lisp_String
*nextstr
2351 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2353 register struct Lisp_String
*newaddr
;
2354 register EMACS_INT size
= nextstr
->size
;
2356 /* NEXTSTR is the old address of the next string.
2357 Just skip it if it isn't marked. */
2358 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2360 /* It is marked, so its size field is really a chain of refs.
2361 Find the end of the chain, where the actual size lives. */
2362 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2364 if (size
& DONT_COPY_FLAG
)
2365 size
^= MARKBIT
| DONT_COPY_FLAG
;
2366 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2369 total_string_size
+= size
;
2371 /* If it won't fit in TO_SB, close it out,
2372 and move to the next sb. Keep doing so until
2373 TO_SB reaches a large enough, empty enough string block.
2374 We know that TO_SB cannot advance past FROM_SB here
2375 since FROM_SB is large enough to contain this string.
2376 Any string blocks skipped here
2377 will be patched out and freed later. */
2378 while (to_pos
+ STRING_FULLSIZE (size
)
2379 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2381 to_sb
->pos
= to_pos
;
2382 to_sb
= to_sb
->next
;
2385 /* Compute new address of this string
2386 and update TO_POS for the space being used. */
2387 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2388 to_pos
+= STRING_FULLSIZE (size
);
2390 /* Copy the string itself to the new place. */
2391 if (nextstr
!= newaddr
)
2392 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2393 + INTERVAL_PTR_SIZE
);
2395 /* Go through NEXTSTR's chain of references
2396 and make each slot in the chain point to
2397 the new address of this string. */
2398 size
= newaddr
->size
;
2399 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2401 register Lisp_Object
*objptr
;
2402 if (size
& DONT_COPY_FLAG
)
2403 size
^= MARKBIT
| DONT_COPY_FLAG
;
2404 objptr
= (Lisp_Object
*)size
;
2406 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2407 if (XMARKBIT (*objptr
))
2409 XSETSTRING (*objptr
, newaddr
);
2413 XSETSTRING (*objptr
, newaddr
);
2415 /* Store the actual size in the size field. */
2416 newaddr
->size
= size
;
2418 #ifdef USE_TEXT_PROPERTIES
2419 /* Now that the string has been relocated, rebalance its
2420 interval tree, and update the tree's parent pointer. */
2421 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2423 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2424 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2427 #endif /* USE_TEXT_PROPERTIES */
2429 pos
+= STRING_FULLSIZE (size
);
2433 /* Close out the last string block still used and free any that follow. */
2434 to_sb
->pos
= to_pos
;
2435 current_string_block
= to_sb
;
2437 from_sb
= to_sb
->next
;
2441 to_sb
= from_sb
->next
;
2446 /* Free any empty string blocks further back in the chain.
2447 This loop will never free first_string_block, but it is very
2448 unlikely that that one will become empty, so why bother checking? */
2450 from_sb
= first_string_block
;
2451 while (to_sb
= from_sb
->next
)
2453 if (to_sb
->pos
== 0)
2455 if (from_sb
->next
= to_sb
->next
)
2456 from_sb
->next
->prev
= from_sb
;
2464 /* Debugging aids. */
2466 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2467 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2468 This may be helpful in debugging Emacs's memory usage.\n\
2469 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2474 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2479 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2480 "Return a list of counters that measure how much consing there has been.\n\
2481 Each of these counters increments for a certain kind of object.\n\
2482 The counters wrap around from the largest positive integer to zero.\n\
2483 Garbage collection does not decrease them.\n\
2484 The elements of the value are as follows:\n\
2485 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2486 All are in units of 1 = one object consed\n\
2487 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2489 MISCS include overlays, markers, and some internal types.\n\
2490 Frames, windows, buffers, and subprocesses count as vectors\n\
2491 (but the contents of a buffer's text do not count here).")
2494 Lisp_Object lisp_cons_cells_consed
;
2495 Lisp_Object lisp_floats_consed
;
2496 Lisp_Object lisp_vector_cells_consed
;
2497 Lisp_Object lisp_symbols_consed
;
2498 Lisp_Object lisp_string_chars_consed
;
2499 Lisp_Object lisp_misc_objects_consed
;
2500 Lisp_Object lisp_intervals_consed
;
2502 XSETINT (lisp_cons_cells_consed
,
2503 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2504 XSETINT (lisp_floats_consed
,
2505 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2506 XSETINT (lisp_vector_cells_consed
,
2507 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2508 XSETINT (lisp_symbols_consed
,
2509 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2510 XSETINT (lisp_string_chars_consed
,
2511 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2512 XSETINT (lisp_misc_objects_consed
,
2513 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2514 XSETINT (lisp_intervals_consed
,
2515 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2517 return Fcons (lisp_cons_cells_consed
,
2518 Fcons (lisp_floats_consed
,
2519 Fcons (lisp_vector_cells_consed
,
2520 Fcons (lisp_symbols_consed
,
2521 Fcons (lisp_string_chars_consed
,
2522 Fcons (lisp_misc_objects_consed
,
2523 Fcons (lisp_intervals_consed
,
2527 /* Initialization */
2531 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2534 pure_size
= PURESIZE
;
2537 ignore_warnings
= 1;
2542 #ifdef LISP_FLOAT_TYPE
2544 #endif /* LISP_FLOAT_TYPE */
2548 malloc_hysteresis
= 32;
2550 malloc_hysteresis
= 0;
2553 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2555 ignore_warnings
= 0;
2558 consing_since_gc
= 0;
2559 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2560 #ifdef VIRT_ADDR_VARIES
2561 malloc_sbrk_unused
= 1<<22; /* A large number */
2562 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2563 #endif /* VIRT_ADDR_VARIES */
2574 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2575 "*Number of bytes of consing between garbage collections.\n\
2576 Garbage collection can happen automatically once this many bytes have been\n\
2577 allocated since the last garbage collection. All data types count.\n\n\
2578 Garbage collection happens automatically only when `eval' is called.\n\n\
2579 By binding this temporarily to a large number, you can effectively\n\
2580 prevent garbage collection during a part of the program.");
2582 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2583 "Number of bytes of sharable Lisp data allocated so far.");
2586 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2587 "Number of bytes of unshared memory allocated in this session.");
2589 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2590 "Number of bytes of unshared memory remaining available in this session.");
2593 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2594 "Non-nil means loading Lisp code in order to dump an executable.\n\
2595 This means that certain objects should be allocated in shared (pure) space.");
2597 DEFVAR_INT ("undo-limit", &undo_limit
,
2598 "Keep no more undo information once it exceeds this size.\n\
2599 This limit is applied when garbage collection happens.\n\
2600 The size is counted as the number of bytes occupied,\n\
2601 which includes both saved text and other data.");
2604 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2605 "Don't keep more than this much size of undo information.\n\
2606 A command which pushes past this size is itself forgotten.\n\
2607 This limit is applied when garbage collection happens.\n\
2608 The size is counted as the number of bytes occupied,\n\
2609 which includes both saved text and other data.");
2610 undo_strong_limit
= 30000;
2612 /* We build this in advance because if we wait until we need it, we might
2613 not be able to allocate the memory to hold it. */
2615 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2616 staticpro (&memory_signal_data
);
2618 staticpro (&Qgc_cons_threshold
);
2619 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2621 staticpro (&Qchar_table_extra_slots
);
2622 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
2627 defsubr (&Smake_byte_code
);
2628 defsubr (&Smake_list
);
2629 defsubr (&Smake_vector
);
2630 defsubr (&Smake_char_table
);
2631 defsubr (&Smake_string
);
2632 defsubr (&Smake_bool_vector
);
2633 defsubr (&Smake_symbol
);
2634 defsubr (&Smake_marker
);
2635 defsubr (&Spurecopy
);
2636 defsubr (&Sgarbage_collect
);
2637 defsubr (&Smemory_limit
);
2638 defsubr (&Smemory_use_counts
);