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 (), mark_perdisplays ();
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
]);
1361 mark_perdisplays ();
1365 /* Clear the mark bits that we set in certain root slots. */
1367 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1368 for (i
= 0; i
< tail
->nvars
; i
++)
1369 XUNMARK (tail
->var
[i
]);
1370 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1372 XUNMARK (*backlist
->function
);
1373 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1376 i
= backlist
->nargs
- 1;
1378 XUNMARK (backlist
->args
[i
]);
1380 XUNMARK (buffer_defaults
.name
);
1381 XUNMARK (buffer_local_symbols
.name
);
1383 /* clear_marks (); */
1386 consing_since_gc
= 0;
1387 if (gc_cons_threshold
< 10000)
1388 gc_cons_threshold
= 10000;
1390 if (omessage
|| minibuf_level
> 0)
1391 message2_nolog (omessage
, omessage_length
);
1392 else if (!noninteractive
)
1393 message1_nolog ("Garbage collecting...done");
1395 return Fcons (Fcons (make_number (total_conses
),
1396 make_number (total_free_conses
)),
1397 Fcons (Fcons (make_number (total_symbols
),
1398 make_number (total_free_symbols
)),
1399 Fcons (Fcons (make_number (total_markers
),
1400 make_number (total_free_markers
)),
1401 Fcons (make_number (total_string_size
),
1402 Fcons (make_number (total_vector_size
),
1404 #ifdef LISP_FLOAT_TYPE
1405 Fcons (Fcons (make_number (total_floats
),
1406 make_number (total_free_floats
)),
1408 #else /* not LISP_FLOAT_TYPE */
1410 #endif /* not LISP_FLOAT_TYPE */
1418 /* Clear marks on all conses */
1420 register struct cons_block
*cblk
;
1421 register int lim
= cons_block_index
;
1423 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1426 for (i
= 0; i
< lim
; i
++)
1427 XUNMARK (cblk
->conses
[i
].car
);
1428 lim
= CONS_BLOCK_SIZE
;
1431 /* Clear marks on all symbols */
1433 register struct symbol_block
*sblk
;
1434 register int lim
= symbol_block_index
;
1436 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1439 for (i
= 0; i
< lim
; i
++)
1441 XUNMARK (sblk
->symbols
[i
].plist
);
1443 lim
= SYMBOL_BLOCK_SIZE
;
1446 /* Clear marks on all markers */
1448 register struct marker_block
*sblk
;
1449 register int lim
= marker_block_index
;
1451 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1454 for (i
= 0; i
< lim
; i
++)
1455 if (sblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1456 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1457 lim
= MARKER_BLOCK_SIZE
;
1460 /* Clear mark bits on all buffers */
1462 register struct buffer
*nextb
= all_buffers
;
1466 XUNMARK (nextb
->name
);
1467 nextb
= nextb
->next
;
1473 /* Mark reference to a Lisp_Object.
1474 If the object referred to has not been seen yet, recursively mark
1475 all the references contained in it.
1477 If the object referenced is a short string, the referencing slot
1478 is threaded into a chain of such slots, pointed to from
1479 the `size' field of the string. The actual string size
1480 lives in the last slot in the chain. We recognize the end
1481 because it is < (unsigned) STRING_BLOCK_SIZE. */
1483 #define LAST_MARKED_SIZE 500
1484 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1485 int last_marked_index
;
1488 mark_object (objptr
)
1489 Lisp_Object
*objptr
;
1491 register Lisp_Object obj
;
1498 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1499 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1502 last_marked
[last_marked_index
++] = objptr
;
1503 if (last_marked_index
== LAST_MARKED_SIZE
)
1504 last_marked_index
= 0;
1506 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1510 register struct Lisp_String
*ptr
= XSTRING (obj
);
1512 MARK_INTERVAL_TREE (ptr
->intervals
);
1513 if (ptr
->size
& MARKBIT
)
1514 /* A large string. Just set ARRAY_MARK_FLAG. */
1515 ptr
->size
|= ARRAY_MARK_FLAG
;
1518 /* A small string. Put this reference
1519 into the chain of references to it.
1520 If the address includes MARKBIT, put that bit elsewhere
1521 when we store OBJPTR into the size field. */
1523 if (XMARKBIT (*objptr
))
1525 XSETFASTINT (*objptr
, ptr
->size
);
1529 XSETFASTINT (*objptr
, ptr
->size
);
1531 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1533 ptr
->size
= (EMACS_INT
) objptr
;
1534 if (ptr
->size
& MARKBIT
)
1535 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1540 case Lisp_Vectorlike
:
1541 if (GC_BUFFERP (obj
))
1543 if (!XMARKBIT (XBUFFER (obj
)->name
))
1546 else if (GC_SUBRP (obj
))
1548 else if (GC_COMPILEDP (obj
))
1549 /* We could treat this just like a vector, but it is better
1550 to save the COMPILED_CONSTANTS element for last and avoid recursion
1553 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1554 register EMACS_INT size
= ptr
->size
;
1555 /* See comment above under Lisp_Vector. */
1556 struct Lisp_Vector
*volatile ptr1
= ptr
;
1559 if (size
& ARRAY_MARK_FLAG
)
1560 break; /* Already marked */
1561 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1562 size
&= PSEUDOVECTOR_SIZE_MASK
;
1563 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1565 if (i
!= COMPILED_CONSTANTS
)
1566 mark_object (&ptr1
->contents
[i
]);
1568 /* This cast should be unnecessary, but some Mips compiler complains
1569 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1570 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1574 else if (GC_FRAMEP (obj
))
1576 /* See comment above under Lisp_Vector for why this is volatile. */
1577 register struct frame
*volatile ptr
= XFRAME (obj
);
1578 register EMACS_INT size
= ptr
->size
;
1580 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1581 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1583 mark_object (&ptr
->name
);
1584 mark_object (&ptr
->focus_frame
);
1585 mark_object (&ptr
->selected_window
);
1586 mark_object (&ptr
->minibuffer_window
);
1587 mark_object (&ptr
->param_alist
);
1588 mark_object (&ptr
->scroll_bars
);
1589 mark_object (&ptr
->condemned_scroll_bars
);
1590 mark_object (&ptr
->menu_bar_items
);
1591 mark_object (&ptr
->face_alist
);
1592 mark_object (&ptr
->menu_bar_vector
);
1593 mark_object (&ptr
->buffer_predicate
);
1595 #endif /* MULTI_FRAME */
1598 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1599 register EMACS_INT size
= ptr
->size
;
1600 /* The reason we use ptr1 is to avoid an apparent hardware bug
1601 that happens occasionally on the FSF's HP 300s.
1602 The bug is that a2 gets clobbered by recursive calls to mark_object.
1603 The clobberage seems to happen during function entry,
1604 perhaps in the moveml instruction.
1605 Yes, this is a crock, but we have to do it. */
1606 struct Lisp_Vector
*volatile ptr1
= ptr
;
1609 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1610 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1611 if (size
& PSEUDOVECTOR_FLAG
)
1612 size
&= PSEUDOVECTOR_SIZE_MASK
;
1613 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1614 mark_object (&ptr1
->contents
[i
]);
1620 /* See comment above under Lisp_Vector for why this is volatile. */
1621 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1622 struct Lisp_Symbol
*ptrx
;
1624 if (XMARKBIT (ptr
->plist
)) break;
1626 mark_object ((Lisp_Object
*) &ptr
->value
);
1627 mark_object (&ptr
->function
);
1628 mark_object (&ptr
->plist
);
1629 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1630 mark_object (&ptr
->name
);
1634 /* For the benefit of the last_marked log. */
1635 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1636 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1637 XSETSYMBOL (obj
, ptrx
);
1638 /* We can't goto loop here because *objptr doesn't contain an
1639 actual Lisp_Object with valid datatype field. */
1646 switch (XMISC (obj
)->type
)
1648 case Lisp_Misc_Marker
:
1649 XMARK (XMARKER (obj
)->chain
);
1650 /* DO NOT mark thru the marker's chain.
1651 The buffer's markers chain does not preserve markers from gc;
1652 instead, markers are removed from the chain when freed by gc. */
1655 case Lisp_Misc_Buffer_Local_Value
:
1656 case Lisp_Misc_Some_Buffer_Local_Value
:
1658 register struct Lisp_Buffer_Local_Value
*ptr
1659 = XBUFFER_LOCAL_VALUE (obj
);
1660 if (XMARKBIT (ptr
->car
)) break;
1662 /* If the cdr is nil, avoid recursion for the car. */
1663 if (EQ (ptr
->cdr
, Qnil
))
1668 mark_object (&ptr
->car
);
1669 /* See comment above under Lisp_Vector for why not use ptr here. */
1670 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1674 case Lisp_Misc_Intfwd
:
1675 case Lisp_Misc_Boolfwd
:
1676 case Lisp_Misc_Objfwd
:
1677 case Lisp_Misc_Buffer_Objfwd
:
1678 case Lisp_Misc_Display_Objfwd
:
1679 /* Don't bother with Lisp_Buffer_Objfwd,
1680 since all markable slots in current buffer marked anyway. */
1681 /* Don't need to do Lisp_Objfwd, since the places they point
1682 are protected with staticpro. */
1685 case Lisp_Misc_Overlay
:
1687 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1688 if (!XMARKBIT (ptr
->plist
))
1691 mark_object (&ptr
->start
);
1692 mark_object (&ptr
->end
);
1693 objptr
= &ptr
->plist
;
1706 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1707 if (XMARKBIT (ptr
->car
)) break;
1709 /* If the cdr is nil, avoid recursion for the car. */
1710 if (EQ (ptr
->cdr
, Qnil
))
1715 mark_object (&ptr
->car
);
1716 /* See comment above under Lisp_Vector for why not use ptr here. */
1717 objptr
= &XCONS (obj
)->cdr
;
1721 #ifdef LISP_FLOAT_TYPE
1723 XMARK (XFLOAT (obj
)->type
);
1725 #endif /* LISP_FLOAT_TYPE */
1735 /* Mark the pointers in a buffer structure. */
1741 register struct buffer
*buffer
= XBUFFER (buf
);
1742 register Lisp_Object
*ptr
;
1743 Lisp_Object base_buffer
;
1745 /* This is the buffer's markbit */
1746 mark_object (&buffer
->name
);
1747 XMARK (buffer
->name
);
1749 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1752 mark_object (buffer
->syntax_table
);
1754 /* Mark the various string-pointers in the buffer object.
1755 Since the strings may be relocated, we must mark them
1756 in their actual slots. So gc_sweep must convert each slot
1757 back to an ordinary C pointer. */
1758 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1759 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1760 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1761 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1763 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1764 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1765 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1766 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1769 for (ptr
= &buffer
->name
+ 1;
1770 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1774 /* If this is an indirect buffer, mark its base buffer. */
1775 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1777 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1778 mark_buffer (base_buffer
);
1783 /* Mark the pointers in the perdisplay objects. */
1789 for (perd
= all_perdisplays
; perd
; perd
= perd
->next_perdisplay
)
1791 mark_object (&perd
->Vprefix_arg
);
1792 mark_object (&perd
->Vcurrent_prefix_arg
);
1793 mark_object (&perd
->kbd_buffer_frame_or_window
);
1797 /* Sweep: find all structures not marked, and free them. */
1802 total_string_size
= 0;
1805 /* Put all unmarked conses on free list */
1807 register struct cons_block
*cblk
;
1808 register int lim
= cons_block_index
;
1809 register int num_free
= 0, num_used
= 0;
1813 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1816 for (i
= 0; i
< lim
; i
++)
1817 if (!XMARKBIT (cblk
->conses
[i
].car
))
1820 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1821 cons_free_list
= &cblk
->conses
[i
];
1826 XUNMARK (cblk
->conses
[i
].car
);
1828 lim
= CONS_BLOCK_SIZE
;
1830 total_conses
= num_used
;
1831 total_free_conses
= num_free
;
1834 #ifdef LISP_FLOAT_TYPE
1835 /* Put all unmarked floats on free list */
1837 register struct float_block
*fblk
;
1838 register int lim
= float_block_index
;
1839 register int num_free
= 0, num_used
= 0;
1841 float_free_list
= 0;
1843 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1846 for (i
= 0; i
< lim
; i
++)
1847 if (!XMARKBIT (fblk
->floats
[i
].type
))
1850 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1851 float_free_list
= &fblk
->floats
[i
];
1856 XUNMARK (fblk
->floats
[i
].type
);
1858 lim
= FLOAT_BLOCK_SIZE
;
1860 total_floats
= num_used
;
1861 total_free_floats
= num_free
;
1863 #endif /* LISP_FLOAT_TYPE */
1865 #ifdef USE_TEXT_PROPERTIES
1866 /* Put all unmarked intervals on free list */
1868 register struct interval_block
*iblk
;
1869 register int lim
= interval_block_index
;
1870 register int num_free
= 0, num_used
= 0;
1872 interval_free_list
= 0;
1874 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1878 for (i
= 0; i
< lim
; i
++)
1880 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1882 iblk
->intervals
[i
].parent
= interval_free_list
;
1883 interval_free_list
= &iblk
->intervals
[i
];
1889 XUNMARK (iblk
->intervals
[i
].plist
);
1892 lim
= INTERVAL_BLOCK_SIZE
;
1894 total_intervals
= num_used
;
1895 total_free_intervals
= num_free
;
1897 #endif /* USE_TEXT_PROPERTIES */
1899 /* Put all unmarked symbols on free list */
1901 register struct symbol_block
*sblk
;
1902 register int lim
= symbol_block_index
;
1903 register int num_free
= 0, num_used
= 0;
1905 symbol_free_list
= 0;
1907 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1910 for (i
= 0; i
< lim
; i
++)
1911 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1913 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
1914 symbol_free_list
= &sblk
->symbols
[i
];
1920 sblk
->symbols
[i
].name
1921 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1922 XUNMARK (sblk
->symbols
[i
].plist
);
1924 lim
= SYMBOL_BLOCK_SIZE
;
1926 total_symbols
= num_used
;
1927 total_free_symbols
= num_free
;
1931 /* Put all unmarked markers on free list.
1932 Dechain each one first from the buffer it points into,
1933 but only if it's a real marker. */
1935 register struct marker_block
*mblk
;
1936 register int lim
= marker_block_index
;
1937 register int num_free
= 0, num_used
= 0;
1939 marker_free_list
= 0;
1941 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1944 for (i
= 0; i
< lim
; i
++)
1946 Lisp_Object
*markword
;
1947 switch (mblk
->markers
[i
].type
)
1949 case Lisp_Misc_Marker
:
1950 markword
= &mblk
->markers
[i
].u_marker
.chain
;
1952 case Lisp_Misc_Buffer_Local_Value
:
1953 case Lisp_Misc_Some_Buffer_Local_Value
:
1954 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
1956 case Lisp_Misc_Overlay
:
1957 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
1963 if (markword
&& !XMARKBIT (*markword
))
1966 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1968 /* tem1 avoids Sun compiler bug */
1969 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
1970 XSETMARKER (tem
, tem1
);
1971 unchain_marker (tem
);
1973 /* We could leave the type alone, since nobody checks it,
1974 but this might catch bugs faster. */
1975 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
1976 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
1977 marker_free_list
= &mblk
->markers
[i
];
1984 XUNMARK (*markword
);
1987 lim
= MARKER_BLOCK_SIZE
;
1990 total_markers
= num_used
;
1991 total_free_markers
= num_free
;
1994 /* Free all unmarked buffers */
1996 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1999 if (!XMARKBIT (buffer
->name
))
2002 prev
->next
= buffer
->next
;
2004 all_buffers
= buffer
->next
;
2005 next
= buffer
->next
;
2011 XUNMARK (buffer
->name
);
2012 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2015 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2016 for purposes of marking and relocation.
2017 Turn them back into C pointers now. */
2018 buffer
->upcase_table
2019 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2020 buffer
->downcase_table
2021 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2023 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2024 buffer
->folding_sort_table
2025 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2028 prev
= buffer
, buffer
= buffer
->next
;
2032 #endif /* standalone */
2034 /* Free all unmarked vectors */
2036 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2037 total_vector_size
= 0;
2040 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2043 prev
->next
= vector
->next
;
2045 all_vectors
= vector
->next
;
2046 next
= vector
->next
;
2052 vector
->size
&= ~ARRAY_MARK_FLAG
;
2053 total_vector_size
+= vector
->size
;
2054 prev
= vector
, vector
= vector
->next
;
2058 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2060 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2061 struct Lisp_String
*s
;
2065 s
= (struct Lisp_String
*) &sb
->chars
[0];
2066 if (s
->size
& ARRAY_MARK_FLAG
)
2068 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2069 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2070 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2071 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2072 prev
= sb
, sb
= sb
->next
;
2077 prev
->next
= sb
->next
;
2079 large_string_blocks
= sb
->next
;
2088 /* Compactify strings, relocate references, and free empty string blocks. */
2093 /* String block of old strings we are scanning. */
2094 register struct string_block
*from_sb
;
2095 /* A preceding string block (or maybe the same one)
2096 where we are copying the still-live strings to. */
2097 register struct string_block
*to_sb
;
2101 to_sb
= first_string_block
;
2104 /* Scan each existing string block sequentially, string by string. */
2105 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2108 /* POS is the index of the next string in the block. */
2109 while (pos
< from_sb
->pos
)
2111 register struct Lisp_String
*nextstr
2112 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2114 register struct Lisp_String
*newaddr
;
2115 register EMACS_INT size
= nextstr
->size
;
2117 /* NEXTSTR is the old address of the next string.
2118 Just skip it if it isn't marked. */
2119 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2121 /* It is marked, so its size field is really a chain of refs.
2122 Find the end of the chain, where the actual size lives. */
2123 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2125 if (size
& DONT_COPY_FLAG
)
2126 size
^= MARKBIT
| DONT_COPY_FLAG
;
2127 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2130 total_string_size
+= size
;
2132 /* If it won't fit in TO_SB, close it out,
2133 and move to the next sb. Keep doing so until
2134 TO_SB reaches a large enough, empty enough string block.
2135 We know that TO_SB cannot advance past FROM_SB here
2136 since FROM_SB is large enough to contain this string.
2137 Any string blocks skipped here
2138 will be patched out and freed later. */
2139 while (to_pos
+ STRING_FULLSIZE (size
)
2140 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2142 to_sb
->pos
= to_pos
;
2143 to_sb
= to_sb
->next
;
2146 /* Compute new address of this string
2147 and update TO_POS for the space being used. */
2148 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2149 to_pos
+= STRING_FULLSIZE (size
);
2151 /* Copy the string itself to the new place. */
2152 if (nextstr
!= newaddr
)
2153 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2154 + INTERVAL_PTR_SIZE
);
2156 /* Go through NEXTSTR's chain of references
2157 and make each slot in the chain point to
2158 the new address of this string. */
2159 size
= newaddr
->size
;
2160 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2162 register Lisp_Object
*objptr
;
2163 if (size
& DONT_COPY_FLAG
)
2164 size
^= MARKBIT
| DONT_COPY_FLAG
;
2165 objptr
= (Lisp_Object
*)size
;
2167 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2168 if (XMARKBIT (*objptr
))
2170 XSETSTRING (*objptr
, newaddr
);
2174 XSETSTRING (*objptr
, newaddr
);
2176 /* Store the actual size in the size field. */
2177 newaddr
->size
= size
;
2179 #ifdef USE_TEXT_PROPERTIES
2180 /* Now that the string has been relocated, rebalance its
2181 interval tree, and update the tree's parent pointer. */
2182 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2184 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2185 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2188 #endif /* USE_TEXT_PROPERTIES */
2190 pos
+= STRING_FULLSIZE (size
);
2194 /* Close out the last string block still used and free any that follow. */
2195 to_sb
->pos
= to_pos
;
2196 current_string_block
= to_sb
;
2198 from_sb
= to_sb
->next
;
2202 to_sb
= from_sb
->next
;
2207 /* Free any empty string blocks further back in the chain.
2208 This loop will never free first_string_block, but it is very
2209 unlikely that that one will become empty, so why bother checking? */
2211 from_sb
= first_string_block
;
2212 while (to_sb
= from_sb
->next
)
2214 if (to_sb
->pos
== 0)
2216 if (from_sb
->next
= to_sb
->next
)
2217 from_sb
->next
->prev
= from_sb
;
2225 /* Debugging aids. */
2227 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2228 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2229 This may be helpful in debugging Emacs's memory usage.\n\
2230 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2235 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2241 /* Initialization */
2245 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2248 pure_size
= PURESIZE
;
2251 ignore_warnings
= 1;
2256 #ifdef LISP_FLOAT_TYPE
2258 #endif /* LISP_FLOAT_TYPE */
2261 ignore_warnings
= 0;
2264 consing_since_gc
= 0;
2265 gc_cons_threshold
= 100000;
2266 #ifdef VIRT_ADDR_VARIES
2267 malloc_sbrk_unused
= 1<<22; /* A large number */
2268 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2269 #endif /* VIRT_ADDR_VARIES */
2280 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2281 "*Number of bytes of consing between garbage collections.\n\
2282 Garbage collection can happen automatically once this many bytes have been\n\
2283 allocated since the last garbage collection. All data types count.\n\n\
2284 Garbage collection happens automatically only when `eval' is called.\n\n\
2285 By binding this temporarily to a large number, you can effectively\n\
2286 prevent garbage collection during a part of the program.");
2288 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2289 "Number of bytes of sharable Lisp data allocated so far.");
2292 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2293 "Number of bytes of unshared memory allocated in this session.");
2295 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2296 "Number of bytes of unshared memory remaining available in this session.");
2299 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2300 "Non-nil means loading Lisp code in order to dump an executable.\n\
2301 This means that certain objects should be allocated in shared (pure) space.");
2303 DEFVAR_INT ("undo-limit", &undo_limit
,
2304 "Keep no more undo information once it exceeds this size.\n\
2305 This limit is applied when garbage collection happens.\n\
2306 The size is counted as the number of bytes occupied,\n\
2307 which includes both saved text and other data.");
2310 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2311 "Don't keep more than this much size of undo information.\n\
2312 A command which pushes past this size is itself forgotten.\n\
2313 This limit is applied when garbage collection happens.\n\
2314 The size is counted as the number of bytes occupied,\n\
2315 which includes both saved text and other data.");
2316 undo_strong_limit
= 30000;
2318 /* We build this in advance because if we wait until we need it, we might
2319 not be able to allocate the memory to hold it. */
2321 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted"), Qnil
));
2322 staticpro (&memory_signal_data
);
2327 defsubr (&Smake_byte_code
);
2328 defsubr (&Smake_list
);
2329 defsubr (&Smake_vector
);
2330 defsubr (&Smake_string
);
2331 defsubr (&Smake_symbol
);
2332 defsubr (&Smake_marker
);
2333 defsubr (&Spurecopy
);
2334 defsubr (&Sgarbage_collect
);
2335 defsubr (&Smemory_limit
);