1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993 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 XSET (val, Lisp_Cons, (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 int pure
[PURESIZE
/ sizeof (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 /* Maximum amount of C stack to save when a GC happens. */
103 #ifndef MAX_SAVE_STACK
104 #define MAX_SAVE_STACK 16000
107 /* Buffer in which we save a copy of the C stack at each GC. */
112 /* Non-zero means ignore malloc warnings. Set during initialization. */
115 static void mark_object (), mark_buffer ();
116 static void clear_marks (), gc_sweep ();
117 static void compact_strings ();
119 /* Versions of malloc and realloc that print warnings as memory gets full. */
122 malloc_warning_1 (str
)
125 Fprinc (str
, Vstandard_output
);
126 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
127 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
128 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
132 /* malloc calls this if it finds we are near exhausting storage */
136 pending_malloc_warning
= str
;
139 display_malloc_warning ()
141 register Lisp_Object val
;
143 val
= build_string (pending_malloc_warning
);
144 pending_malloc_warning
= 0;
145 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
148 /* Called if malloc returns zero */
151 error ("Memory exhausted");
154 /* like malloc routines but check for no memory and block interrupt input. */
163 val
= (long *) malloc (size
);
166 if (!val
&& size
) memory_full ();
171 xrealloc (block
, size
)
178 /* We must call malloc explicitly when BLOCK is 0, since some
179 reallocs don't do this. */
181 val
= (long *) malloc (size
);
183 val
= (long *) realloc (block
, size
);
186 if (!val
&& size
) memory_full ();
200 /* Arranging to disable input signals while we're in malloc.
202 This only works with GNU malloc. To help out systems which can't
203 use GNU malloc, all the calls to malloc, realloc, and free
204 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
205 pairs; unfortunately, we have no idea what C library functions
206 might call malloc, so we can't really protect them unless you're
207 using GNU malloc. Fortunately, most of the major operating can use
210 #ifndef SYSTEM_MALLOC
211 extern void * (*__malloc_hook
) ();
212 static void * (*old_malloc_hook
) ();
213 extern void * (*__realloc_hook
) ();
214 static void * (*old_realloc_hook
) ();
215 extern void (*__free_hook
) ();
216 static void (*old_free_hook
) ();
219 emacs_blocked_free (ptr
)
223 __free_hook
= old_free_hook
;
225 __free_hook
= emacs_blocked_free
;
230 emacs_blocked_malloc (size
)
236 __malloc_hook
= old_malloc_hook
;
237 value
= (void *) malloc (size
);
238 __malloc_hook
= emacs_blocked_malloc
;
245 emacs_blocked_realloc (ptr
, size
)
252 __realloc_hook
= old_realloc_hook
;
253 value
= (void *) realloc (ptr
, size
);
254 __realloc_hook
= emacs_blocked_realloc
;
261 uninterrupt_malloc ()
263 old_free_hook
= __free_hook
;
264 __free_hook
= emacs_blocked_free
;
266 old_malloc_hook
= __malloc_hook
;
267 __malloc_hook
= emacs_blocked_malloc
;
269 old_realloc_hook
= __realloc_hook
;
270 __realloc_hook
= emacs_blocked_realloc
;
274 /* Interval allocation. */
276 #ifdef USE_TEXT_PROPERTIES
277 #define INTERVAL_BLOCK_SIZE \
278 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
280 struct interval_block
282 struct interval_block
*next
;
283 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
286 struct interval_block
*interval_block
;
287 static int interval_block_index
;
289 INTERVAL interval_free_list
;
295 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
296 interval_block
->next
= 0;
297 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
298 interval_block_index
= 0;
299 interval_free_list
= 0;
302 #define INIT_INTERVALS init_intervals ()
309 if (interval_free_list
)
311 val
= interval_free_list
;
312 interval_free_list
= interval_free_list
->parent
;
316 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
318 register struct interval_block
*newi
319 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
321 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
322 newi
->next
= interval_block
;
323 interval_block
= newi
;
324 interval_block_index
= 0;
326 val
= &interval_block
->intervals
[interval_block_index
++];
328 consing_since_gc
+= sizeof (struct interval
);
329 RESET_INTERVAL (val
);
333 static int total_free_intervals
, total_intervals
;
335 /* Mark the pointers of one interval. */
338 mark_interval (i
, dummy
)
342 if (XMARKBIT (i
->plist
))
344 mark_object (&i
->plist
);
349 mark_interval_tree (tree
)
350 register INTERVAL tree
;
352 /* No need to test if this tree has been marked already; this
353 function is always called through the MARK_INTERVAL_TREE macro,
354 which takes care of that. */
356 /* XMARK expands to an assignment; the LHS of an assignment can't be
358 XMARK (* (Lisp_Object
*) &tree
->parent
);
360 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
363 #define MARK_INTERVAL_TREE(i) \
365 if (!NULL_INTERVAL_P (i) \
366 && ! XMARKBIT ((Lisp_Object) i->parent)) \
367 mark_interval_tree (i); \
370 /* The oddity in the call to XUNMARK is necessary because XUNMARK
371 expands to an assignment to its argument, and most C compilers don't
372 support casts on the left operand of `='. */
373 #define UNMARK_BALANCE_INTERVALS(i) \
375 if (! NULL_INTERVAL_P (i)) \
377 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
378 (i) = balance_intervals (i); \
382 #else /* no interval use */
384 #define INIT_INTERVALS
386 #define UNMARK_BALANCE_INTERVALS(i)
387 #define MARK_INTERVAL_TREE(i)
389 #endif /* no interval use */
391 /* Floating point allocation. */
393 #ifdef LISP_FLOAT_TYPE
394 /* Allocation of float cells, just like conses */
395 /* We store float cells inside of float_blocks, allocating a new
396 float_block with malloc whenever necessary. Float cells reclaimed by
397 GC are put on a free list to be reallocated before allocating
398 any new float cells from the latest float_block.
400 Each float_block is just under 1020 bytes long,
401 since malloc really allocates in units of powers of two
402 and uses 4 bytes for its own overhead. */
404 #define FLOAT_BLOCK_SIZE \
405 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
409 struct float_block
*next
;
410 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
413 struct float_block
*float_block
;
414 int float_block_index
;
416 struct Lisp_Float
*float_free_list
;
421 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
422 float_block
->next
= 0;
423 bzero (float_block
->floats
, sizeof float_block
->floats
);
424 float_block_index
= 0;
428 /* Explicitly free a float cell. */
430 struct Lisp_Float
*ptr
;
432 XFASTINT (ptr
->type
) = (int) float_free_list
;
433 float_free_list
= ptr
;
437 make_float (float_value
)
440 register Lisp_Object val
;
444 XSET (val
, Lisp_Float
, float_free_list
);
445 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
449 if (float_block_index
== FLOAT_BLOCK_SIZE
)
451 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
452 VALIDATE_LISP_STORAGE (new, sizeof *new);
453 new->next
= float_block
;
455 float_block_index
= 0;
457 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
459 XFLOAT (val
)->data
= float_value
;
460 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
461 consing_since_gc
+= sizeof (struct Lisp_Float
);
465 #endif /* LISP_FLOAT_TYPE */
467 /* Allocation of cons cells */
468 /* We store cons cells inside of cons_blocks, allocating a new
469 cons_block with malloc whenever necessary. Cons cells reclaimed by
470 GC are put on a free list to be reallocated before allocating
471 any new cons cells from the latest cons_block.
473 Each cons_block is just under 1020 bytes long,
474 since malloc really allocates in units of powers of two
475 and uses 4 bytes for its own overhead. */
477 #define CONS_BLOCK_SIZE \
478 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
482 struct cons_block
*next
;
483 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
486 struct cons_block
*cons_block
;
487 int cons_block_index
;
489 struct Lisp_Cons
*cons_free_list
;
494 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
495 cons_block
->next
= 0;
496 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
497 cons_block_index
= 0;
501 /* Explicitly free a cons cell. */
503 struct Lisp_Cons
*ptr
;
505 XFASTINT (ptr
->car
) = (int) cons_free_list
;
506 cons_free_list
= ptr
;
509 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
510 "Create a new cons, give it CAR and CDR as components, and return it.")
512 Lisp_Object car
, cdr
;
514 register Lisp_Object val
;
518 XSET (val
, Lisp_Cons
, cons_free_list
);
519 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
523 if (cons_block_index
== CONS_BLOCK_SIZE
)
525 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
526 VALIDATE_LISP_STORAGE (new, sizeof *new);
527 new->next
= cons_block
;
529 cons_block_index
= 0;
531 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
533 XCONS (val
)->car
= car
;
534 XCONS (val
)->cdr
= cdr
;
535 consing_since_gc
+= sizeof (struct Lisp_Cons
);
539 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
540 "Return a newly created list with specified arguments as elements.\n\
541 Any number of arguments, even zero arguments, are allowed.")
544 register Lisp_Object
*args
;
546 register Lisp_Object len
, val
, val_tail
;
548 XFASTINT (len
) = nargs
;
549 val
= Fmake_list (len
, Qnil
);
551 while (!NILP (val_tail
))
553 XCONS (val_tail
)->car
= *args
++;
554 val_tail
= XCONS (val_tail
)->cdr
;
559 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
560 "Return a newly created list of length LENGTH, with each element being INIT.")
562 register Lisp_Object length
, init
;
564 register Lisp_Object val
;
567 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
568 length
= wrong_type_argument (Qnatnump
, length
);
569 size
= XINT (length
);
573 val
= Fcons (init
, val
);
577 /* Allocation of vectors */
579 struct Lisp_Vector
*all_vectors
;
581 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
582 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
583 See also the function `vector'.")
585 register Lisp_Object length
, init
;
587 register int sizei
, index
;
588 register Lisp_Object vector
;
589 register struct Lisp_Vector
*p
;
591 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
592 length
= wrong_type_argument (Qnatnump
, length
);
593 sizei
= XINT (length
);
595 p
= (struct Lisp_Vector
*) xmalloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
596 VALIDATE_LISP_STORAGE (p
, 0);
598 XSET (vector
, Lisp_Vector
, p
);
599 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
602 p
->next
= all_vectors
;
605 for (index
= 0; index
< sizei
; index
++)
606 p
->contents
[index
] = init
;
611 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
612 "Return a newly created vector with specified arguments as elements.\n\
613 Any number of arguments, even zero arguments, are allowed.")
618 register Lisp_Object len
, val
;
620 register struct Lisp_Vector
*p
;
622 XFASTINT (len
) = nargs
;
623 val
= Fmake_vector (len
, Qnil
);
625 for (index
= 0; index
< nargs
; index
++)
626 p
->contents
[index
] = args
[index
];
630 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
631 "Create a byte-code object with specified arguments as elements.\n\
632 The arguments should be the arglist, bytecode-string, constant vector,\n\
633 stack size, (optional) doc string, and (optional) interactive spec.\n\
634 The first four arguments are required; at most six have any\n\
640 register Lisp_Object len
, val
;
642 register struct Lisp_Vector
*p
;
644 XFASTINT (len
) = nargs
;
645 if (!NILP (Vpurify_flag
))
646 val
= make_pure_vector (len
);
648 val
= Fmake_vector (len
, Qnil
);
650 for (index
= 0; index
< nargs
; index
++)
652 if (!NILP (Vpurify_flag
))
653 args
[index
] = Fpurecopy (args
[index
]);
654 p
->contents
[index
] = args
[index
];
656 XSETTYPE (val
, Lisp_Compiled
);
660 /* Allocation of symbols.
661 Just like allocation of conses!
663 Each symbol_block is just under 1020 bytes long,
664 since malloc really allocates in units of powers of two
665 and uses 4 bytes for its own overhead. */
667 #define SYMBOL_BLOCK_SIZE \
668 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
672 struct symbol_block
*next
;
673 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
676 struct symbol_block
*symbol_block
;
677 int symbol_block_index
;
679 struct Lisp_Symbol
*symbol_free_list
;
684 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
685 symbol_block
->next
= 0;
686 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
687 symbol_block_index
= 0;
688 symbol_free_list
= 0;
691 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
692 "Return a newly allocated uninterned symbol whose name is NAME.\n\
693 Its value and function definition are void, and its property list is nil.")
697 register Lisp_Object val
;
698 register struct Lisp_Symbol
*p
;
700 CHECK_STRING (str
, 0);
702 if (symbol_free_list
)
704 XSET (val
, Lisp_Symbol
, symbol_free_list
);
706 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
710 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
712 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
713 VALIDATE_LISP_STORAGE (new, sizeof *new);
714 new->next
= symbol_block
;
716 symbol_block_index
= 0;
718 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
721 p
->name
= XSTRING (str
);
724 p
->function
= Qunbound
;
726 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
730 /* Allocation of markers.
731 Works like allocation of conses. */
733 #define MARKER_BLOCK_SIZE \
734 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
738 struct marker_block
*next
;
739 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
742 struct marker_block
*marker_block
;
743 int marker_block_index
;
745 struct Lisp_Marker
*marker_free_list
;
750 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
751 marker_block
->next
= 0;
752 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
753 marker_block_index
= 0;
754 marker_free_list
= 0;
757 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
758 "Return a newly allocated marker which does not point at any place.")
761 register Lisp_Object val
;
762 register struct Lisp_Marker
*p
;
764 if (marker_free_list
)
766 XSET (val
, Lisp_Marker
, marker_free_list
);
768 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
772 if (marker_block_index
== MARKER_BLOCK_SIZE
)
774 struct marker_block
*new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
775 VALIDATE_LISP_STORAGE (new, sizeof *new);
776 new->next
= marker_block
;
778 marker_block_index
= 0;
780 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
786 consing_since_gc
+= sizeof (struct Lisp_Marker
);
790 /* Allocation of strings */
792 /* Strings reside inside of string_blocks. The entire data of the string,
793 both the size and the contents, live in part of the `chars' component of a string_block.
794 The `pos' component is the index within `chars' of the first free byte.
796 first_string_block points to the first string_block ever allocated.
797 Each block points to the next one with its `next' field.
798 The `prev' fields chain in reverse order.
799 The last one allocated is the one currently being filled.
800 current_string_block points to it.
802 The string_blocks that hold individual large strings
803 go in a separate chain, started by large_string_blocks. */
806 /* String blocks contain this many useful bytes.
807 8188 is power of 2, minus 4 for malloc overhead. */
808 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
810 /* A string bigger than this gets its own specially-made string block
811 if it doesn't fit in the current one. */
812 #define STRING_BLOCK_OUTSIZE 1024
814 struct string_block_head
816 struct string_block
*next
, *prev
;
822 struct string_block
*next
, *prev
;
824 char chars
[STRING_BLOCK_SIZE
];
827 /* This points to the string block we are now allocating strings. */
829 struct string_block
*current_string_block
;
831 /* This points to the oldest string block, the one that starts the chain. */
833 struct string_block
*first_string_block
;
835 /* Last string block in chain of those made for individual large strings. */
837 struct string_block
*large_string_blocks
;
839 /* If SIZE is the length of a string, this returns how many bytes
840 the string occupies in a string_block (including padding). */
842 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
844 #define PAD (sizeof (int))
847 #define STRING_FULLSIZE(SIZE) \
848 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
854 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
855 first_string_block
= current_string_block
;
856 consing_since_gc
+= sizeof (struct string_block
);
857 current_string_block
->next
= 0;
858 current_string_block
->prev
= 0;
859 current_string_block
->pos
= 0;
860 large_string_blocks
= 0;
863 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
864 "Return a newly created string of length LENGTH, with each element being INIT.\n\
865 Both LENGTH and INIT must be numbers.")
867 Lisp_Object length
, init
;
869 register Lisp_Object val
;
870 register unsigned char *p
, *end
, c
;
872 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
873 length
= wrong_type_argument (Qnatnump
, length
);
874 CHECK_NUMBER (init
, 1);
875 val
= make_uninit_string (XINT (length
));
877 p
= XSTRING (val
)->data
;
878 end
= p
+ XSTRING (val
)->size
;
886 make_string (contents
, length
)
890 register Lisp_Object val
;
891 val
= make_uninit_string (length
);
892 bcopy (contents
, XSTRING (val
)->data
, length
);
900 return make_string (str
, strlen (str
));
904 make_uninit_string (length
)
907 register Lisp_Object val
;
908 register int fullsize
= STRING_FULLSIZE (length
);
910 if (length
< 0) abort ();
912 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
913 /* This string can fit in the current string block */
915 XSET (val
, Lisp_String
,
916 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
917 current_string_block
->pos
+= fullsize
;
919 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
920 /* This string gets its own string block */
922 register struct string_block
*new
923 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
924 VALIDATE_LISP_STORAGE (new, 0);
925 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
927 new->next
= large_string_blocks
;
928 large_string_blocks
= new;
929 XSET (val
, Lisp_String
,
930 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
933 /* Make a new current string block and start it off with this string */
935 register struct string_block
*new
936 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
937 VALIDATE_LISP_STORAGE (new, sizeof *new);
938 consing_since_gc
+= sizeof (struct string_block
);
939 current_string_block
->next
= new;
940 new->prev
= current_string_block
;
942 current_string_block
= new;
944 XSET (val
, Lisp_String
,
945 (struct Lisp_String
*) current_string_block
->chars
);
948 XSTRING (val
)->size
= length
;
949 XSTRING (val
)->data
[length
] = 0;
950 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
955 /* Return a newly created vector or string with specified arguments as
956 elements. If all the arguments are characters that can fit
957 in a string of events, make a string; otherwise, make a vector.
959 Any number of arguments, even zero arguments, are allowed. */
962 make_event_array (nargs
, args
)
968 for (i
= 0; i
< nargs
; i
++)
969 /* The things that fit in a string
970 are characters that are in 0...127,
971 after discarding the meta bit and all the bits above it. */
972 if (XTYPE (args
[i
]) != Lisp_Int
973 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
974 return Fvector (nargs
, args
);
976 /* Since the loop exited, we know that all the things in it are
977 characters, so we can make a string. */
979 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
981 for (i
= 0; i
< nargs
; i
++)
983 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
984 /* Move the meta bit to the right place for a string char. */
985 if (XINT (args
[i
]) & CHAR_META
)
986 XSTRING (result
)->data
[i
] |= 0x80;
993 /* Pure storage management. */
995 /* Must get an error if pure storage is full,
996 since if it cannot hold a large string
997 it may be able to hold conses that point to that string;
998 then the string is not protected from gc. */
1001 make_pure_string (data
, length
)
1005 register Lisp_Object
new;
1006 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
1008 if (pureptr
+ size
> PURESIZE
)
1009 error ("Pure Lisp storage exhausted");
1010 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
1011 XSTRING (new)->size
= length
;
1012 bcopy (data
, XSTRING (new)->data
, length
);
1013 XSTRING (new)->data
[length
] = 0;
1015 /* We must give strings in pure storage some kind of interval. So we
1016 give them a null one. */
1017 #if defined (USE_TEXT_PROPERTIES)
1018 XSTRING (new)->intervals
= NULL_INTERVAL
;
1020 pureptr
+= (size
+ sizeof (int) - 1)
1021 / sizeof (int) * sizeof (int);
1026 pure_cons (car
, cdr
)
1027 Lisp_Object car
, cdr
;
1029 register Lisp_Object
new;
1031 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1032 error ("Pure Lisp storage exhausted");
1033 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
1034 pureptr
+= sizeof (struct Lisp_Cons
);
1035 XCONS (new)->car
= Fpurecopy (car
);
1036 XCONS (new)->cdr
= Fpurecopy (cdr
);
1040 #ifdef LISP_FLOAT_TYPE
1043 make_pure_float (num
)
1046 register Lisp_Object
new;
1048 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1049 (double) boundary. Some architectures (like the sparc) require
1050 this, and I suspect that floats are rare enough that it's no
1051 tragedy for those that do. */
1054 char *p
= PUREBEG
+ pureptr
;
1058 alignment
= __alignof (struct Lisp_Float
);
1060 alignment
= sizeof (struct Lisp_Float
);
1063 alignment
= sizeof (struct Lisp_Float
);
1065 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1066 pureptr
= p
- PUREBEG
;
1069 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1070 error ("Pure Lisp storage exhausted");
1071 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1072 pureptr
+= sizeof (struct Lisp_Float
);
1073 XFLOAT (new)->data
= num
;
1074 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1078 #endif /* LISP_FLOAT_TYPE */
1081 make_pure_vector (len
)
1084 register Lisp_Object
new;
1085 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1087 if (pureptr
+ size
> PURESIZE
)
1088 error ("Pure Lisp storage exhausted");
1090 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1092 XVECTOR (new)->size
= len
;
1096 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1097 "Make a copy of OBJECT in pure storage.\n\
1098 Recursively copies contents of vectors and cons cells.\n\
1099 Does not copy symbols.")
1101 register Lisp_Object obj
;
1103 register Lisp_Object
new, tem
;
1106 if (NILP (Vpurify_flag
))
1109 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1110 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1113 #ifdef SWITCH_ENUM_BUG
1114 switch ((int) XTYPE (obj
))
1116 switch (XTYPE (obj
))
1120 error ("Attempt to copy a marker to pure storage");
1123 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1125 #ifdef LISP_FLOAT_TYPE
1127 return make_pure_float (XFLOAT (obj
)->data
);
1128 #endif /* LISP_FLOAT_TYPE */
1131 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1135 new = make_pure_vector (XVECTOR (obj
)->size
);
1136 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1138 tem
= XVECTOR (obj
)->contents
[i
];
1139 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1141 XSETTYPE (new, XTYPE (obj
));
1149 /* Recording what needs to be marked for gc. */
1151 struct gcpro
*gcprolist
;
1153 #define NSTATICS 512
1155 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1159 /* Put an entry in staticvec, pointing at the variable whose address is given */
1162 staticpro (varaddress
)
1163 Lisp_Object
*varaddress
;
1165 staticvec
[staticidx
++] = varaddress
;
1166 if (staticidx
>= NSTATICS
)
1174 struct catchtag
*next
;
1175 /* jmp_buf jmp; /* We don't need this for GC purposes */
1180 struct backtrace
*next
;
1181 Lisp_Object
*function
;
1182 Lisp_Object
*args
; /* Points to vector of args. */
1183 int nargs
; /* length of vector */
1184 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1188 /* Two flags that are set during GC in the `size' component
1189 of a string or vector. On some machines, these flags
1190 are defined by the m- file to be different bits. */
1192 /* On vector, means it has been marked.
1193 On string size field or a reference to a string,
1194 means not the last reference in the chain. */
1196 #ifndef ARRAY_MARK_FLAG
1197 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1198 #endif /* no ARRAY_MARK_FLAG */
1200 /* Any slot that is a Lisp_Object can point to a string
1201 and thus can be put on a string's reference-chain
1202 and thus may need to have its ARRAY_MARK_FLAG set.
1203 This includes the slots whose markbits are used to mark
1204 the containing objects. */
1206 #if ARRAY_MARK_FLAG == MARKBIT
1210 /* Garbage collection! */
1212 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1213 int total_free_conses
, total_free_markers
, total_free_symbols
;
1214 #ifdef LISP_FLOAT_TYPE
1215 int total_free_floats
, total_floats
;
1216 #endif /* LISP_FLOAT_TYPE */
1218 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1219 "Reclaim storage for Lisp objects no longer needed.\n\
1220 Returns info on amount of space in use:\n\
1221 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1222 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1223 (USED-FLOATS . FREE-FLOATS))\n\
1224 Garbage collection happens automatically if you cons more than\n\
1225 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1228 register struct gcpro
*tail
;
1229 register struct specbinding
*bind
;
1230 struct catchtag
*catch;
1231 struct handler
*handler
;
1232 register struct backtrace
*backlist
;
1233 register Lisp_Object tem
;
1234 char *omessage
= echo_area_glyphs
;
1235 char stack_top_variable
;
1238 /* Save a copy of the contents of the stack, for debugging. */
1239 #if MAX_SAVE_STACK > 0
1240 if (NILP (Vpurify_flag
))
1242 i
= &stack_top_variable
- stack_bottom
;
1244 if (i
< MAX_SAVE_STACK
)
1246 if (stack_copy
== 0)
1247 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1248 else if (stack_copy_size
< i
)
1249 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1252 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1253 bcopy (stack_bottom
, stack_copy
, i
);
1255 bcopy (&stack_top_variable
, stack_copy
, i
);
1259 #endif /* MAX_SAVE_STACK > 0 */
1261 if (!noninteractive
)
1262 message1 ("Garbage collecting...");
1264 /* Don't keep command history around forever */
1265 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1267 XCONS (tem
)->cdr
= Qnil
;
1269 /* Likewise for undo information. */
1271 register struct buffer
*nextb
= all_buffers
;
1275 /* If a buffer's undo list is Qt, that means that undo is
1276 turned off in that buffer. Calling truncate_undo_list on
1277 Qt tends to return NULL, which effectively turns undo back on.
1278 So don't call truncate_undo_list if undo_list is Qt. */
1279 if (! EQ (nextb
->undo_list
, Qt
))
1281 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1283 nextb
= nextb
->next
;
1289 /* clear_marks (); */
1291 /* In each "large string", set the MARKBIT of the size field.
1292 That enables mark_object to recognize them. */
1294 register struct string_block
*b
;
1295 for (b
= large_string_blocks
; b
; b
= b
->next
)
1296 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1299 /* Mark all the special slots that serve as the roots of accessibility.
1301 Usually the special slots to mark are contained in particular structures.
1302 Then we know no slot is marked twice because the structures don't overlap.
1303 In some cases, the structures point to the slots to be marked.
1304 For these, we use MARKBIT to avoid double marking of the slot. */
1306 for (i
= 0; i
< staticidx
; i
++)
1307 mark_object (staticvec
[i
]);
1308 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1309 for (i
= 0; i
< tail
->nvars
; i
++)
1310 if (!XMARKBIT (tail
->var
[i
]))
1312 mark_object (&tail
->var
[i
]);
1313 XMARK (tail
->var
[i
]);
1315 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1317 mark_object (&bind
->symbol
);
1318 mark_object (&bind
->old_value
);
1320 for (catch = catchlist
; catch; catch = catch->next
)
1322 mark_object (&catch->tag
);
1323 mark_object (&catch->val
);
1325 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1327 mark_object (&handler
->handler
);
1328 mark_object (&handler
->var
);
1330 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1332 if (!XMARKBIT (*backlist
->function
))
1334 mark_object (backlist
->function
);
1335 XMARK (*backlist
->function
);
1337 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1340 i
= backlist
->nargs
- 1;
1342 if (!XMARKBIT (backlist
->args
[i
]))
1344 mark_object (&backlist
->args
[i
]);
1345 XMARK (backlist
->args
[i
]);
1351 /* Clear the mark bits that we set in certain root slots. */
1353 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1354 for (i
= 0; i
< tail
->nvars
; i
++)
1355 XUNMARK (tail
->var
[i
]);
1356 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1358 XUNMARK (*backlist
->function
);
1359 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1362 i
= backlist
->nargs
- 1;
1364 XUNMARK (backlist
->args
[i
]);
1366 XUNMARK (buffer_defaults
.name
);
1367 XUNMARK (buffer_local_symbols
.name
);
1369 /* clear_marks (); */
1372 consing_since_gc
= 0;
1373 if (gc_cons_threshold
< 10000)
1374 gc_cons_threshold
= 10000;
1376 if (omessage
|| minibuf_level
> 0)
1377 message1 (omessage
);
1378 else if (!noninteractive
)
1379 message1 ("Garbage collecting...done");
1381 return Fcons (Fcons (make_number (total_conses
),
1382 make_number (total_free_conses
)),
1383 Fcons (Fcons (make_number (total_symbols
),
1384 make_number (total_free_symbols
)),
1385 Fcons (Fcons (make_number (total_markers
),
1386 make_number (total_free_markers
)),
1387 Fcons (make_number (total_string_size
),
1388 Fcons (make_number (total_vector_size
),
1390 #ifdef LISP_FLOAT_TYPE
1391 Fcons (Fcons (make_number (total_floats
),
1392 make_number (total_free_floats
)),
1394 #else /* not LISP_FLOAT_TYPE */
1396 #endif /* not LISP_FLOAT_TYPE */
1404 /* Clear marks on all conses */
1406 register struct cons_block
*cblk
;
1407 register int lim
= cons_block_index
;
1409 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1412 for (i
= 0; i
< lim
; i
++)
1413 XUNMARK (cblk
->conses
[i
].car
);
1414 lim
= CONS_BLOCK_SIZE
;
1417 /* Clear marks on all symbols */
1419 register struct symbol_block
*sblk
;
1420 register int lim
= symbol_block_index
;
1422 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1425 for (i
= 0; i
< lim
; i
++)
1427 XUNMARK (sblk
->symbols
[i
].plist
);
1429 lim
= SYMBOL_BLOCK_SIZE
;
1432 /* Clear marks on all markers */
1434 register struct marker_block
*sblk
;
1435 register int lim
= marker_block_index
;
1437 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1440 for (i
= 0; i
< lim
; i
++)
1441 XUNMARK (sblk
->markers
[i
].chain
);
1442 lim
= MARKER_BLOCK_SIZE
;
1445 /* Clear mark bits on all buffers */
1447 register struct buffer
*nextb
= all_buffers
;
1451 XUNMARK (nextb
->name
);
1452 nextb
= nextb
->next
;
1458 /* Mark reference to a Lisp_Object.
1459 If the object referred to has not been seen yet, recursively mark
1460 all the references contained in it.
1462 If the object referenced is a short string, the referencing slot
1463 is threaded into a chain of such slots, pointed to from
1464 the `size' field of the string. The actual string size
1465 lives in the last slot in the chain. We recognize the end
1466 because it is < (unsigned) STRING_BLOCK_SIZE. */
1468 #define LAST_MARKED_SIZE 500
1469 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1470 int last_marked_index
;
1473 mark_object (objptr
)
1474 Lisp_Object
*objptr
;
1476 register Lisp_Object obj
;
1483 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1484 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1487 last_marked
[last_marked_index
++] = objptr
;
1488 if (last_marked_index
== LAST_MARKED_SIZE
)
1489 last_marked_index
= 0;
1491 #ifdef SWITCH_ENUM_BUG
1492 switch ((int) XGCTYPE (obj
))
1494 switch (XGCTYPE (obj
))
1499 register struct Lisp_String
*ptr
= XSTRING (obj
);
1501 MARK_INTERVAL_TREE (ptr
->intervals
);
1502 if (ptr
->size
& MARKBIT
)
1503 /* A large string. Just set ARRAY_MARK_FLAG. */
1504 ptr
->size
|= ARRAY_MARK_FLAG
;
1507 /* A small string. Put this reference
1508 into the chain of references to it.
1509 The address OBJPTR is even, so if the address
1510 includes MARKBIT, put it in the low bit
1511 when we store OBJPTR into the size field. */
1513 if (XMARKBIT (*objptr
))
1515 XFASTINT (*objptr
) = ptr
->size
;
1519 XFASTINT (*objptr
) = ptr
->size
;
1520 if ((int)objptr
& 1) abort ();
1521 ptr
->size
= (int) objptr
& ~MARKBIT
;
1522 if ((int) objptr
& MARKBIT
)
1531 case Lisp_Window_Configuration
:
1533 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1534 register int size
= ptr
->size
;
1535 /* The reason we use ptr1 is to avoid an apparent hardware bug
1536 that happens occasionally on the FSF's HP 300s.
1537 The bug is that a2 gets clobbered by recursive calls to mark_object.
1538 The clobberage seems to happen during function entry,
1539 perhaps in the moveml instruction.
1540 Yes, this is a crock, but we have to do it. */
1541 struct Lisp_Vector
*volatile ptr1
= ptr
;
1544 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1545 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1546 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1547 mark_object (&ptr1
->contents
[i
]);
1552 /* We could treat this just like a vector, but it is better
1553 to save the COMPILED_CONSTANTS element for last and avoid recursion
1556 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1557 register int size
= ptr
->size
;
1558 /* See comment above under Lisp_Vector. */
1559 struct Lisp_Vector
*volatile ptr1
= ptr
;
1562 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1563 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1564 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1566 if (i
!= COMPILED_CONSTANTS
)
1567 mark_object (&ptr1
->contents
[i
]);
1569 objptr
= &ptr1
->contents
[COMPILED_CONSTANTS
];
1576 /* See comment above under Lisp_Vector for why this is volatile. */
1577 register struct frame
*volatile ptr
= XFRAME (obj
);
1578 register 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
->width
);
1586 mark_object (&ptr
->height
);
1587 mark_object (&ptr
->selected_window
);
1588 mark_object (&ptr
->minibuffer_window
);
1589 mark_object (&ptr
->param_alist
);
1590 mark_object (&ptr
->scroll_bars
);
1591 mark_object (&ptr
->condemned_scroll_bars
);
1592 mark_object (&ptr
->menu_bar_items
);
1593 mark_object (&ptr
->face_alist
);
1596 #endif /* MULTI_FRAME */
1600 /* See comment above under Lisp_Vector for why this is volatile. */
1601 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1602 struct Lisp_Symbol
*ptrx
;
1604 if (XMARKBIT (ptr
->plist
)) break;
1606 mark_object ((Lisp_Object
*) &ptr
->value
);
1607 mark_object (&ptr
->function
);
1608 mark_object (&ptr
->plist
);
1609 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1610 mark_object (&ptr
->name
);
1614 /* For the benefit of the last_marked log. */
1615 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1616 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1617 XSETSYMBOL (obj
, ptrx
);
1618 /* We can't goto loop here because *objptr doesn't contain an
1619 actual Lisp_Object with valid datatype field. */
1626 XMARK (XMARKER (obj
)->chain
);
1627 /* DO NOT mark thru the marker's chain.
1628 The buffer's markers chain does not preserve markers from gc;
1629 instead, markers are removed from the chain when freed by gc. */
1633 case Lisp_Buffer_Local_Value
:
1634 case Lisp_Some_Buffer_Local_Value
:
1637 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1638 if (XMARKBIT (ptr
->car
)) break;
1640 /* If the cdr is nil, avoid recursion for the car. */
1641 if (EQ (ptr
->cdr
, Qnil
))
1646 mark_object (&ptr
->car
);
1647 /* See comment above under Lisp_Vector for why not use ptr here. */
1648 objptr
= &XCONS (obj
)->cdr
;
1652 #ifdef LISP_FLOAT_TYPE
1654 XMARK (XFLOAT (obj
)->type
);
1656 #endif /* LISP_FLOAT_TYPE */
1659 if (!XMARKBIT (XBUFFER (obj
)->name
))
1669 case Lisp_Buffer_Objfwd
:
1670 case Lisp_Internal_Stream
:
1671 /* Don't bother with Lisp_Buffer_Objfwd,
1672 since all markable slots in current buffer marked anyway. */
1673 /* Don't need to do Lisp_Objfwd, since the places they point
1674 are protected with staticpro. */
1682 /* Mark the pointers in a buffer structure. */
1688 register struct buffer
*buffer
= XBUFFER (buf
);
1689 register Lisp_Object
*ptr
;
1691 /* This is the buffer's markbit */
1692 mark_object (&buffer
->name
);
1693 XMARK (buffer
->name
);
1695 MARK_INTERVAL_TREE (buffer
->intervals
);
1698 mark_object (buffer
->syntax_table
);
1700 /* Mark the various string-pointers in the buffer object.
1701 Since the strings may be relocated, we must mark them
1702 in their actual slots. So gc_sweep must convert each slot
1703 back to an ordinary C pointer. */
1704 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1705 Lisp_String
, buffer
->upcase_table
);
1706 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1707 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1708 Lisp_String
, buffer
->downcase_table
);
1709 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1711 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1712 Lisp_String
, buffer
->sort_table
);
1713 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1714 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1715 Lisp_String
, buffer
->folding_sort_table
);
1716 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1719 for (ptr
= &buffer
->name
+ 1;
1720 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1725 /* Sweep: find all structures not marked, and free them. */
1730 total_string_size
= 0;
1733 /* Put all unmarked conses on free list */
1735 register struct cons_block
*cblk
;
1736 register int lim
= cons_block_index
;
1737 register int num_free
= 0, num_used
= 0;
1741 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1744 for (i
= 0; i
< lim
; i
++)
1745 if (!XMARKBIT (cblk
->conses
[i
].car
))
1747 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1749 cons_free_list
= &cblk
->conses
[i
];
1754 XUNMARK (cblk
->conses
[i
].car
);
1756 lim
= CONS_BLOCK_SIZE
;
1758 total_conses
= num_used
;
1759 total_free_conses
= num_free
;
1762 #ifdef LISP_FLOAT_TYPE
1763 /* Put all unmarked floats on free list */
1765 register struct float_block
*fblk
;
1766 register int lim
= float_block_index
;
1767 register int num_free
= 0, num_used
= 0;
1769 float_free_list
= 0;
1771 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1774 for (i
= 0; i
< lim
; i
++)
1775 if (!XMARKBIT (fblk
->floats
[i
].type
))
1777 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1779 float_free_list
= &fblk
->floats
[i
];
1784 XUNMARK (fblk
->floats
[i
].type
);
1786 lim
= FLOAT_BLOCK_SIZE
;
1788 total_floats
= num_used
;
1789 total_free_floats
= num_free
;
1791 #endif /* LISP_FLOAT_TYPE */
1793 #ifdef USE_TEXT_PROPERTIES
1794 /* Put all unmarked intervals on free list */
1796 register struct interval_block
*iblk
;
1797 register int lim
= interval_block_index
;
1798 register int num_free
= 0, num_used
= 0;
1800 interval_free_list
= 0;
1802 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1806 for (i
= 0; i
< lim
; i
++)
1808 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1810 iblk
->intervals
[i
].parent
= interval_free_list
;
1811 interval_free_list
= &iblk
->intervals
[i
];
1817 XUNMARK (iblk
->intervals
[i
].plist
);
1820 lim
= INTERVAL_BLOCK_SIZE
;
1822 total_intervals
= num_used
;
1823 total_free_intervals
= num_free
;
1825 #endif /* USE_TEXT_PROPERTIES */
1827 /* Put all unmarked symbols on free list */
1829 register struct symbol_block
*sblk
;
1830 register int lim
= symbol_block_index
;
1831 register int num_free
= 0, num_used
= 0;
1833 symbol_free_list
= 0;
1835 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1838 for (i
= 0; i
< lim
; i
++)
1839 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1841 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1842 symbol_free_list
= &sblk
->symbols
[i
];
1848 sblk
->symbols
[i
].name
1849 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1850 XUNMARK (sblk
->symbols
[i
].plist
);
1852 lim
= SYMBOL_BLOCK_SIZE
;
1854 total_symbols
= num_used
;
1855 total_free_symbols
= num_free
;
1859 /* Put all unmarked markers on free list.
1860 Dechain each one first from the buffer it points into. */
1862 register struct marker_block
*mblk
;
1863 struct Lisp_Marker
*tem1
;
1864 register int lim
= marker_block_index
;
1865 register int num_free
= 0, num_used
= 0;
1867 marker_free_list
= 0;
1869 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1872 for (i
= 0; i
< lim
; i
++)
1873 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1876 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1877 XSET (tem
, Lisp_Marker
, tem1
);
1878 unchain_marker (tem
);
1879 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1880 marker_free_list
= &mblk
->markers
[i
];
1886 XUNMARK (mblk
->markers
[i
].chain
);
1888 lim
= MARKER_BLOCK_SIZE
;
1891 total_markers
= num_used
;
1892 total_free_markers
= num_free
;
1895 /* Free all unmarked buffers */
1897 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1900 if (!XMARKBIT (buffer
->name
))
1903 prev
->next
= buffer
->next
;
1905 all_buffers
= buffer
->next
;
1906 next
= buffer
->next
;
1912 XUNMARK (buffer
->name
);
1913 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1916 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1917 for purposes of marking and relocation.
1918 Turn them back into C pointers now. */
1919 buffer
->upcase_table
1920 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1921 buffer
->downcase_table
1922 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1924 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1925 buffer
->folding_sort_table
1926 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1929 prev
= buffer
, buffer
= buffer
->next
;
1933 #endif /* standalone */
1935 /* Free all unmarked vectors */
1937 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1938 total_vector_size
= 0;
1941 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1944 prev
->next
= vector
->next
;
1946 all_vectors
= vector
->next
;
1947 next
= vector
->next
;
1953 vector
->size
&= ~ARRAY_MARK_FLAG
;
1954 total_vector_size
+= vector
->size
;
1955 prev
= vector
, vector
= vector
->next
;
1959 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1961 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1962 struct Lisp_String
*s
;
1966 s
= (struct Lisp_String
*) &sb
->chars
[0];
1967 if (s
->size
& ARRAY_MARK_FLAG
)
1969 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1970 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1971 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1972 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1973 prev
= sb
, sb
= sb
->next
;
1978 prev
->next
= sb
->next
;
1980 large_string_blocks
= sb
->next
;
1989 /* Compactify strings, relocate references, and free empty string blocks. */
1994 /* String block of old strings we are scanning. */
1995 register struct string_block
*from_sb
;
1996 /* A preceding string block (or maybe the same one)
1997 where we are copying the still-live strings to. */
1998 register struct string_block
*to_sb
;
2002 to_sb
= first_string_block
;
2005 /* Scan each existing string block sequentially, string by string. */
2006 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2009 /* POS is the index of the next string in the block. */
2010 while (pos
< from_sb
->pos
)
2012 register struct Lisp_String
*nextstr
2013 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2015 register struct Lisp_String
*newaddr
;
2016 register int size
= nextstr
->size
;
2018 /* NEXTSTR is the old address of the next string.
2019 Just skip it if it isn't marked. */
2020 if ((unsigned) size
> STRING_BLOCK_SIZE
)
2022 /* It is marked, so its size field is really a chain of refs.
2023 Find the end of the chain, where the actual size lives. */
2024 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2026 if (size
& 1) size
^= MARKBIT
| 1;
2027 size
= *(int *)size
& ~MARKBIT
;
2030 total_string_size
+= size
;
2032 /* If it won't fit in TO_SB, close it out,
2033 and move to the next sb. Keep doing so until
2034 TO_SB reaches a large enough, empty enough string block.
2035 We know that TO_SB cannot advance past FROM_SB here
2036 since FROM_SB is large enough to contain this string.
2037 Any string blocks skipped here
2038 will be patched out and freed later. */
2039 while (to_pos
+ STRING_FULLSIZE (size
)
2040 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2042 to_sb
->pos
= to_pos
;
2043 to_sb
= to_sb
->next
;
2046 /* Compute new address of this string
2047 and update TO_POS for the space being used. */
2048 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2049 to_pos
+= STRING_FULLSIZE (size
);
2051 /* Copy the string itself to the new place. */
2052 if (nextstr
!= newaddr
)
2053 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
2054 + INTERVAL_PTR_SIZE
);
2056 /* Go through NEXTSTR's chain of references
2057 and make each slot in the chain point to
2058 the new address of this string. */
2059 size
= newaddr
->size
;
2060 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2062 register Lisp_Object
*objptr
;
2063 if (size
& 1) size
^= MARKBIT
| 1;
2064 objptr
= (Lisp_Object
*)size
;
2066 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2067 if (XMARKBIT (*objptr
))
2069 XSET (*objptr
, Lisp_String
, newaddr
);
2073 XSET (*objptr
, Lisp_String
, newaddr
);
2075 /* Store the actual size in the size field. */
2076 newaddr
->size
= size
;
2078 #ifdef USE_TEXT_PROPERTIES
2079 /* Now that the string has been relocated, rebalance its
2080 interval tree, and update the tree's parent pointer. */
2081 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2083 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2084 XSET (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2088 #endif /* USE_TEXT_PROPERTIES */
2090 pos
+= STRING_FULLSIZE (size
);
2094 /* Close out the last string block still used and free any that follow. */
2095 to_sb
->pos
= to_pos
;
2096 current_string_block
= to_sb
;
2098 from_sb
= to_sb
->next
;
2102 to_sb
= from_sb
->next
;
2107 /* Free any empty string blocks further back in the chain.
2108 This loop will never free first_string_block, but it is very
2109 unlikely that that one will become empty, so why bother checking? */
2111 from_sb
= first_string_block
;
2112 while (to_sb
= from_sb
->next
)
2114 if (to_sb
->pos
== 0)
2116 if (from_sb
->next
= to_sb
->next
)
2117 from_sb
->next
->prev
= from_sb
;
2125 /* Debugging aids. */
2127 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2128 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2129 This may be helpful in debugging Emacs's memory usage.\n\
2130 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2135 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2141 /* Initialization */
2145 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2148 pure_size
= PURESIZE
;
2151 ignore_warnings
= 1;
2156 #ifdef LISP_FLOAT_TYPE
2158 #endif /* LISP_FLOAT_TYPE */
2161 ignore_warnings
= 0;
2164 consing_since_gc
= 0;
2165 gc_cons_threshold
= 100000;
2166 #ifdef VIRT_ADDR_VARIES
2167 malloc_sbrk_unused
= 1<<22; /* A large number */
2168 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2169 #endif /* VIRT_ADDR_VARIES */
2180 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2181 "*Number of bytes of consing between garbage collections.\n\
2182 Garbage collection can happen automatically once this many bytes have been\n\
2183 allocated since the last garbage collection. All data types count.\n\n\
2184 Garbage collection happens automatically only when `eval' is called.\n\n\
2185 By binding this temporarily to a large number, you can effectively\n\
2186 prevent garbage collection during a part of the program.");
2188 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2189 "Number of bytes of sharable Lisp data allocated so far.");
2192 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2193 "Number of bytes of unshared memory allocated in this session.");
2195 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2196 "Number of bytes of unshared memory remaining available in this session.");
2199 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2200 "Non-nil means loading Lisp code in order to dump an executable.\n\
2201 This means that certain objects should be allocated in shared (pure) space.");
2203 DEFVAR_INT ("undo-limit", &undo_limit
,
2204 "Keep no more undo information once it exceeds this size.\n\
2205 This limit is applied when garbage collection happens.\n\
2206 The size is counted as the number of bytes occupied,\n\
2207 which includes both saved text and other data.");
2210 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2211 "Don't keep more than this much size of undo information.\n\
2212 A command which pushes past this size is itself forgotten.\n\
2213 This limit is applied when garbage collection happens.\n\
2214 The size is counted as the number of bytes occupied,\n\
2215 which includes both saved text and other data.");
2216 undo_strong_limit
= 30000;
2221 defsubr (&Smake_byte_code
);
2222 defsubr (&Smake_list
);
2223 defsubr (&Smake_vector
);
2224 defsubr (&Smake_string
);
2225 defsubr (&Smake_symbol
);
2226 defsubr (&Smake_marker
);
2227 defsubr (&Spurecopy
);
2228 defsubr (&Sgarbage_collect
);
2229 defsubr (&Smemory_limit
);