1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "intervals.h"
30 #include "blockinput.h"
33 #include "syssignal.h"
35 #define max(A,B) ((A) > (B) ? (A) : (B))
37 /* Macro to verify that storage intended for Lisp objects is not
38 out of range to fit in the space for a pointer.
39 ADDRESS is the start of the block, and SIZE
40 is the amount of space within which objects can start. */
41 #define VALIDATE_LISP_STORAGE(address, size) \
45 XSETCONS (val, (char *) address + size); \
46 if ((char *) XCONS (val) != (char *) address + size) \
53 /* Number of bytes of consing done since the last gc */
56 /* Number of bytes of consing since gc before another gc should be done. */
57 int gc_cons_threshold
;
59 /* Nonzero during gc */
62 #ifndef VIRT_ADDR_VARIES
64 #endif /* VIRT_ADDR_VARIES */
67 #ifndef VIRT_ADDR_VARIES
69 #endif /* VIRT_ADDR_VARIES */
70 int malloc_sbrk_unused
;
72 /* Two limits controlling how much undo information to keep. */
74 int undo_strong_limit
;
76 /* Non-nil means defun should do purecopy on the function definition */
77 Lisp_Object Vpurify_flag
;
80 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
81 #define PUREBEG (char *) pure
83 #define pure PURE_SEG_BITS /* Use shared memory segment */
84 #define PUREBEG (char *)PURE_SEG_BITS
86 /* This variable is used only by the XPNTR macro when HAVE_SHM is
87 defined. If we used the PURESIZE macro directly there, that would
88 make most of emacs dependent on puresize.h, which we don't want -
89 you should be able to change that without too much recompilation.
90 So map_in_data initializes pure_size, and the dependencies work
93 #endif /* not HAVE_SHM */
95 /* Index in pure at which next pure object will be allocated. */
98 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
99 char *pending_malloc_warning
;
101 /* Pre-computed signal argument for use when memory is exhausted. */
102 Lisp_Object memory_signal_data
;
104 /* Maximum amount of C stack to save when a GC happens. */
106 #ifndef MAX_SAVE_STACK
107 #define MAX_SAVE_STACK 16000
110 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
111 pointer to a Lisp_Object, when that pointer is viewed as an integer.
112 (On most machines, pointers are even, so we can use the low bit.
113 Word-addressible architectures may need to override this in the m-file.)
114 When linking references to small strings through the size field, we
115 use this slot to hold the bit that would otherwise be interpreted as
117 #ifndef DONT_COPY_FLAG
118 #define DONT_COPY_FLAG 1
119 #endif /* no DONT_COPY_FLAG */
121 #if DONT_COPY_FLAG == MARKBIT
125 /* Buffer in which we save a copy of the C stack at each GC. */
130 /* Non-zero means ignore malloc warnings. Set during initialization. */
133 static void mark_object (), mark_buffer ();
134 static void clear_marks (), gc_sweep ();
135 static void compact_strings ();
137 /* Versions of malloc and realloc that print warnings as memory gets full. */
140 malloc_warning_1 (str
)
143 Fprinc (str
, Vstandard_output
);
144 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
145 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
146 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
150 /* malloc calls this if it finds we are near exhausting storage */
154 pending_malloc_warning
= str
;
157 display_malloc_warning ()
159 register Lisp_Object val
;
161 val
= build_string (pending_malloc_warning
);
162 pending_malloc_warning
= 0;
163 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
166 /* Called if malloc returns zero */
169 /* This used to call error, but if we've run out of memory, we could get
170 infinite recursion trying to build the string. */
172 Fsignal (Qerror
, memory_signal_data
);
175 /* like malloc routines but check for no memory and block interrupt input. */
184 val
= (long *) malloc (size
);
187 if (!val
&& size
) memory_full ();
192 xrealloc (block
, size
)
199 /* We must call malloc explicitly when BLOCK is 0, since some
200 reallocs don't do this. */
202 val
= (long *) malloc (size
);
204 val
= (long *) realloc (block
, size
);
207 if (!val
&& size
) memory_full ();
221 /* Arranging to disable input signals while we're in malloc.
223 This only works with GNU malloc. To help out systems which can't
224 use GNU malloc, all the calls to malloc, realloc, and free
225 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
226 pairs; unfortunately, we have no idea what C library functions
227 might call malloc, so we can't really protect them unless you're
228 using GNU malloc. Fortunately, most of the major operating can use
231 #ifndef SYSTEM_MALLOC
232 extern void * (*__malloc_hook
) ();
233 static void * (*old_malloc_hook
) ();
234 extern void * (*__realloc_hook
) ();
235 static void * (*old_realloc_hook
) ();
236 extern void (*__free_hook
) ();
237 static void (*old_free_hook
) ();
240 emacs_blocked_free (ptr
)
244 __free_hook
= old_free_hook
;
246 __free_hook
= emacs_blocked_free
;
251 emacs_blocked_malloc (size
)
257 __malloc_hook
= old_malloc_hook
;
258 value
= (void *) malloc (size
);
259 __malloc_hook
= emacs_blocked_malloc
;
266 emacs_blocked_realloc (ptr
, size
)
273 __realloc_hook
= old_realloc_hook
;
274 value
= (void *) realloc (ptr
, size
);
275 __realloc_hook
= emacs_blocked_realloc
;
282 uninterrupt_malloc ()
284 old_free_hook
= __free_hook
;
285 __free_hook
= emacs_blocked_free
;
287 old_malloc_hook
= __malloc_hook
;
288 __malloc_hook
= emacs_blocked_malloc
;
290 old_realloc_hook
= __realloc_hook
;
291 __realloc_hook
= emacs_blocked_realloc
;
295 /* Interval allocation. */
297 #ifdef USE_TEXT_PROPERTIES
298 #define INTERVAL_BLOCK_SIZE \
299 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
301 struct interval_block
303 struct interval_block
*next
;
304 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
307 struct interval_block
*interval_block
;
308 static int interval_block_index
;
310 INTERVAL interval_free_list
;
316 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
317 interval_block
->next
= 0;
318 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
319 interval_block_index
= 0;
320 interval_free_list
= 0;
323 #define INIT_INTERVALS init_intervals ()
330 if (interval_free_list
)
332 val
= interval_free_list
;
333 interval_free_list
= interval_free_list
->parent
;
337 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
339 register struct interval_block
*newi
340 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
342 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
343 newi
->next
= interval_block
;
344 interval_block
= newi
;
345 interval_block_index
= 0;
347 val
= &interval_block
->intervals
[interval_block_index
++];
349 consing_since_gc
+= sizeof (struct interval
);
350 RESET_INTERVAL (val
);
354 static int total_free_intervals
, total_intervals
;
356 /* Mark the pointers of one interval. */
359 mark_interval (i
, dummy
)
363 if (XMARKBIT (i
->plist
))
365 mark_object (&i
->plist
);
370 mark_interval_tree (tree
)
371 register INTERVAL tree
;
373 /* No need to test if this tree has been marked already; this
374 function is always called through the MARK_INTERVAL_TREE macro,
375 which takes care of that. */
377 /* XMARK expands to an assignment; the LHS of an assignment can't be
379 XMARK (* (Lisp_Object
*) &tree
->parent
);
381 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
384 #define MARK_INTERVAL_TREE(i) \
386 if (!NULL_INTERVAL_P (i) \
387 && ! XMARKBIT ((Lisp_Object) i->parent)) \
388 mark_interval_tree (i); \
391 /* The oddity in the call to XUNMARK is necessary because XUNMARK
392 expands to an assignment to its argument, and most C compilers don't
393 support casts on the left operand of `='. */
394 #define UNMARK_BALANCE_INTERVALS(i) \
396 if (! NULL_INTERVAL_P (i)) \
398 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
399 (i) = balance_intervals (i); \
403 #else /* no interval use */
405 #define INIT_INTERVALS
407 #define UNMARK_BALANCE_INTERVALS(i)
408 #define MARK_INTERVAL_TREE(i)
410 #endif /* no interval use */
412 /* Floating point allocation. */
414 #ifdef LISP_FLOAT_TYPE
415 /* Allocation of float cells, just like conses */
416 /* We store float cells inside of float_blocks, allocating a new
417 float_block with malloc whenever necessary. Float cells reclaimed by
418 GC are put on a free list to be reallocated before allocating
419 any new float cells from the latest float_block.
421 Each float_block is just under 1020 bytes long,
422 since malloc really allocates in units of powers of two
423 and uses 4 bytes for its own overhead. */
425 #define FLOAT_BLOCK_SIZE \
426 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
430 struct float_block
*next
;
431 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
434 struct float_block
*float_block
;
435 int float_block_index
;
437 struct Lisp_Float
*float_free_list
;
442 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
443 float_block
->next
= 0;
444 bzero (float_block
->floats
, sizeof float_block
->floats
);
445 float_block_index
= 0;
449 /* Explicitly free a float cell. */
451 struct Lisp_Float
*ptr
;
453 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
454 float_free_list
= ptr
;
458 make_float (float_value
)
461 register Lisp_Object val
;
465 XSETFLOAT (val
, float_free_list
);
466 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
470 if (float_block_index
== FLOAT_BLOCK_SIZE
)
472 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
473 VALIDATE_LISP_STORAGE (new, sizeof *new);
474 new->next
= float_block
;
476 float_block_index
= 0;
478 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
480 XFLOAT (val
)->data
= float_value
;
481 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
482 consing_since_gc
+= sizeof (struct Lisp_Float
);
486 #endif /* LISP_FLOAT_TYPE */
488 /* Allocation of cons cells */
489 /* We store cons cells inside of cons_blocks, allocating a new
490 cons_block with malloc whenever necessary. Cons cells reclaimed by
491 GC are put on a free list to be reallocated before allocating
492 any new cons cells from the latest cons_block.
494 Each cons_block is just under 1020 bytes long,
495 since malloc really allocates in units of powers of two
496 and uses 4 bytes for its own overhead. */
498 #define CONS_BLOCK_SIZE \
499 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
503 struct cons_block
*next
;
504 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
507 struct cons_block
*cons_block
;
508 int cons_block_index
;
510 struct Lisp_Cons
*cons_free_list
;
515 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
516 cons_block
->next
= 0;
517 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
518 cons_block_index
= 0;
522 /* Explicitly free a cons cell. */
524 struct Lisp_Cons
*ptr
;
526 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
527 cons_free_list
= ptr
;
530 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
531 "Create a new cons, give it CAR and CDR as components, and return it.")
533 Lisp_Object car
, cdr
;
535 register Lisp_Object val
;
539 XSETCONS (val
, cons_free_list
);
540 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
544 if (cons_block_index
== CONS_BLOCK_SIZE
)
546 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
547 VALIDATE_LISP_STORAGE (new, sizeof *new);
548 new->next
= cons_block
;
550 cons_block_index
= 0;
552 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
554 XCONS (val
)->car
= car
;
555 XCONS (val
)->cdr
= cdr
;
556 consing_since_gc
+= sizeof (struct Lisp_Cons
);
560 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
561 "Return a newly created list with specified arguments as elements.\n\
562 Any number of arguments, even zero arguments, are allowed.")
565 register Lisp_Object
*args
;
567 register Lisp_Object len
, val
, val_tail
;
569 XSETFASTINT (len
, nargs
);
570 val
= Fmake_list (len
, Qnil
);
572 while (!NILP (val_tail
))
574 XCONS (val_tail
)->car
= *args
++;
575 val_tail
= XCONS (val_tail
)->cdr
;
580 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
581 "Return a newly created list of length LENGTH, with each element being INIT.")
583 register Lisp_Object length
, init
;
585 register Lisp_Object val
;
588 CHECK_NATNUM (length
, 0);
589 size
= XFASTINT (length
);
593 val
= Fcons (init
, val
);
597 /* Allocation of vectors */
599 struct Lisp_Vector
*all_vectors
;
602 allocate_vectorlike (len
)
605 struct Lisp_Vector
*p
;
607 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
608 + (len
- 1) * sizeof (Lisp_Object
));
609 VALIDATE_LISP_STORAGE (p
, 0);
610 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
611 + (len
- 1) * sizeof (Lisp_Object
));
613 p
->next
= all_vectors
;
618 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
619 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
620 See also the function `vector'.")
622 register Lisp_Object length
, init
;
625 register EMACS_INT sizei
;
627 register struct Lisp_Vector
*p
;
629 CHECK_NATNUM (length
, 0);
630 sizei
= XFASTINT (length
);
632 p
= allocate_vectorlike (sizei
);
634 for (index
= 0; index
< sizei
; index
++)
635 p
->contents
[index
] = init
;
637 XSETVECTOR (vector
, p
);
641 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
642 "Return a newly created vector with specified arguments as elements.\n\
643 Any number of arguments, even zero arguments, are allowed.")
648 register Lisp_Object len
, val
;
650 register struct Lisp_Vector
*p
;
652 XSETFASTINT (len
, nargs
);
653 val
= Fmake_vector (len
, Qnil
);
655 for (index
= 0; index
< nargs
; index
++)
656 p
->contents
[index
] = args
[index
];
660 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
661 "Create a byte-code object with specified arguments as elements.\n\
662 The arguments should be the arglist, bytecode-string, constant vector,\n\
663 stack size, (optional) doc string, and (optional) interactive spec.\n\
664 The first four arguments are required; at most six have any\n\
670 register Lisp_Object len
, val
;
672 register struct Lisp_Vector
*p
;
674 XSETFASTINT (len
, nargs
);
675 if (!NILP (Vpurify_flag
))
676 val
= make_pure_vector (len
);
678 val
= Fmake_vector (len
, Qnil
);
680 for (index
= 0; index
< nargs
; index
++)
682 if (!NILP (Vpurify_flag
))
683 args
[index
] = Fpurecopy (args
[index
]);
684 p
->contents
[index
] = args
[index
];
686 XSETCOMPILED (val
, val
);
690 /* Allocation of symbols.
691 Just like allocation of conses!
693 Each symbol_block is just under 1020 bytes long,
694 since malloc really allocates in units of powers of two
695 and uses 4 bytes for its own overhead. */
697 #define SYMBOL_BLOCK_SIZE \
698 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
702 struct symbol_block
*next
;
703 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
706 struct symbol_block
*symbol_block
;
707 int symbol_block_index
;
709 struct Lisp_Symbol
*symbol_free_list
;
714 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
715 symbol_block
->next
= 0;
716 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
717 symbol_block_index
= 0;
718 symbol_free_list
= 0;
721 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
722 "Return a newly allocated uninterned symbol whose name is NAME.\n\
723 Its value and function definition are void, and its property list is nil.")
727 register Lisp_Object val
;
728 register struct Lisp_Symbol
*p
;
730 CHECK_STRING (str
, 0);
732 if (symbol_free_list
)
734 XSETSYMBOL (val
, symbol_free_list
);
735 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
739 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
741 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
742 VALIDATE_LISP_STORAGE (new, sizeof *new);
743 new->next
= symbol_block
;
745 symbol_block_index
= 0;
747 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
750 p
->name
= XSTRING (str
);
753 p
->function
= Qunbound
;
755 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
759 /* Allocation of markers and other objects that share that structure.
760 Works like allocation of conses. */
762 #define MARKER_BLOCK_SIZE \
763 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
767 struct marker_block
*next
;
768 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
771 struct marker_block
*marker_block
;
772 int marker_block_index
;
774 union Lisp_Misc
*marker_free_list
;
779 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
780 marker_block
->next
= 0;
781 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
782 marker_block_index
= 0;
783 marker_free_list
= 0;
786 /* Return a newly allocated Lisp_Misc object, with no substructure. */
792 if (marker_free_list
)
794 XSETMISC (val
, marker_free_list
);
795 marker_free_list
= marker_free_list
->u_free
.chain
;
799 if (marker_block_index
== MARKER_BLOCK_SIZE
)
801 struct marker_block
*new
802 = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
803 VALIDATE_LISP_STORAGE (new, sizeof *new);
804 new->next
= marker_block
;
806 marker_block_index
= 0;
808 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
810 consing_since_gc
+= sizeof (union Lisp_Misc
);
814 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
815 "Return a newly allocated marker which does not point at any place.")
818 register Lisp_Object val
;
819 register struct Lisp_Marker
*p
;
821 val
= allocate_misc ();
822 XMISC (val
)->type
= Lisp_Misc_Marker
;
830 /* Allocation of strings */
832 /* Strings reside inside of string_blocks. The entire data of the string,
833 both the size and the contents, live in part of the `chars' component of a string_block.
834 The `pos' component is the index within `chars' of the first free byte.
836 first_string_block points to the first string_block ever allocated.
837 Each block points to the next one with its `next' field.
838 The `prev' fields chain in reverse order.
839 The last one allocated is the one currently being filled.
840 current_string_block points to it.
842 The string_blocks that hold individual large strings
843 go in a separate chain, started by large_string_blocks. */
846 /* String blocks contain this many useful bytes.
847 8188 is power of 2, minus 4 for malloc overhead. */
848 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
850 /* A string bigger than this gets its own specially-made string block
851 if it doesn't fit in the current one. */
852 #define STRING_BLOCK_OUTSIZE 1024
854 struct string_block_head
856 struct string_block
*next
, *prev
;
862 struct string_block
*next
, *prev
;
864 char chars
[STRING_BLOCK_SIZE
];
867 /* This points to the string block we are now allocating strings. */
869 struct string_block
*current_string_block
;
871 /* This points to the oldest string block, the one that starts the chain. */
873 struct string_block
*first_string_block
;
875 /* Last string block in chain of those made for individual large strings. */
877 struct string_block
*large_string_blocks
;
879 /* If SIZE is the length of a string, this returns how many bytes
880 the string occupies in a string_block (including padding). */
882 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
884 #define PAD (sizeof (EMACS_INT))
887 #define STRING_FULLSIZE(SIZE) \
888 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
894 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
895 first_string_block
= current_string_block
;
896 consing_since_gc
+= sizeof (struct string_block
);
897 current_string_block
->next
= 0;
898 current_string_block
->prev
= 0;
899 current_string_block
->pos
= 0;
900 large_string_blocks
= 0;
903 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
904 "Return a newly created string of length LENGTH, with each element being INIT.\n\
905 Both LENGTH and INIT must be numbers.")
907 Lisp_Object length
, init
;
909 register Lisp_Object val
;
910 register unsigned char *p
, *end
, c
;
912 CHECK_NATNUM (length
, 0);
913 CHECK_NUMBER (init
, 1);
914 val
= make_uninit_string (XFASTINT (length
));
916 p
= XSTRING (val
)->data
;
917 end
= p
+ XSTRING (val
)->size
;
925 make_string (contents
, length
)
929 register Lisp_Object val
;
930 val
= make_uninit_string (length
);
931 bcopy (contents
, XSTRING (val
)->data
, length
);
939 return make_string (str
, strlen (str
));
943 make_uninit_string (length
)
946 register Lisp_Object val
;
947 register int fullsize
= STRING_FULLSIZE (length
);
949 if (length
< 0) abort ();
951 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
952 /* This string can fit in the current string block */
955 ((struct Lisp_String
*)
956 (current_string_block
->chars
+ current_string_block
->pos
)));
957 current_string_block
->pos
+= fullsize
;
959 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
960 /* This string gets its own string block */
962 register struct string_block
*new
963 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
964 VALIDATE_LISP_STORAGE (new, 0);
965 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
967 new->next
= large_string_blocks
;
968 large_string_blocks
= new;
970 ((struct Lisp_String
*)
971 ((struct string_block_head
*)new + 1)));
974 /* Make a new current string block and start it off with this string */
976 register struct string_block
*new
977 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
978 VALIDATE_LISP_STORAGE (new, sizeof *new);
979 consing_since_gc
+= sizeof (struct string_block
);
980 current_string_block
->next
= new;
981 new->prev
= current_string_block
;
983 current_string_block
= new;
986 (struct Lisp_String
*) current_string_block
->chars
);
989 XSTRING (val
)->size
= length
;
990 XSTRING (val
)->data
[length
] = 0;
991 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
996 /* Return a newly created vector or string with specified arguments as
997 elements. If all the arguments are characters that can fit
998 in a string of events, make a string; otherwise, make a vector.
1000 Any number of arguments, even zero arguments, are allowed. */
1003 make_event_array (nargs
, args
)
1009 for (i
= 0; i
< nargs
; i
++)
1010 /* The things that fit in a string
1011 are characters that are in 0...127,
1012 after discarding the meta bit and all the bits above it. */
1013 if (!INTEGERP (args
[i
])
1014 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1015 return Fvector (nargs
, args
);
1017 /* Since the loop exited, we know that all the things in it are
1018 characters, so we can make a string. */
1022 result
= Fmake_string (nargs
, make_number (0));
1023 for (i
= 0; i
< nargs
; i
++)
1025 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1026 /* Move the meta bit to the right place for a string char. */
1027 if (XINT (args
[i
]) & CHAR_META
)
1028 XSTRING (result
)->data
[i
] |= 0x80;
1035 /* Pure storage management. */
1037 /* Must get an error if pure storage is full,
1038 since if it cannot hold a large string
1039 it may be able to hold conses that point to that string;
1040 then the string is not protected from gc. */
1043 make_pure_string (data
, length
)
1047 register Lisp_Object
new;
1048 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1050 if (pureptr
+ size
> PURESIZE
)
1051 error ("Pure Lisp storage exhausted");
1052 XSETSTRING (new, PUREBEG
+ pureptr
);
1053 XSTRING (new)->size
= length
;
1054 bcopy (data
, XSTRING (new)->data
, length
);
1055 XSTRING (new)->data
[length
] = 0;
1057 /* We must give strings in pure storage some kind of interval. So we
1058 give them a null one. */
1059 #if defined (USE_TEXT_PROPERTIES)
1060 XSTRING (new)->intervals
= NULL_INTERVAL
;
1062 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1063 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1068 pure_cons (car
, cdr
)
1069 Lisp_Object car
, cdr
;
1071 register Lisp_Object
new;
1073 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1074 error ("Pure Lisp storage exhausted");
1075 XSETCONS (new, PUREBEG
+ pureptr
);
1076 pureptr
+= sizeof (struct Lisp_Cons
);
1077 XCONS (new)->car
= Fpurecopy (car
);
1078 XCONS (new)->cdr
= Fpurecopy (cdr
);
1082 #ifdef LISP_FLOAT_TYPE
1085 make_pure_float (num
)
1088 register Lisp_Object
new;
1090 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1091 (double) boundary. Some architectures (like the sparc) require
1092 this, and I suspect that floats are rare enough that it's no
1093 tragedy for those that do. */
1096 char *p
= PUREBEG
+ pureptr
;
1100 alignment
= __alignof (struct Lisp_Float
);
1102 alignment
= sizeof (struct Lisp_Float
);
1105 alignment
= sizeof (struct Lisp_Float
);
1107 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1108 pureptr
= p
- PUREBEG
;
1111 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1112 error ("Pure Lisp storage exhausted");
1113 XSETFLOAT (new, PUREBEG
+ pureptr
);
1114 pureptr
+= sizeof (struct Lisp_Float
);
1115 XFLOAT (new)->data
= num
;
1116 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1120 #endif /* LISP_FLOAT_TYPE */
1123 make_pure_vector (len
)
1126 register Lisp_Object
new;
1127 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1129 if (pureptr
+ size
> PURESIZE
)
1130 error ("Pure Lisp storage exhausted");
1132 XSETVECTOR (new, PUREBEG
+ pureptr
);
1134 XVECTOR (new)->size
= len
;
1138 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1139 "Make a copy of OBJECT in pure storage.\n\
1140 Recursively copies contents of vectors and cons cells.\n\
1141 Does not copy symbols.")
1143 register Lisp_Object obj
;
1145 if (NILP (Vpurify_flag
))
1148 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1149 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1153 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1154 #ifdef LISP_FLOAT_TYPE
1155 else if (FLOATP (obj
))
1156 return make_pure_float (XFLOAT (obj
)->data
);
1157 #endif /* LISP_FLOAT_TYPE */
1158 else if (STRINGP (obj
))
1159 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1160 else if (COMPILEDP (obj
) || VECTORP (obj
))
1162 register struct Lisp_Vector
*vec
;
1163 register int i
, size
;
1165 size
= XVECTOR (obj
)->size
;
1166 if (size
& PSEUDOVECTOR_FLAG
)
1167 size
&= PSEUDOVECTOR_SIZE_MASK
;
1168 vec
= XVECTOR (make_pure_vector (size
));
1169 for (i
= 0; i
< size
; i
++)
1170 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1171 if (COMPILEDP (obj
))
1172 XSETCOMPILED (obj
, vec
);
1174 XSETVECTOR (obj
, vec
);
1177 else if (MARKERP (obj
))
1178 error ("Attempt to copy a marker to pure storage");
1183 /* Recording what needs to be marked for gc. */
1185 struct gcpro
*gcprolist
;
1187 #define NSTATICS 512
1189 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1193 /* Put an entry in staticvec, pointing at the variable whose address is given */
1196 staticpro (varaddress
)
1197 Lisp_Object
*varaddress
;
1199 staticvec
[staticidx
++] = varaddress
;
1200 if (staticidx
>= NSTATICS
)
1208 struct catchtag
*next
;
1209 /* jmp_buf jmp; /* We don't need this for GC purposes */
1214 struct backtrace
*next
;
1215 Lisp_Object
*function
;
1216 Lisp_Object
*args
; /* Points to vector of args. */
1217 int nargs
; /* length of vector */
1218 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1222 /* Garbage collection! */
1224 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1225 int total_free_conses
, total_free_markers
, total_free_symbols
;
1226 #ifdef LISP_FLOAT_TYPE
1227 int total_free_floats
, total_floats
;
1228 #endif /* LISP_FLOAT_TYPE */
1230 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1231 "Reclaim storage for Lisp objects no longer needed.\n\
1232 Returns info on amount of space in use:\n\
1233 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1234 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1235 (USED-FLOATS . FREE-FLOATS))\n\
1236 Garbage collection happens automatically if you cons more than\n\
1237 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1240 register struct gcpro
*tail
;
1241 register struct specbinding
*bind
;
1242 struct catchtag
*catch;
1243 struct handler
*handler
;
1244 register struct backtrace
*backlist
;
1245 register Lisp_Object tem
;
1246 char *omessage
= echo_area_glyphs
;
1247 int omessage_length
= echo_area_glyphs_length
;
1248 char stack_top_variable
;
1251 /* Save a copy of the contents of the stack, for debugging. */
1252 #if MAX_SAVE_STACK > 0
1253 if (NILP (Vpurify_flag
))
1255 i
= &stack_top_variable
- stack_bottom
;
1257 if (i
< MAX_SAVE_STACK
)
1259 if (stack_copy
== 0)
1260 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1261 else if (stack_copy_size
< i
)
1262 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1265 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1266 bcopy (stack_bottom
, stack_copy
, i
);
1268 bcopy (&stack_top_variable
, stack_copy
, i
);
1272 #endif /* MAX_SAVE_STACK > 0 */
1274 if (!noninteractive
)
1275 message1_nolog ("Garbage collecting...");
1277 /* Don't keep command history around forever */
1278 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1280 XCONS (tem
)->cdr
= Qnil
;
1282 /* Likewise for undo information. */
1284 register struct buffer
*nextb
= all_buffers
;
1288 /* If a buffer's undo list is Qt, that means that undo is
1289 turned off in that buffer. Calling truncate_undo_list on
1290 Qt tends to return NULL, which effectively turns undo back on.
1291 So don't call truncate_undo_list if undo_list is Qt. */
1292 if (! EQ (nextb
->undo_list
, Qt
))
1294 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1296 nextb
= nextb
->next
;
1302 /* clear_marks (); */
1304 /* In each "large string", set the MARKBIT of the size field.
1305 That enables mark_object to recognize them. */
1307 register struct string_block
*b
;
1308 for (b
= large_string_blocks
; b
; b
= b
->next
)
1309 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1312 /* Mark all the special slots that serve as the roots of accessibility.
1314 Usually the special slots to mark are contained in particular structures.
1315 Then we know no slot is marked twice because the structures don't overlap.
1316 In some cases, the structures point to the slots to be marked.
1317 For these, we use MARKBIT to avoid double marking of the slot. */
1319 for (i
= 0; i
< staticidx
; i
++)
1320 mark_object (staticvec
[i
]);
1321 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1322 for (i
= 0; i
< tail
->nvars
; i
++)
1323 if (!XMARKBIT (tail
->var
[i
]))
1325 mark_object (&tail
->var
[i
]);
1326 XMARK (tail
->var
[i
]);
1328 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1330 mark_object (&bind
->symbol
);
1331 mark_object (&bind
->old_value
);
1333 for (catch = catchlist
; catch; catch = catch->next
)
1335 mark_object (&catch->tag
);
1336 mark_object (&catch->val
);
1338 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1340 mark_object (&handler
->handler
);
1341 mark_object (&handler
->var
);
1343 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1345 if (!XMARKBIT (*backlist
->function
))
1347 mark_object (backlist
->function
);
1348 XMARK (*backlist
->function
);
1350 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1353 i
= backlist
->nargs
- 1;
1355 if (!XMARKBIT (backlist
->args
[i
]))
1357 mark_object (&backlist
->args
[i
]);
1358 XMARK (backlist
->args
[i
]);
1364 /* Clear the mark bits that we set in certain root slots. */
1366 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1367 for (i
= 0; i
< tail
->nvars
; i
++)
1368 XUNMARK (tail
->var
[i
]);
1369 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1371 XUNMARK (*backlist
->function
);
1372 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1375 i
= backlist
->nargs
- 1;
1377 XUNMARK (backlist
->args
[i
]);
1379 XUNMARK (buffer_defaults
.name
);
1380 XUNMARK (buffer_local_symbols
.name
);
1382 /* clear_marks (); */
1385 consing_since_gc
= 0;
1386 if (gc_cons_threshold
< 10000)
1387 gc_cons_threshold
= 10000;
1389 if (omessage
|| minibuf_level
> 0)
1390 message2_nolog (omessage
, omessage_length
);
1391 else if (!noninteractive
)
1392 message1_nolog ("Garbage collecting...done");
1394 return Fcons (Fcons (make_number (total_conses
),
1395 make_number (total_free_conses
)),
1396 Fcons (Fcons (make_number (total_symbols
),
1397 make_number (total_free_symbols
)),
1398 Fcons (Fcons (make_number (total_markers
),
1399 make_number (total_free_markers
)),
1400 Fcons (make_number (total_string_size
),
1401 Fcons (make_number (total_vector_size
),
1403 #ifdef LISP_FLOAT_TYPE
1404 Fcons (Fcons (make_number (total_floats
),
1405 make_number (total_free_floats
)),
1407 #else /* not LISP_FLOAT_TYPE */
1409 #endif /* not LISP_FLOAT_TYPE */
1417 /* Clear marks on all conses */
1419 register struct cons_block
*cblk
;
1420 register int lim
= cons_block_index
;
1422 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1425 for (i
= 0; i
< lim
; i
++)
1426 XUNMARK (cblk
->conses
[i
].car
);
1427 lim
= CONS_BLOCK_SIZE
;
1430 /* Clear marks on all symbols */
1432 register struct symbol_block
*sblk
;
1433 register int lim
= symbol_block_index
;
1435 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1438 for (i
= 0; i
< lim
; i
++)
1440 XUNMARK (sblk
->symbols
[i
].plist
);
1442 lim
= SYMBOL_BLOCK_SIZE
;
1445 /* Clear marks on all markers */
1447 register struct marker_block
*sblk
;
1448 register int lim
= marker_block_index
;
1450 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1453 for (i
= 0; i
< lim
; i
++)
1454 if (sblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1455 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1456 lim
= MARKER_BLOCK_SIZE
;
1459 /* Clear mark bits on all buffers */
1461 register struct buffer
*nextb
= all_buffers
;
1465 XUNMARK (nextb
->name
);
1466 nextb
= nextb
->next
;
1472 /* Mark reference to a Lisp_Object.
1473 If the object referred to has not been seen yet, recursively mark
1474 all the references contained in it.
1476 If the object referenced is a short string, the referencing slot
1477 is threaded into a chain of such slots, pointed to from
1478 the `size' field of the string. The actual string size
1479 lives in the last slot in the chain. We recognize the end
1480 because it is < (unsigned) STRING_BLOCK_SIZE. */
1482 #define LAST_MARKED_SIZE 500
1483 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1484 int last_marked_index
;
1487 mark_object (objptr
)
1488 Lisp_Object
*objptr
;
1490 register Lisp_Object obj
;
1497 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1498 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1501 last_marked
[last_marked_index
++] = objptr
;
1502 if (last_marked_index
== LAST_MARKED_SIZE
)
1503 last_marked_index
= 0;
1505 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1509 register struct Lisp_String
*ptr
= XSTRING (obj
);
1511 MARK_INTERVAL_TREE (ptr
->intervals
);
1512 if (ptr
->size
& MARKBIT
)
1513 /* A large string. Just set ARRAY_MARK_FLAG. */
1514 ptr
->size
|= ARRAY_MARK_FLAG
;
1517 /* A small string. Put this reference
1518 into the chain of references to it.
1519 If the address includes MARKBIT, put that bit elsewhere
1520 when we store OBJPTR into the size field. */
1522 if (XMARKBIT (*objptr
))
1524 XSETFASTINT (*objptr
, ptr
->size
);
1528 XSETFASTINT (*objptr
, ptr
->size
);
1530 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1532 ptr
->size
= (EMACS_INT
) objptr
;
1533 if (ptr
->size
& MARKBIT
)
1534 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1539 case Lisp_Vectorlike
:
1540 if (GC_BUFFERP (obj
))
1542 if (!XMARKBIT (XBUFFER (obj
)->name
))
1545 else if (GC_SUBRP (obj
))
1547 else if (GC_COMPILEDP (obj
))
1548 /* We could treat this just like a vector, but it is better
1549 to save the COMPILED_CONSTANTS element for last and avoid recursion
1552 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1553 register EMACS_INT size
= ptr
->size
;
1554 /* See comment above under Lisp_Vector. */
1555 struct Lisp_Vector
*volatile ptr1
= ptr
;
1558 if (size
& ARRAY_MARK_FLAG
)
1559 break; /* Already marked */
1560 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1561 size
&= PSEUDOVECTOR_SIZE_MASK
;
1562 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1564 if (i
!= COMPILED_CONSTANTS
)
1565 mark_object (&ptr1
->contents
[i
]);
1567 /* This cast should be unnecessary, but some Mips compiler complains
1568 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1569 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1573 else if (GC_FRAMEP (obj
))
1575 /* See comment above under Lisp_Vector for why this is volatile. */
1576 register struct frame
*volatile ptr
= XFRAME (obj
);
1577 register EMACS_INT size
= ptr
->size
;
1579 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1580 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1582 mark_object (&ptr
->name
);
1583 mark_object (&ptr
->focus_frame
);
1584 mark_object (&ptr
->selected_window
);
1585 mark_object (&ptr
->minibuffer_window
);
1586 mark_object (&ptr
->param_alist
);
1587 mark_object (&ptr
->scroll_bars
);
1588 mark_object (&ptr
->condemned_scroll_bars
);
1589 mark_object (&ptr
->menu_bar_items
);
1590 mark_object (&ptr
->face_alist
);
1591 mark_object (&ptr
->menu_bar_vector
);
1592 mark_object (&ptr
->buffer_predicate
);
1594 #endif /* MULTI_FRAME */
1597 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1598 register EMACS_INT size
= ptr
->size
;
1599 /* The reason we use ptr1 is to avoid an apparent hardware bug
1600 that happens occasionally on the FSF's HP 300s.
1601 The bug is that a2 gets clobbered by recursive calls to mark_object.
1602 The clobberage seems to happen during function entry,
1603 perhaps in the moveml instruction.
1604 Yes, this is a crock, but we have to do it. */
1605 struct Lisp_Vector
*volatile ptr1
= ptr
;
1608 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1609 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1610 if (size
& PSEUDOVECTOR_FLAG
)
1611 size
&= PSEUDOVECTOR_SIZE_MASK
;
1612 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1613 mark_object (&ptr1
->contents
[i
]);
1619 /* See comment above under Lisp_Vector for why this is volatile. */
1620 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1621 struct Lisp_Symbol
*ptrx
;
1623 if (XMARKBIT (ptr
->plist
)) break;
1625 mark_object ((Lisp_Object
*) &ptr
->value
);
1626 mark_object (&ptr
->function
);
1627 mark_object (&ptr
->plist
);
1628 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1629 mark_object (&ptr
->name
);
1633 /* For the benefit of the last_marked log. */
1634 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1635 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1636 XSETSYMBOL (obj
, ptrx
);
1637 /* We can't goto loop here because *objptr doesn't contain an
1638 actual Lisp_Object with valid datatype field. */
1645 switch (XMISC (obj
)->type
)
1647 case Lisp_Misc_Marker
:
1648 XMARK (XMARKER (obj
)->chain
);
1649 /* DO NOT mark thru the marker's chain.
1650 The buffer's markers chain does not preserve markers from gc;
1651 instead, markers are removed from the chain when freed by gc. */
1654 case Lisp_Misc_Buffer_Local_Value
:
1655 case Lisp_Misc_Some_Buffer_Local_Value
:
1657 register struct Lisp_Buffer_Local_Value
*ptr
1658 = XBUFFER_LOCAL_VALUE (obj
);
1659 if (XMARKBIT (ptr
->car
)) break;
1661 /* If the cdr is nil, avoid recursion for the car. */
1662 if (EQ (ptr
->cdr
, Qnil
))
1667 mark_object (&ptr
->car
);
1668 /* See comment above under Lisp_Vector for why not use ptr here. */
1669 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1673 case Lisp_Misc_Intfwd
:
1674 case Lisp_Misc_Boolfwd
:
1675 case Lisp_Misc_Objfwd
:
1676 case Lisp_Misc_Buffer_Objfwd
:
1677 /* Don't bother with Lisp_Buffer_Objfwd,
1678 since all markable slots in current buffer marked anyway. */
1679 /* Don't need to do Lisp_Objfwd, since the places they point
1680 are protected with staticpro. */
1683 case Lisp_Misc_Overlay
:
1685 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1686 if (!XMARKBIT (ptr
->plist
))
1689 mark_object (&ptr
->start
);
1690 mark_object (&ptr
->end
);
1691 objptr
= &ptr
->plist
;
1704 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1705 if (XMARKBIT (ptr
->car
)) break;
1707 /* If the cdr is nil, avoid recursion for the car. */
1708 if (EQ (ptr
->cdr
, Qnil
))
1713 mark_object (&ptr
->car
);
1714 /* See comment above under Lisp_Vector for why not use ptr here. */
1715 objptr
= &XCONS (obj
)->cdr
;
1719 #ifdef LISP_FLOAT_TYPE
1721 XMARK (XFLOAT (obj
)->type
);
1723 #endif /* LISP_FLOAT_TYPE */
1733 /* Mark the pointers in a buffer structure. */
1739 register struct buffer
*buffer
= XBUFFER (buf
);
1740 register Lisp_Object
*ptr
;
1741 Lisp_Object base_buffer
;
1743 /* This is the buffer's markbit */
1744 mark_object (&buffer
->name
);
1745 XMARK (buffer
->name
);
1747 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1750 mark_object (buffer
->syntax_table
);
1752 /* Mark the various string-pointers in the buffer object.
1753 Since the strings may be relocated, we must mark them
1754 in their actual slots. So gc_sweep must convert each slot
1755 back to an ordinary C pointer. */
1756 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1757 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1758 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1759 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1761 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1762 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1763 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1764 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1767 for (ptr
= &buffer
->name
+ 1;
1768 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1772 /* If this is an indirect buffer, mark its base buffer. */
1773 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1775 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1776 mark_buffer (base_buffer
);
1780 /* Sweep: find all structures not marked, and free them. */
1785 total_string_size
= 0;
1788 /* Put all unmarked conses on free list */
1790 register struct cons_block
*cblk
;
1791 register int lim
= cons_block_index
;
1792 register int num_free
= 0, num_used
= 0;
1796 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1799 for (i
= 0; i
< lim
; i
++)
1800 if (!XMARKBIT (cblk
->conses
[i
].car
))
1803 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1804 cons_free_list
= &cblk
->conses
[i
];
1809 XUNMARK (cblk
->conses
[i
].car
);
1811 lim
= CONS_BLOCK_SIZE
;
1813 total_conses
= num_used
;
1814 total_free_conses
= num_free
;
1817 #ifdef LISP_FLOAT_TYPE
1818 /* Put all unmarked floats on free list */
1820 register struct float_block
*fblk
;
1821 register int lim
= float_block_index
;
1822 register int num_free
= 0, num_used
= 0;
1824 float_free_list
= 0;
1826 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1829 for (i
= 0; i
< lim
; i
++)
1830 if (!XMARKBIT (fblk
->floats
[i
].type
))
1833 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1834 float_free_list
= &fblk
->floats
[i
];
1839 XUNMARK (fblk
->floats
[i
].type
);
1841 lim
= FLOAT_BLOCK_SIZE
;
1843 total_floats
= num_used
;
1844 total_free_floats
= num_free
;
1846 #endif /* LISP_FLOAT_TYPE */
1848 #ifdef USE_TEXT_PROPERTIES
1849 /* Put all unmarked intervals on free list */
1851 register struct interval_block
*iblk
;
1852 register int lim
= interval_block_index
;
1853 register int num_free
= 0, num_used
= 0;
1855 interval_free_list
= 0;
1857 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1861 for (i
= 0; i
< lim
; i
++)
1863 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1865 iblk
->intervals
[i
].parent
= interval_free_list
;
1866 interval_free_list
= &iblk
->intervals
[i
];
1872 XUNMARK (iblk
->intervals
[i
].plist
);
1875 lim
= INTERVAL_BLOCK_SIZE
;
1877 total_intervals
= num_used
;
1878 total_free_intervals
= num_free
;
1880 #endif /* USE_TEXT_PROPERTIES */
1882 /* Put all unmarked symbols on free list */
1884 register struct symbol_block
*sblk
;
1885 register int lim
= symbol_block_index
;
1886 register int num_free
= 0, num_used
= 0;
1888 symbol_free_list
= 0;
1890 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1893 for (i
= 0; i
< lim
; i
++)
1894 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1896 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
1897 symbol_free_list
= &sblk
->symbols
[i
];
1903 sblk
->symbols
[i
].name
1904 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1905 XUNMARK (sblk
->symbols
[i
].plist
);
1907 lim
= SYMBOL_BLOCK_SIZE
;
1909 total_symbols
= num_used
;
1910 total_free_symbols
= num_free
;
1914 /* Put all unmarked markers on free list.
1915 Dechain each one first from the buffer it points into,
1916 but only if it's a real marker. */
1918 register struct marker_block
*mblk
;
1919 register int lim
= marker_block_index
;
1920 register int num_free
= 0, num_used
= 0;
1922 marker_free_list
= 0;
1924 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1927 for (i
= 0; i
< lim
; i
++)
1929 Lisp_Object
*markword
;
1930 switch (mblk
->markers
[i
].type
)
1932 case Lisp_Misc_Marker
:
1933 markword
= &mblk
->markers
[i
].u_marker
.chain
;
1935 case Lisp_Misc_Buffer_Local_Value
:
1936 case Lisp_Misc_Some_Buffer_Local_Value
:
1937 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
1939 case Lisp_Misc_Overlay
:
1940 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
1946 if (markword
&& !XMARKBIT (*markword
))
1949 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1951 /* tem1 avoids Sun compiler bug */
1952 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
1953 XSETMARKER (tem
, tem1
);
1954 unchain_marker (tem
);
1956 /* We could leave the type alone, since nobody checks it,
1957 but this might catch bugs faster. */
1958 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
1959 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
1960 marker_free_list
= &mblk
->markers
[i
];
1967 XUNMARK (*markword
);
1970 lim
= MARKER_BLOCK_SIZE
;
1973 total_markers
= num_used
;
1974 total_free_markers
= num_free
;
1977 /* Free all unmarked buffers */
1979 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1982 if (!XMARKBIT (buffer
->name
))
1985 prev
->next
= buffer
->next
;
1987 all_buffers
= buffer
->next
;
1988 next
= buffer
->next
;
1994 XUNMARK (buffer
->name
);
1995 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
1998 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1999 for purposes of marking and relocation.
2000 Turn them back into C pointers now. */
2001 buffer
->upcase_table
2002 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2003 buffer
->downcase_table
2004 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2006 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2007 buffer
->folding_sort_table
2008 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2011 prev
= buffer
, buffer
= buffer
->next
;
2015 #endif /* standalone */
2017 /* Free all unmarked vectors */
2019 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2020 total_vector_size
= 0;
2023 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2026 prev
->next
= vector
->next
;
2028 all_vectors
= vector
->next
;
2029 next
= vector
->next
;
2035 vector
->size
&= ~ARRAY_MARK_FLAG
;
2036 total_vector_size
+= vector
->size
;
2037 prev
= vector
, vector
= vector
->next
;
2041 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2043 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2044 struct Lisp_String
*s
;
2048 s
= (struct Lisp_String
*) &sb
->chars
[0];
2049 if (s
->size
& ARRAY_MARK_FLAG
)
2051 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2052 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2053 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2054 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2055 prev
= sb
, sb
= sb
->next
;
2060 prev
->next
= sb
->next
;
2062 large_string_blocks
= sb
->next
;
2071 /* Compactify strings, relocate references, and free empty string blocks. */
2076 /* String block of old strings we are scanning. */
2077 register struct string_block
*from_sb
;
2078 /* A preceding string block (or maybe the same one)
2079 where we are copying the still-live strings to. */
2080 register struct string_block
*to_sb
;
2084 to_sb
= first_string_block
;
2087 /* Scan each existing string block sequentially, string by string. */
2088 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2091 /* POS is the index of the next string in the block. */
2092 while (pos
< from_sb
->pos
)
2094 register struct Lisp_String
*nextstr
2095 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2097 register struct Lisp_String
*newaddr
;
2098 register EMACS_INT size
= nextstr
->size
;
2100 /* NEXTSTR is the old address of the next string.
2101 Just skip it if it isn't marked. */
2102 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2104 /* It is marked, so its size field is really a chain of refs.
2105 Find the end of the chain, where the actual size lives. */
2106 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2108 if (size
& DONT_COPY_FLAG
)
2109 size
^= MARKBIT
| DONT_COPY_FLAG
;
2110 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2113 total_string_size
+= size
;
2115 /* If it won't fit in TO_SB, close it out,
2116 and move to the next sb. Keep doing so until
2117 TO_SB reaches a large enough, empty enough string block.
2118 We know that TO_SB cannot advance past FROM_SB here
2119 since FROM_SB is large enough to contain this string.
2120 Any string blocks skipped here
2121 will be patched out and freed later. */
2122 while (to_pos
+ STRING_FULLSIZE (size
)
2123 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2125 to_sb
->pos
= to_pos
;
2126 to_sb
= to_sb
->next
;
2129 /* Compute new address of this string
2130 and update TO_POS for the space being used. */
2131 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2132 to_pos
+= STRING_FULLSIZE (size
);
2134 /* Copy the string itself to the new place. */
2135 if (nextstr
!= newaddr
)
2136 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2137 + INTERVAL_PTR_SIZE
);
2139 /* Go through NEXTSTR's chain of references
2140 and make each slot in the chain point to
2141 the new address of this string. */
2142 size
= newaddr
->size
;
2143 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2145 register Lisp_Object
*objptr
;
2146 if (size
& DONT_COPY_FLAG
)
2147 size
^= MARKBIT
| DONT_COPY_FLAG
;
2148 objptr
= (Lisp_Object
*)size
;
2150 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2151 if (XMARKBIT (*objptr
))
2153 XSETSTRING (*objptr
, newaddr
);
2157 XSETSTRING (*objptr
, newaddr
);
2159 /* Store the actual size in the size field. */
2160 newaddr
->size
= size
;
2162 #ifdef USE_TEXT_PROPERTIES
2163 /* Now that the string has been relocated, rebalance its
2164 interval tree, and update the tree's parent pointer. */
2165 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2167 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2168 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2171 #endif /* USE_TEXT_PROPERTIES */
2173 pos
+= STRING_FULLSIZE (size
);
2177 /* Close out the last string block still used and free any that follow. */
2178 to_sb
->pos
= to_pos
;
2179 current_string_block
= to_sb
;
2181 from_sb
= to_sb
->next
;
2185 to_sb
= from_sb
->next
;
2190 /* Free any empty string blocks further back in the chain.
2191 This loop will never free first_string_block, but it is very
2192 unlikely that that one will become empty, so why bother checking? */
2194 from_sb
= first_string_block
;
2195 while (to_sb
= from_sb
->next
)
2197 if (to_sb
->pos
== 0)
2199 if (from_sb
->next
= to_sb
->next
)
2200 from_sb
->next
->prev
= from_sb
;
2208 /* Debugging aids. */
2210 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2211 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2212 This may be helpful in debugging Emacs's memory usage.\n\
2213 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2218 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2224 /* Initialization */
2228 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2231 pure_size
= PURESIZE
;
2234 ignore_warnings
= 1;
2239 #ifdef LISP_FLOAT_TYPE
2241 #endif /* LISP_FLOAT_TYPE */
2244 ignore_warnings
= 0;
2247 consing_since_gc
= 0;
2248 gc_cons_threshold
= 100000;
2249 #ifdef VIRT_ADDR_VARIES
2250 malloc_sbrk_unused
= 1<<22; /* A large number */
2251 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2252 #endif /* VIRT_ADDR_VARIES */
2263 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2264 "*Number of bytes of consing between garbage collections.\n\
2265 Garbage collection can happen automatically once this many bytes have been\n\
2266 allocated since the last garbage collection. All data types count.\n\n\
2267 Garbage collection happens automatically only when `eval' is called.\n\n\
2268 By binding this temporarily to a large number, you can effectively\n\
2269 prevent garbage collection during a part of the program.");
2271 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2272 "Number of bytes of sharable Lisp data allocated so far.");
2275 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2276 "Number of bytes of unshared memory allocated in this session.");
2278 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2279 "Number of bytes of unshared memory remaining available in this session.");
2282 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2283 "Non-nil means loading Lisp code in order to dump an executable.\n\
2284 This means that certain objects should be allocated in shared (pure) space.");
2286 DEFVAR_INT ("undo-limit", &undo_limit
,
2287 "Keep no more undo information once it exceeds this size.\n\
2288 This limit is applied when garbage collection happens.\n\
2289 The size is counted as the number of bytes occupied,\n\
2290 which includes both saved text and other data.");
2293 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2294 "Don't keep more than this much size of undo information.\n\
2295 A command which pushes past this size is itself forgotten.\n\
2296 This limit is applied when garbage collection happens.\n\
2297 The size is counted as the number of bytes occupied,\n\
2298 which includes both saved text and other data.");
2299 undo_strong_limit
= 30000;
2301 /* We build this in advance because if we wait until we need it, we might
2302 not be able to allocate the memory to hold it. */
2304 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted"), Qnil
));
2305 staticpro (&memory_signal_data
);
2310 defsubr (&Smake_byte_code
);
2311 defsubr (&Smake_list
);
2312 defsubr (&Smake_vector
);
2313 defsubr (&Smake_string
);
2314 defsubr (&Smake_symbol
);
2315 defsubr (&Smake_marker
);
2316 defsubr (&Spurecopy
);
2317 defsubr (&Sgarbage_collect
);
2318 defsubr (&Smemory_limit
);