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;
1014 pureptr
+= (size
+ sizeof (int) - 1)
1015 / sizeof (int) * sizeof (int);
1020 pure_cons (car
, cdr
)
1021 Lisp_Object car
, cdr
;
1023 register Lisp_Object
new;
1025 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1026 error ("Pure Lisp storage exhausted");
1027 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
1028 pureptr
+= sizeof (struct Lisp_Cons
);
1029 XCONS (new)->car
= Fpurecopy (car
);
1030 XCONS (new)->cdr
= Fpurecopy (cdr
);
1034 #ifdef LISP_FLOAT_TYPE
1037 make_pure_float (num
)
1040 register Lisp_Object
new;
1042 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1043 (double) boundary. Some architectures (like the sparc) require
1044 this, and I suspect that floats are rare enough that it's no
1045 tragedy for those that do. */
1048 char *p
= PUREBEG
+ pureptr
;
1052 alignment
= __alignof (struct Lisp_Float
);
1054 alignment
= sizeof (struct Lisp_Float
);
1057 alignment
= sizeof (struct Lisp_Float
);
1059 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1060 pureptr
= p
- PUREBEG
;
1063 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1064 error ("Pure Lisp storage exhausted");
1065 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1066 pureptr
+= sizeof (struct Lisp_Float
);
1067 XFLOAT (new)->data
= num
;
1068 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1072 #endif /* LISP_FLOAT_TYPE */
1075 make_pure_vector (len
)
1078 register Lisp_Object
new;
1079 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1081 if (pureptr
+ size
> PURESIZE
)
1082 error ("Pure Lisp storage exhausted");
1084 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1086 XVECTOR (new)->size
= len
;
1090 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1091 "Make a copy of OBJECT in pure storage.\n\
1092 Recursively copies contents of vectors and cons cells.\n\
1093 Does not copy symbols.")
1095 register Lisp_Object obj
;
1097 register Lisp_Object
new, tem
;
1100 if (NILP (Vpurify_flag
))
1103 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1104 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1107 #ifdef SWITCH_ENUM_BUG
1108 switch ((int) XTYPE (obj
))
1110 switch (XTYPE (obj
))
1114 error ("Attempt to copy a marker to pure storage");
1117 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1119 #ifdef LISP_FLOAT_TYPE
1121 return make_pure_float (XFLOAT (obj
)->data
);
1122 #endif /* LISP_FLOAT_TYPE */
1125 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1129 new = make_pure_vector (XVECTOR (obj
)->size
);
1130 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1132 tem
= XVECTOR (obj
)->contents
[i
];
1133 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1135 XSETTYPE (new, XTYPE (obj
));
1143 /* Recording what needs to be marked for gc. */
1145 struct gcpro
*gcprolist
;
1147 #define NSTATICS 512
1149 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1153 /* Put an entry in staticvec, pointing at the variable whose address is given */
1156 staticpro (varaddress
)
1157 Lisp_Object
*varaddress
;
1159 staticvec
[staticidx
++] = varaddress
;
1160 if (staticidx
>= NSTATICS
)
1168 struct catchtag
*next
;
1169 /* jmp_buf jmp; /* We don't need this for GC purposes */
1174 struct backtrace
*next
;
1175 Lisp_Object
*function
;
1176 Lisp_Object
*args
; /* Points to vector of args. */
1177 int nargs
; /* length of vector */
1178 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1182 /* Two flags that are set during GC in the `size' component
1183 of a string or vector. On some machines, these flags
1184 are defined by the m- file to be different bits. */
1186 /* On vector, means it has been marked.
1187 On string size field or a reference to a string,
1188 means not the last reference in the chain. */
1190 #ifndef ARRAY_MARK_FLAG
1191 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1192 #endif /* no ARRAY_MARK_FLAG */
1194 /* Any slot that is a Lisp_Object can point to a string
1195 and thus can be put on a string's reference-chain
1196 and thus may need to have its ARRAY_MARK_FLAG set.
1197 This includes the slots whose markbits are used to mark
1198 the containing objects. */
1200 #if ARRAY_MARK_FLAG == MARKBIT
1204 /* Garbage collection! */
1206 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1207 int total_free_conses
, total_free_markers
, total_free_symbols
;
1208 #ifdef LISP_FLOAT_TYPE
1209 int total_free_floats
, total_floats
;
1210 #endif /* LISP_FLOAT_TYPE */
1212 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1213 "Reclaim storage for Lisp objects no longer needed.\n\
1214 Returns info on amount of space in use:\n\
1215 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1216 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1217 (USED-FLOATS . FREE-FLOATS))\n\
1218 Garbage collection happens automatically if you cons more than\n\
1219 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1222 register struct gcpro
*tail
;
1223 register struct specbinding
*bind
;
1224 struct catchtag
*catch;
1225 struct handler
*handler
;
1226 register struct backtrace
*backlist
;
1227 register Lisp_Object tem
;
1228 char *omessage
= echo_area_glyphs
;
1229 char stack_top_variable
;
1232 /* Save a copy of the contents of the stack, for debugging. */
1233 #if MAX_SAVE_STACK > 0
1234 if (NILP (Vpurify_flag
))
1236 i
= &stack_top_variable
- stack_bottom
;
1238 if (i
< MAX_SAVE_STACK
)
1240 if (stack_copy
== 0)
1241 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1242 else if (stack_copy_size
< i
)
1243 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1246 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1247 bcopy (stack_bottom
, stack_copy
, i
);
1249 bcopy (&stack_top_variable
, stack_copy
, i
);
1253 #endif /* MAX_SAVE_STACK > 0 */
1255 if (!noninteractive
)
1256 message1 ("Garbage collecting...");
1258 /* Don't keep command history around forever */
1259 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1261 XCONS (tem
)->cdr
= Qnil
;
1263 /* Likewise for undo information. */
1265 register struct buffer
*nextb
= all_buffers
;
1269 /* If a buffer's undo list is Qt, that means that undo is
1270 turned off in that buffer. Calling truncate_undo_list on
1271 Qt tends to return NULL, which effectively turns undo back on.
1272 So don't call truncate_undo_list if undo_list is Qt. */
1273 if (! EQ (nextb
->undo_list
, Qt
))
1275 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1277 nextb
= nextb
->next
;
1283 /* clear_marks (); */
1285 /* In each "large string", set the MARKBIT of the size field.
1286 That enables mark_object to recognize them. */
1288 register struct string_block
*b
;
1289 for (b
= large_string_blocks
; b
; b
= b
->next
)
1290 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1293 /* Mark all the special slots that serve as the roots of accessibility.
1295 Usually the special slots to mark are contained in particular structures.
1296 Then we know no slot is marked twice because the structures don't overlap.
1297 In some cases, the structures point to the slots to be marked.
1298 For these, we use MARKBIT to avoid double marking of the slot. */
1300 for (i
= 0; i
< staticidx
; i
++)
1301 mark_object (staticvec
[i
]);
1302 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1303 for (i
= 0; i
< tail
->nvars
; i
++)
1304 if (!XMARKBIT (tail
->var
[i
]))
1306 mark_object (&tail
->var
[i
]);
1307 XMARK (tail
->var
[i
]);
1309 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1311 mark_object (&bind
->symbol
);
1312 mark_object (&bind
->old_value
);
1314 for (catch = catchlist
; catch; catch = catch->next
)
1316 mark_object (&catch->tag
);
1317 mark_object (&catch->val
);
1319 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1321 mark_object (&handler
->handler
);
1322 mark_object (&handler
->var
);
1324 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1326 if (!XMARKBIT (*backlist
->function
))
1328 mark_object (backlist
->function
);
1329 XMARK (*backlist
->function
);
1331 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1334 i
= backlist
->nargs
- 1;
1336 if (!XMARKBIT (backlist
->args
[i
]))
1338 mark_object (&backlist
->args
[i
]);
1339 XMARK (backlist
->args
[i
]);
1345 /* Clear the mark bits that we set in certain root slots. */
1347 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1348 for (i
= 0; i
< tail
->nvars
; i
++)
1349 XUNMARK (tail
->var
[i
]);
1350 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1352 XUNMARK (*backlist
->function
);
1353 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1356 i
= backlist
->nargs
- 1;
1358 XUNMARK (backlist
->args
[i
]);
1360 XUNMARK (buffer_defaults
.name
);
1361 XUNMARK (buffer_local_symbols
.name
);
1363 /* clear_marks (); */
1366 consing_since_gc
= 0;
1367 if (gc_cons_threshold
< 10000)
1368 gc_cons_threshold
= 10000;
1370 if (omessage
|| minibuf_level
> 0)
1371 message1 (omessage
);
1372 else if (!noninteractive
)
1373 message1 ("Garbage collecting...done");
1375 return Fcons (Fcons (make_number (total_conses
),
1376 make_number (total_free_conses
)),
1377 Fcons (Fcons (make_number (total_symbols
),
1378 make_number (total_free_symbols
)),
1379 Fcons (Fcons (make_number (total_markers
),
1380 make_number (total_free_markers
)),
1381 Fcons (make_number (total_string_size
),
1382 Fcons (make_number (total_vector_size
),
1384 #ifdef LISP_FLOAT_TYPE
1385 Fcons (Fcons (make_number (total_floats
),
1386 make_number (total_free_floats
)),
1388 #else /* not LISP_FLOAT_TYPE */
1390 #endif /* not LISP_FLOAT_TYPE */
1398 /* Clear marks on all conses */
1400 register struct cons_block
*cblk
;
1401 register int lim
= cons_block_index
;
1403 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1406 for (i
= 0; i
< lim
; i
++)
1407 XUNMARK (cblk
->conses
[i
].car
);
1408 lim
= CONS_BLOCK_SIZE
;
1411 /* Clear marks on all symbols */
1413 register struct symbol_block
*sblk
;
1414 register int lim
= symbol_block_index
;
1416 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1419 for (i
= 0; i
< lim
; i
++)
1421 XUNMARK (sblk
->symbols
[i
].plist
);
1423 lim
= SYMBOL_BLOCK_SIZE
;
1426 /* Clear marks on all markers */
1428 register struct marker_block
*sblk
;
1429 register int lim
= marker_block_index
;
1431 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1434 for (i
= 0; i
< lim
; i
++)
1435 XUNMARK (sblk
->markers
[i
].chain
);
1436 lim
= MARKER_BLOCK_SIZE
;
1439 /* Clear mark bits on all buffers */
1441 register struct buffer
*nextb
= all_buffers
;
1445 XUNMARK (nextb
->name
);
1446 nextb
= nextb
->next
;
1452 /* Mark reference to a Lisp_Object.
1453 If the object referred to has not been seen yet, recursively mark
1454 all the references contained in it.
1456 If the object referenced is a short string, the referencing slot
1457 is threaded into a chain of such slots, pointed to from
1458 the `size' field of the string. The actual string size
1459 lives in the last slot in the chain. We recognize the end
1460 because it is < (unsigned) STRING_BLOCK_SIZE. */
1462 #define LAST_MARKED_SIZE 500
1463 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1464 int last_marked_index
;
1467 mark_object (objptr
)
1468 Lisp_Object
*objptr
;
1470 register Lisp_Object obj
;
1473 if (*(int *) ((char *)__builtin_frame_address (0) - 16) == 0)
1482 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1483 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1486 last_marked
[last_marked_index
++] = objptr
;
1487 if (last_marked_index
== LAST_MARKED_SIZE
)
1488 last_marked_index
= 0;
1490 #ifdef SWITCH_ENUM_BUG
1491 switch ((int) XGCTYPE (obj
))
1493 switch (XGCTYPE (obj
))
1498 register struct Lisp_String
*ptr
= XSTRING (obj
);
1500 MARK_INTERVAL_TREE (ptr
->intervals
);
1501 if (ptr
->size
& MARKBIT
)
1502 /* A large string. Just set ARRAY_MARK_FLAG. */
1503 ptr
->size
|= ARRAY_MARK_FLAG
;
1506 /* A small string. Put this reference
1507 into the chain of references to it.
1508 The address OBJPTR is even, so if the address
1509 includes MARKBIT, put it in the low bit
1510 when we store OBJPTR into the size field. */
1512 if (XMARKBIT (*objptr
))
1514 XFASTINT (*objptr
) = ptr
->size
;
1518 XFASTINT (*objptr
) = ptr
->size
;
1519 if ((int)objptr
& 1) abort ();
1520 ptr
->size
= (int) objptr
& ~MARKBIT
;
1521 if ((int) objptr
& MARKBIT
)
1530 case Lisp_Window_Configuration
:
1532 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1533 register int size
= ptr
->size
;
1534 struct Lisp_Vector
*volatile ptr1
= ptr
;
1537 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1538 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1539 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1543 mark_object (&ptr
->contents
[i
]);
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 int size
= ptr
->size
;
1555 struct Lisp_Vector
*volatile ptr1
= ptr
;
1558 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1559 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1560 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1564 if (i
!= COMPILED_CONSTANTS
)
1565 mark_object (&ptr
->contents
[i
]);
1567 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1575 register struct frame
*ptr
= XFRAME (obj
);
1576 register int size
= ptr
->size
;
1578 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1579 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1581 mark_object (&ptr
->name
);
1582 mark_object (&ptr
->focus_frame
);
1583 mark_object (&ptr
->width
);
1584 mark_object (&ptr
->height
);
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
);
1594 #endif /* MULTI_FRAME */
1598 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1599 struct Lisp_Symbol
*ptrx
;
1601 if (XMARKBIT (ptr
->plist
)) break;
1603 mark_object ((Lisp_Object
*) &ptr
->value
);
1604 if ((unsigned int) ptr
<= 4)
1606 mark_object (&ptr
->function
);
1607 if ((unsigned int) ptr
<= 4)
1609 mark_object (&ptr
->plist
);
1610 if ((unsigned int) ptr
<= 4)
1612 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1613 mark_object (&ptr
->name
);
1614 if ((unsigned int) ptr
<= 4)
1619 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1620 XSETSYMBOL (obj
, ptrx
);
1627 XMARK (XMARKER (obj
)->chain
);
1628 /* DO NOT mark thru the marker's chain.
1629 The buffer's markers chain does not preserve markers from gc;
1630 instead, markers are removed from the chain when freed by gc. */
1634 case Lisp_Buffer_Local_Value
:
1635 case Lisp_Some_Buffer_Local_Value
:
1638 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1639 if (XMARKBIT (ptr
->car
)) break;
1641 /* If the cdr is nil, avoid recursion for the car. */
1642 if (EQ (ptr
->cdr
, Qnil
))
1651 mark_object (&ptr
->car
);
1659 #ifdef LISP_FLOAT_TYPE
1661 XMARK (XFLOAT (obj
)->type
);
1663 #endif /* LISP_FLOAT_TYPE */
1666 if (!XMARKBIT (XBUFFER (obj
)->name
))
1676 case Lisp_Buffer_Objfwd
:
1677 case Lisp_Internal_Stream
:
1678 /* Don't bother with Lisp_Buffer_Objfwd,
1679 since all markable slots in current buffer marked anyway. */
1680 /* Don't need to do Lisp_Objfwd, since the places they point
1681 are protected with staticpro. */
1689 /* Mark the pointers in a buffer structure. */
1695 register struct buffer
*buffer
= XBUFFER (buf
);
1696 register Lisp_Object
*ptr
;
1698 /* This is the buffer's markbit */
1699 mark_object (&buffer
->name
);
1700 XMARK (buffer
->name
);
1702 MARK_INTERVAL_TREE (buffer
->intervals
);
1705 mark_object (buffer
->syntax_table
);
1707 /* Mark the various string-pointers in the buffer object.
1708 Since the strings may be relocated, we must mark them
1709 in their actual slots. So gc_sweep must convert each slot
1710 back to an ordinary C pointer. */
1711 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1712 Lisp_String
, buffer
->upcase_table
);
1713 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1714 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1715 Lisp_String
, buffer
->downcase_table
);
1716 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1718 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1719 Lisp_String
, buffer
->sort_table
);
1720 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1721 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1722 Lisp_String
, buffer
->folding_sort_table
);
1723 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1726 for (ptr
= &buffer
->name
+ 1;
1727 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1732 /* Sweep: find all structures not marked, and free them. */
1737 total_string_size
= 0;
1740 /* Put all unmarked conses on free list */
1742 register struct cons_block
*cblk
;
1743 register int lim
= cons_block_index
;
1744 register int num_free
= 0, num_used
= 0;
1748 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1751 for (i
= 0; i
< lim
; i
++)
1752 if (!XMARKBIT (cblk
->conses
[i
].car
))
1754 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1756 cons_free_list
= &cblk
->conses
[i
];
1761 XUNMARK (cblk
->conses
[i
].car
);
1763 lim
= CONS_BLOCK_SIZE
;
1765 total_conses
= num_used
;
1766 total_free_conses
= num_free
;
1769 #ifdef LISP_FLOAT_TYPE
1770 /* Put all unmarked floats on free list */
1772 register struct float_block
*fblk
;
1773 register int lim
= float_block_index
;
1774 register int num_free
= 0, num_used
= 0;
1776 float_free_list
= 0;
1778 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1781 for (i
= 0; i
< lim
; i
++)
1782 if (!XMARKBIT (fblk
->floats
[i
].type
))
1784 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1786 float_free_list
= &fblk
->floats
[i
];
1791 XUNMARK (fblk
->floats
[i
].type
);
1793 lim
= FLOAT_BLOCK_SIZE
;
1795 total_floats
= num_used
;
1796 total_free_floats
= num_free
;
1798 #endif /* LISP_FLOAT_TYPE */
1800 #ifdef USE_TEXT_PROPERTIES
1801 /* Put all unmarked intervals on free list */
1803 register struct interval_block
*iblk
;
1804 register int lim
= interval_block_index
;
1805 register int num_free
= 0, num_used
= 0;
1807 interval_free_list
= 0;
1809 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1813 for (i
= 0; i
< lim
; i
++)
1815 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1817 iblk
->intervals
[i
].parent
= interval_free_list
;
1818 interval_free_list
= &iblk
->intervals
[i
];
1824 XUNMARK (iblk
->intervals
[i
].plist
);
1827 lim
= INTERVAL_BLOCK_SIZE
;
1829 total_intervals
= num_used
;
1830 total_free_intervals
= num_free
;
1832 #endif /* USE_TEXT_PROPERTIES */
1834 /* Put all unmarked symbols on free list */
1836 register struct symbol_block
*sblk
;
1837 register int lim
= symbol_block_index
;
1838 register int num_free
= 0, num_used
= 0;
1840 symbol_free_list
= 0;
1842 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1845 for (i
= 0; i
< lim
; i
++)
1846 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1848 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1849 symbol_free_list
= &sblk
->symbols
[i
];
1855 sblk
->symbols
[i
].name
1856 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1857 XUNMARK (sblk
->symbols
[i
].plist
);
1859 lim
= SYMBOL_BLOCK_SIZE
;
1861 total_symbols
= num_used
;
1862 total_free_symbols
= num_free
;
1866 /* Put all unmarked markers on free list.
1867 Dechain each one first from the buffer it points into. */
1869 register struct marker_block
*mblk
;
1870 struct Lisp_Marker
*tem1
;
1871 register int lim
= marker_block_index
;
1872 register int num_free
= 0, num_used
= 0;
1874 marker_free_list
= 0;
1876 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1879 for (i
= 0; i
< lim
; i
++)
1880 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1883 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1884 XSET (tem
, Lisp_Marker
, tem1
);
1885 unchain_marker (tem
);
1886 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1887 marker_free_list
= &mblk
->markers
[i
];
1893 XUNMARK (mblk
->markers
[i
].chain
);
1895 lim
= MARKER_BLOCK_SIZE
;
1898 total_markers
= num_used
;
1899 total_free_markers
= num_free
;
1902 /* Free all unmarked buffers */
1904 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1907 if (!XMARKBIT (buffer
->name
))
1910 prev
->next
= buffer
->next
;
1912 all_buffers
= buffer
->next
;
1913 next
= buffer
->next
;
1919 XUNMARK (buffer
->name
);
1920 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1923 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1924 for purposes of marking and relocation.
1925 Turn them back into C pointers now. */
1926 buffer
->upcase_table
1927 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1928 buffer
->downcase_table
1929 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1931 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1932 buffer
->folding_sort_table
1933 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1936 prev
= buffer
, buffer
= buffer
->next
;
1940 #endif /* standalone */
1942 /* Free all unmarked vectors */
1944 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1945 total_vector_size
= 0;
1948 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1951 prev
->next
= vector
->next
;
1953 all_vectors
= vector
->next
;
1954 next
= vector
->next
;
1960 vector
->size
&= ~ARRAY_MARK_FLAG
;
1961 total_vector_size
+= vector
->size
;
1962 prev
= vector
, vector
= vector
->next
;
1966 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1968 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1969 struct Lisp_String
*s
;
1973 s
= (struct Lisp_String
*) &sb
->chars
[0];
1974 if (s
->size
& ARRAY_MARK_FLAG
)
1976 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1977 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1978 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1979 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1980 prev
= sb
, sb
= sb
->next
;
1985 prev
->next
= sb
->next
;
1987 large_string_blocks
= sb
->next
;
1996 /* Compactify strings, relocate references, and free empty string blocks. */
2001 /* String block of old strings we are scanning. */
2002 register struct string_block
*from_sb
;
2003 /* A preceding string block (or maybe the same one)
2004 where we are copying the still-live strings to. */
2005 register struct string_block
*to_sb
;
2009 to_sb
= first_string_block
;
2012 /* Scan each existing string block sequentially, string by string. */
2013 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2016 /* POS is the index of the next string in the block. */
2017 while (pos
< from_sb
->pos
)
2019 register struct Lisp_String
*nextstr
2020 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2022 register struct Lisp_String
*newaddr
;
2023 register int size
= nextstr
->size
;
2025 /* NEXTSTR is the old address of the next string.
2026 Just skip it if it isn't marked. */
2027 if ((unsigned) size
> STRING_BLOCK_SIZE
)
2029 /* It is marked, so its size field is really a chain of refs.
2030 Find the end of the chain, where the actual size lives. */
2031 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2033 if (size
& 1) size
^= MARKBIT
| 1;
2034 size
= *(int *)size
& ~MARKBIT
;
2037 total_string_size
+= size
;
2039 /* If it won't fit in TO_SB, close it out,
2040 and move to the next sb. Keep doing so until
2041 TO_SB reaches a large enough, empty enough string block.
2042 We know that TO_SB cannot advance past FROM_SB here
2043 since FROM_SB is large enough to contain this string.
2044 Any string blocks skipped here
2045 will be patched out and freed later. */
2046 while (to_pos
+ STRING_FULLSIZE (size
)
2047 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2049 to_sb
->pos
= to_pos
;
2050 to_sb
= to_sb
->next
;
2053 /* Compute new address of this string
2054 and update TO_POS for the space being used. */
2055 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2056 to_pos
+= STRING_FULLSIZE (size
);
2058 /* Copy the string itself to the new place. */
2059 if (nextstr
!= newaddr
)
2060 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
2061 + INTERVAL_PTR_SIZE
);
2063 /* Go through NEXTSTR's chain of references
2064 and make each slot in the chain point to
2065 the new address of this string. */
2066 size
= newaddr
->size
;
2067 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2069 register Lisp_Object
*objptr
;
2070 if (size
& 1) size
^= MARKBIT
| 1;
2071 objptr
= (Lisp_Object
*)size
;
2073 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2074 if (XMARKBIT (*objptr
))
2076 XSET (*objptr
, Lisp_String
, newaddr
);
2080 XSET (*objptr
, Lisp_String
, newaddr
);
2082 /* Store the actual size in the size field. */
2083 newaddr
->size
= size
;
2085 #ifdef USE_TEXT_PROPERTIES
2086 /* Now that the string has been relocated, rebalance its
2087 interval tree, and update the tree's parent pointer. */
2088 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2090 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2091 XSET (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2095 #endif /* USE_TEXT_PROPERTIES */
2097 pos
+= STRING_FULLSIZE (size
);
2101 /* Close out the last string block still used and free any that follow. */
2102 to_sb
->pos
= to_pos
;
2103 current_string_block
= to_sb
;
2105 from_sb
= to_sb
->next
;
2109 to_sb
= from_sb
->next
;
2114 /* Free any empty string blocks further back in the chain.
2115 This loop will never free first_string_block, but it is very
2116 unlikely that that one will become empty, so why bother checking? */
2118 from_sb
= first_string_block
;
2119 while (to_sb
= from_sb
->next
)
2121 if (to_sb
->pos
== 0)
2123 if (from_sb
->next
= to_sb
->next
)
2124 from_sb
->next
->prev
= from_sb
;
2132 /* Debugging aids. */
2134 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2135 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2136 This may be helpful in debugging Emacs's memory usage.\n\
2137 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2142 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2148 /* Initialization */
2152 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2155 pure_size
= PURESIZE
;
2158 ignore_warnings
= 1;
2163 #ifdef LISP_FLOAT_TYPE
2165 #endif /* LISP_FLOAT_TYPE */
2168 ignore_warnings
= 0;
2171 consing_since_gc
= 0;
2172 gc_cons_threshold
= 100000;
2173 #ifdef VIRT_ADDR_VARIES
2174 malloc_sbrk_unused
= 1<<22; /* A large number */
2175 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2176 #endif /* VIRT_ADDR_VARIES */
2187 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2188 "*Number of bytes of consing between garbage collections.\n\
2189 Garbage collection can happen automatically once this many bytes have been\n\
2190 allocated since the last garbage collection. All data types count.\n\n\
2191 Garbage collection happens automatically only when `eval' is called.\n\n\
2192 By binding this temporarily to a large number, you can effectively\n\
2193 prevent garbage collection during a part of the program.");
2195 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2196 "Number of bytes of sharable Lisp data allocated so far.");
2199 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2200 "Number of bytes of unshared memory allocated in this session.");
2202 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2203 "Number of bytes of unshared memory remaining available in this session.");
2206 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2207 "Non-nil means loading Lisp code in order to dump an executable.\n\
2208 This means that certain objects should be allocated in shared (pure) space.");
2210 DEFVAR_INT ("undo-limit", &undo_limit
,
2211 "Keep no more undo information once it exceeds this size.\n\
2212 This limit is applied when garbage collection happens.\n\
2213 The size is counted as the number of bytes occupied,\n\
2214 which includes both saved text and other data.");
2217 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2218 "Don't keep more than this much size of undo information.\n\
2219 A command which pushes past this size is itself forgotten.\n\
2220 This limit is applied when garbage collection happens.\n\
2221 The size is counted as the number of bytes occupied,\n\
2222 which includes both saved text and other data.");
2223 undo_strong_limit
= 30000;
2228 defsubr (&Smake_byte_code
);
2229 defsubr (&Smake_list
);
2230 defsubr (&Smake_vector
);
2231 defsubr (&Smake_string
);
2232 defsubr (&Smake_symbol
);
2233 defsubr (&Smake_marker
);
2234 defsubr (&Spurecopy
);
2235 defsubr (&Sgarbage_collect
);
2236 defsubr (&Smemory_limit
);