1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 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. */
23 #include "intervals.h"
29 #include "blockinput.h"
32 #include "syssignal.h"
34 #define max(A,B) ((A) > (B) ? (A) : (B))
36 /* Macro to verify that storage intended for Lisp objects is not
37 out of range to fit in the space for a pointer.
38 ADDRESS is the start of the block, and SIZE
39 is the amount of space within which objects can start. */
40 #define VALIDATE_LISP_STORAGE(address, size) \
44 XSET (val, Lisp_Cons, (char *) address + size); \
45 if ((char *) XCONS (val) != (char *) address + size) \
52 /* Number of bytes of consing done since the last gc */
55 /* Number of bytes of consing since gc before another gc should be done. */
56 int gc_cons_threshold
;
58 /* Nonzero during gc */
61 #ifndef VIRT_ADDR_VARIES
63 #endif /* VIRT_ADDR_VARIES */
66 #ifndef VIRT_ADDR_VARIES
68 #endif /* VIRT_ADDR_VARIES */
69 int malloc_sbrk_unused
;
71 /* Two limits controlling how much undo information to keep. */
73 int undo_strong_limit
;
75 /* Non-nil means defun should do purecopy on the function definition */
76 Lisp_Object Vpurify_flag
;
79 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
80 #define PUREBEG (char *) pure
82 #define pure PURE_SEG_BITS /* Use shared memory segment */
83 #define PUREBEG (char *)PURE_SEG_BITS
85 /* This variable is used only by the XPNTR macro when HAVE_SHM is
86 defined. If we used the PURESIZE macro directly there, that would
87 make most of emacs dependent on puresize.h, which we don't want -
88 you should be able to change that without too much recompilation.
89 So map_in_data initializes pure_size, and the dependencies work
92 #endif /* not HAVE_SHM */
94 /* Index in pure at which next pure object will be allocated. */
97 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
98 char *pending_malloc_warning
;
100 /* Maximum amount of C stack to save when a GC happens. */
102 #ifndef MAX_SAVE_STACK
103 #define MAX_SAVE_STACK 16000
106 /* Buffer in which we save a copy of the C stack at each GC. */
111 /* Non-zero means ignore malloc warnings. Set during initialization. */
114 static void mark_object (), mark_buffer ();
115 static void clear_marks (), gc_sweep ();
116 static void compact_strings ();
118 /* Versions of malloc and realloc that print warnings as memory gets full. */
121 malloc_warning_1 (str
)
124 Fprinc (str
, Vstandard_output
);
125 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
126 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
127 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
131 /* malloc calls this if it finds we are near exhausting storage */
135 pending_malloc_warning
= str
;
138 display_malloc_warning ()
140 register Lisp_Object val
;
142 val
= build_string (pending_malloc_warning
);
143 pending_malloc_warning
= 0;
144 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
147 /* Called if malloc returns zero */
150 error ("Memory exhausted");
153 /* like malloc routines but check for no memory and block interrupt input. */
162 val
= (long *) malloc (size
);
165 if (!val
&& size
) memory_full ();
170 xrealloc (block
, size
)
177 /* We must call malloc explicitly when BLOCK is 0, since some
178 reallocs don't do this. */
180 val
= (long *) malloc (size
);
182 val
= (long *) realloc (block
, size
);
185 if (!val
&& size
) memory_full ();
199 /* Arranging to disable input signals while we're in malloc.
201 This only works with GNU malloc. To help out systems which can't
202 use GNU malloc, all the calls to malloc, realloc, and free
203 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
204 pairs; unfortunately, we have no idea what C library functions
205 might call malloc, so we can't really protect them unless you're
206 using GNU malloc. Fortunately, most of the major operating can use
209 #ifndef SYSTEM_MALLOC
210 static void (*__malloc_hook
) (), (*old_malloc_hook
) ();
211 static void (*__realloc_hook
) (), (*old_realloc_hook
) ();
212 static void (*__free_hook
) (), (*old_free_hook
) ();
215 emacs_blocked_free (ptr
)
219 __free_hook
= old_free_hook
;
221 __free_hook
= &emacs_blocked_free
;
226 emacs_blocked_malloc (size
)
232 __malloc_hook
= old_malloc_hook
;
233 value
= malloc (size
);
234 __malloc_hook
= &emacs_blocked_malloc
;
241 emacs_blocked_realloc (ptr
, size
)
248 __realloc_hook
= old_realloc_hook
;
249 value
= realloc (ptr
, size
);
250 __realloc_hook
= &emacs_blocked_realloc
;
257 uninterrupt_malloc ()
259 old_free_hook
= __free_hook
;
260 __free_hook
= &emacs_blocked_free
;
262 old_malloc_hook
= __malloc_hook
;
263 __malloc_hook
= &emacs_blocked_malloc
;
265 old_realloc_hook
= __realloc_hook
;
266 __realloc_hook
= &emacs_blocked_realloc
;
270 /* Interval allocation. */
272 #ifdef USE_TEXT_PROPERTIES
273 #define INTERVAL_BLOCK_SIZE \
274 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
276 struct interval_block
278 struct interval_block
*next
;
279 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
282 struct interval_block
*interval_block
;
283 static int interval_block_index
;
285 INTERVAL interval_free_list
;
291 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
292 interval_block
->next
= 0;
293 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
294 interval_block_index
= 0;
295 interval_free_list
= 0;
298 #define INIT_INTERVALS init_intervals ()
305 if (interval_free_list
)
307 val
= interval_free_list
;
308 interval_free_list
= interval_free_list
->parent
;
312 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
314 register struct interval_block
*newi
315 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
317 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
318 newi
->next
= interval_block
;
319 interval_block
= newi
;
320 interval_block_index
= 0;
322 val
= &interval_block
->intervals
[interval_block_index
++];
324 consing_since_gc
+= sizeof (struct interval
);
325 RESET_INTERVAL (val
);
329 static int total_free_intervals
, total_intervals
;
331 /* Mark the pointers of one interval. */
334 mark_interval (i
, dummy
)
338 if (XMARKBIT (i
->plist
))
340 mark_object (&i
->plist
);
345 mark_interval_tree (tree
)
346 register INTERVAL tree
;
348 if (XMARKBIT (tree
->plist
))
351 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
354 #define MARK_INTERVAL_TREE(i) \
355 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
357 /* The oddity in the call to XUNMARK is necessary because XUNMARK
358 expands to an assigment to its argument, and most C compilers don't
359 support casts on the left operand of `='. */
360 #define UNMARK_BALANCE_INTERVALS(i) \
362 if (! NULL_INTERVAL_P (i)) \
364 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
365 (i) = balance_intervals (i); \
369 #else /* no interval use */
371 #define INIT_INTERVALS
373 #define UNMARK_BALANCE_INTERVALS(i)
374 #define MARK_INTERVAL_TREE(i)
376 #endif /* no interval use */
378 /* Floating point allocation. */
380 #ifdef LISP_FLOAT_TYPE
381 /* Allocation of float cells, just like conses */
382 /* We store float cells inside of float_blocks, allocating a new
383 float_block with malloc whenever necessary. Float cells reclaimed by
384 GC are put on a free list to be reallocated before allocating
385 any new float cells from the latest float_block.
387 Each float_block is just under 1020 bytes long,
388 since malloc really allocates in units of powers of two
389 and uses 4 bytes for its own overhead. */
391 #define FLOAT_BLOCK_SIZE \
392 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
396 struct float_block
*next
;
397 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
400 struct float_block
*float_block
;
401 int float_block_index
;
403 struct Lisp_Float
*float_free_list
;
408 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
409 float_block
->next
= 0;
410 bzero (float_block
->floats
, sizeof float_block
->floats
);
411 float_block_index
= 0;
415 /* Explicitly free a float cell. */
417 struct Lisp_Float
*ptr
;
419 XFASTINT (ptr
->type
) = (int) float_free_list
;
420 float_free_list
= ptr
;
424 make_float (float_value
)
427 register Lisp_Object val
;
431 XSET (val
, Lisp_Float
, float_free_list
);
432 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
436 if (float_block_index
== FLOAT_BLOCK_SIZE
)
438 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
439 VALIDATE_LISP_STORAGE (new, sizeof *new);
440 new->next
= float_block
;
442 float_block_index
= 0;
444 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
446 XFLOAT (val
)->data
= float_value
;
447 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
448 consing_since_gc
+= sizeof (struct Lisp_Float
);
452 #endif /* LISP_FLOAT_TYPE */
454 /* Allocation of cons cells */
455 /* We store cons cells inside of cons_blocks, allocating a new
456 cons_block with malloc whenever necessary. Cons cells reclaimed by
457 GC are put on a free list to be reallocated before allocating
458 any new cons cells from the latest cons_block.
460 Each cons_block is just under 1020 bytes long,
461 since malloc really allocates in units of powers of two
462 and uses 4 bytes for its own overhead. */
464 #define CONS_BLOCK_SIZE \
465 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
469 struct cons_block
*next
;
470 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
473 struct cons_block
*cons_block
;
474 int cons_block_index
;
476 struct Lisp_Cons
*cons_free_list
;
481 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
482 cons_block
->next
= 0;
483 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
484 cons_block_index
= 0;
488 /* Explicitly free a cons cell. */
490 struct Lisp_Cons
*ptr
;
492 XFASTINT (ptr
->car
) = (int) cons_free_list
;
493 cons_free_list
= ptr
;
496 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
497 "Create a new cons, give it CAR and CDR as components, and return it.")
499 Lisp_Object car
, cdr
;
501 register Lisp_Object val
;
505 XSET (val
, Lisp_Cons
, cons_free_list
);
506 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
510 if (cons_block_index
== CONS_BLOCK_SIZE
)
512 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
513 VALIDATE_LISP_STORAGE (new, sizeof *new);
514 new->next
= cons_block
;
516 cons_block_index
= 0;
518 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
520 XCONS (val
)->car
= car
;
521 XCONS (val
)->cdr
= cdr
;
522 consing_since_gc
+= sizeof (struct Lisp_Cons
);
526 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
527 "Return a newly created list with specified arguments as elements.\n\
528 Any number of arguments, even zero arguments, are allowed.")
531 register Lisp_Object
*args
;
533 register Lisp_Object len
, val
, val_tail
;
535 XFASTINT (len
) = nargs
;
536 val
= Fmake_list (len
, Qnil
);
538 while (!NILP (val_tail
))
540 XCONS (val_tail
)->car
= *args
++;
541 val_tail
= XCONS (val_tail
)->cdr
;
546 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
547 "Return a newly created list of length LENGTH, with each element being INIT.")
549 register Lisp_Object length
, init
;
551 register Lisp_Object val
;
554 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
555 length
= wrong_type_argument (Qnatnump
, length
);
556 size
= XINT (length
);
560 val
= Fcons (init
, val
);
564 /* Allocation of vectors */
566 struct Lisp_Vector
*all_vectors
;
568 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
569 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
570 See also the function `vector'.")
572 register Lisp_Object length
, init
;
574 register int sizei
, index
;
575 register Lisp_Object vector
;
576 register struct Lisp_Vector
*p
;
578 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
579 length
= wrong_type_argument (Qnatnump
, length
);
580 sizei
= XINT (length
);
582 p
= (struct Lisp_Vector
*) xmalloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
583 VALIDATE_LISP_STORAGE (p
, 0);
585 XSET (vector
, Lisp_Vector
, p
);
586 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
589 p
->next
= all_vectors
;
592 for (index
= 0; index
< sizei
; index
++)
593 p
->contents
[index
] = init
;
598 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
599 "Return a newly created vector with specified arguments as elements.\n\
600 Any number of arguments, even zero arguments, are allowed.")
605 register Lisp_Object len
, val
;
607 register struct Lisp_Vector
*p
;
609 XFASTINT (len
) = nargs
;
610 val
= Fmake_vector (len
, Qnil
);
612 for (index
= 0; index
< nargs
; index
++)
613 p
->contents
[index
] = args
[index
];
617 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
618 "Create a byte-code object with specified arguments as elements.\n\
619 The arguments should be the arglist, bytecode-string, constant vector,\n\
620 stack size, (optional) doc string, and (optional) interactive spec.\n\
621 The first four arguments are required; at most six have any\n\
627 register Lisp_Object len
, val
;
629 register struct Lisp_Vector
*p
;
631 XFASTINT (len
) = nargs
;
632 if (!NILP (Vpurify_flag
))
633 val
= make_pure_vector (len
);
635 val
= Fmake_vector (len
, Qnil
);
637 for (index
= 0; index
< nargs
; index
++)
639 if (!NILP (Vpurify_flag
))
640 args
[index
] = Fpurecopy (args
[index
]);
641 p
->contents
[index
] = args
[index
];
643 XSETTYPE (val
, Lisp_Compiled
);
647 /* Allocation of symbols.
648 Just like allocation of conses!
650 Each symbol_block is just under 1020 bytes long,
651 since malloc really allocates in units of powers of two
652 and uses 4 bytes for its own overhead. */
654 #define SYMBOL_BLOCK_SIZE \
655 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
659 struct symbol_block
*next
;
660 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
663 struct symbol_block
*symbol_block
;
664 int symbol_block_index
;
666 struct Lisp_Symbol
*symbol_free_list
;
671 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
672 symbol_block
->next
= 0;
673 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
674 symbol_block_index
= 0;
675 symbol_free_list
= 0;
678 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
679 "Return a newly allocated uninterned symbol whose name is NAME.\n\
680 Its value and function definition are void, and its property list is nil.")
684 register Lisp_Object val
;
685 register struct Lisp_Symbol
*p
;
687 CHECK_STRING (str
, 0);
689 if (symbol_free_list
)
691 XSET (val
, Lisp_Symbol
, symbol_free_list
);
693 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
697 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
699 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
700 VALIDATE_LISP_STORAGE (new, sizeof *new);
701 new->next
= symbol_block
;
703 symbol_block_index
= 0;
705 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
708 p
->name
= XSTRING (str
);
711 p
->function
= Qunbound
;
713 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
717 /* Allocation of markers.
718 Works like allocation of conses. */
720 #define MARKER_BLOCK_SIZE \
721 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
725 struct marker_block
*next
;
726 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
729 struct marker_block
*marker_block
;
730 int marker_block_index
;
732 struct Lisp_Marker
*marker_free_list
;
737 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
738 marker_block
->next
= 0;
739 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
740 marker_block_index
= 0;
741 marker_free_list
= 0;
744 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
745 "Return a newly allocated marker which does not point at any place.")
748 register Lisp_Object val
;
749 register struct Lisp_Marker
*p
;
751 if (marker_free_list
)
753 XSET (val
, Lisp_Marker
, marker_free_list
);
755 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
759 if (marker_block_index
== MARKER_BLOCK_SIZE
)
761 struct marker_block
*new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
762 VALIDATE_LISP_STORAGE (new, sizeof *new);
763 new->next
= marker_block
;
765 marker_block_index
= 0;
767 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
773 consing_since_gc
+= sizeof (struct Lisp_Marker
);
777 /* Allocation of strings */
779 /* Strings reside inside of string_blocks. The entire data of the string,
780 both the size and the contents, live in part of the `chars' component of a string_block.
781 The `pos' component is the index within `chars' of the first free byte.
783 first_string_block points to the first string_block ever allocated.
784 Each block points to the next one with its `next' field.
785 The `prev' fields chain in reverse order.
786 The last one allocated is the one currently being filled.
787 current_string_block points to it.
789 The string_blocks that hold individual large strings
790 go in a separate chain, started by large_string_blocks. */
793 /* String blocks contain this many useful bytes.
794 8188 is power of 2, minus 4 for malloc overhead. */
795 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
797 /* A string bigger than this gets its own specially-made string block
798 if it doesn't fit in the current one. */
799 #define STRING_BLOCK_OUTSIZE 1024
801 struct string_block_head
803 struct string_block
*next
, *prev
;
809 struct string_block
*next
, *prev
;
811 char chars
[STRING_BLOCK_SIZE
];
814 /* This points to the string block we are now allocating strings. */
816 struct string_block
*current_string_block
;
818 /* This points to the oldest string block, the one that starts the chain. */
820 struct string_block
*first_string_block
;
822 /* Last string block in chain of those made for individual large strings. */
824 struct string_block
*large_string_blocks
;
826 /* If SIZE is the length of a string, this returns how many bytes
827 the string occupies in a string_block (including padding). */
829 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
831 #define PAD (sizeof (int))
834 #define STRING_FULLSIZE(SIZE) \
835 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
841 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
842 first_string_block
= current_string_block
;
843 consing_since_gc
+= sizeof (struct string_block
);
844 current_string_block
->next
= 0;
845 current_string_block
->prev
= 0;
846 current_string_block
->pos
= 0;
847 large_string_blocks
= 0;
850 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
851 "Return a newly created string of length LENGTH, with each element being INIT.\n\
852 Both LENGTH and INIT must be numbers.")
854 Lisp_Object length
, init
;
856 register Lisp_Object val
;
857 register unsigned char *p
, *end
, c
;
859 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
860 length
= wrong_type_argument (Qnatnump
, length
);
861 CHECK_NUMBER (init
, 1);
862 val
= make_uninit_string (XINT (length
));
864 p
= XSTRING (val
)->data
;
865 end
= p
+ XSTRING (val
)->size
;
873 make_string (contents
, length
)
877 register Lisp_Object val
;
878 val
= make_uninit_string (length
);
879 bcopy (contents
, XSTRING (val
)->data
, length
);
887 return make_string (str
, strlen (str
));
891 make_uninit_string (length
)
894 register Lisp_Object val
;
895 register int fullsize
= STRING_FULLSIZE (length
);
897 if (length
< 0) abort ();
899 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
900 /* This string can fit in the current string block */
902 XSET (val
, Lisp_String
,
903 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
904 current_string_block
->pos
+= fullsize
;
906 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
907 /* This string gets its own string block */
909 register struct string_block
*new
910 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
911 VALIDATE_LISP_STORAGE (new, 0);
912 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
914 new->next
= large_string_blocks
;
915 large_string_blocks
= new;
916 XSET (val
, Lisp_String
,
917 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
920 /* Make a new current string block and start it off with this string */
922 register struct string_block
*new
923 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
924 VALIDATE_LISP_STORAGE (new, sizeof *new);
925 consing_since_gc
+= sizeof (struct string_block
);
926 current_string_block
->next
= new;
927 new->prev
= current_string_block
;
929 current_string_block
= new;
931 XSET (val
, Lisp_String
,
932 (struct Lisp_String
*) current_string_block
->chars
);
935 XSTRING (val
)->size
= length
;
936 XSTRING (val
)->data
[length
] = 0;
937 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
942 /* Return a newly created vector or string with specified arguments as
943 elements. If all the arguments are characters that can fit
944 in a string of events, make a string; otherwise, make a vector.
946 Any number of arguments, even zero arguments, are allowed. */
949 make_event_array (nargs
, args
)
955 for (i
= 0; i
< nargs
; i
++)
956 /* The things that fit in a string
957 are characters that are in 0...127 after discarding the meta bit. */
958 if (XTYPE (args
[i
]) != Lisp_Int
959 || (XUINT (args
[i
]) & ~CHAR_META
) >= 0200)
960 return Fvector (nargs
, args
);
962 /* Since the loop exited, we know that all the things in it are
963 characters, so we can make a string. */
965 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
967 for (i
= 0; i
< nargs
; i
++)
969 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
970 /* Move the meta bit to the right place for a string char. */
971 if (XINT (args
[i
]) & CHAR_META
)
972 XSTRING (result
)->data
[i
] |= 0x80;
979 /* Pure storage management. */
981 /* Must get an error if pure storage is full,
982 since if it cannot hold a large string
983 it may be able to hold conses that point to that string;
984 then the string is not protected from gc. */
987 make_pure_string (data
, length
)
991 register Lisp_Object
new;
992 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
994 if (pureptr
+ size
> PURESIZE
)
995 error ("Pure Lisp storage exhausted");
996 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
997 XSTRING (new)->size
= length
;
998 bcopy (data
, XSTRING (new)->data
, length
);
999 XSTRING (new)->data
[length
] = 0;
1000 pureptr
+= (size
+ sizeof (int) - 1)
1001 / sizeof (int) * sizeof (int);
1006 pure_cons (car
, cdr
)
1007 Lisp_Object car
, cdr
;
1009 register Lisp_Object
new;
1011 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1012 error ("Pure Lisp storage exhausted");
1013 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
1014 pureptr
+= sizeof (struct Lisp_Cons
);
1015 XCONS (new)->car
= Fpurecopy (car
);
1016 XCONS (new)->cdr
= Fpurecopy (cdr
);
1020 #ifdef LISP_FLOAT_TYPE
1023 make_pure_float (num
)
1026 register Lisp_Object
new;
1028 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1029 (double) boundary. Some architectures (like the sparc) require
1030 this, and I suspect that floats are rare enough that it's no
1031 tragedy for those that do. */
1034 char *p
= PUREBEG
+ pureptr
;
1038 alignment
= __alignof (struct Lisp_Float
);
1040 alignment
= sizeof (struct Lisp_Float
);
1043 alignment
= sizeof (struct Lisp_Float
);
1045 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1046 pureptr
= p
- PUREBEG
;
1049 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1050 error ("Pure Lisp storage exhausted");
1051 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1052 pureptr
+= sizeof (struct Lisp_Float
);
1053 XFLOAT (new)->data
= num
;
1054 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1058 #endif /* LISP_FLOAT_TYPE */
1061 make_pure_vector (len
)
1064 register Lisp_Object
new;
1065 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1067 if (pureptr
+ size
> PURESIZE
)
1068 error ("Pure Lisp storage exhausted");
1070 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1072 XVECTOR (new)->size
= len
;
1076 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1077 "Make a copy of OBJECT in pure storage.\n\
1078 Recursively copies contents of vectors and cons cells.\n\
1079 Does not copy symbols.")
1081 register Lisp_Object obj
;
1083 register Lisp_Object
new, tem
;
1086 if (NILP (Vpurify_flag
))
1089 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1090 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1093 #ifdef SWITCH_ENUM_BUG
1094 switch ((int) XTYPE (obj
))
1096 switch (XTYPE (obj
))
1100 error ("Attempt to copy a marker to pure storage");
1103 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1105 #ifdef LISP_FLOAT_TYPE
1107 return make_pure_float (XFLOAT (obj
)->data
);
1108 #endif /* LISP_FLOAT_TYPE */
1111 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1115 new = make_pure_vector (XVECTOR (obj
)->size
);
1116 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1118 tem
= XVECTOR (obj
)->contents
[i
];
1119 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1121 XSETTYPE (new, XTYPE (obj
));
1129 /* Recording what needs to be marked for gc. */
1131 struct gcpro
*gcprolist
;
1133 #define NSTATICS 512
1135 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1139 /* Put an entry in staticvec, pointing at the variable whose address is given */
1142 staticpro (varaddress
)
1143 Lisp_Object
*varaddress
;
1145 staticvec
[staticidx
++] = varaddress
;
1146 if (staticidx
>= NSTATICS
)
1154 struct catchtag
*next
;
1155 /* jmp_buf jmp; /* We don't need this for GC purposes */
1160 struct backtrace
*next
;
1161 Lisp_Object
*function
;
1162 Lisp_Object
*args
; /* Points to vector of args. */
1163 int nargs
; /* length of vector */
1164 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1168 /* Two flags that are set during GC in the `size' component
1169 of a string or vector. On some machines, these flags
1170 are defined by the m- file to be different bits. */
1172 /* On vector, means it has been marked.
1173 On string size field or a reference to a string,
1174 means not the last reference in the chain. */
1176 #ifndef ARRAY_MARK_FLAG
1177 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1178 #endif /* no ARRAY_MARK_FLAG */
1180 /* Any slot that is a Lisp_Object can point to a string
1181 and thus can be put on a string's reference-chain
1182 and thus may need to have its ARRAY_MARK_FLAG set.
1183 This includes the slots whose markbits are used to mark
1184 the containing objects. */
1186 #if ARRAY_MARK_FLAG == MARKBIT
1190 /* Garbage collection! */
1192 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1193 int total_free_conses
, total_free_markers
, total_free_symbols
;
1194 #ifdef LISP_FLOAT_TYPE
1195 int total_free_floats
, total_floats
;
1196 #endif /* LISP_FLOAT_TYPE */
1198 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1199 "Reclaim storage for Lisp objects no longer needed.\n\
1200 Returns info on amount of space in use:\n\
1201 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1202 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1203 (USED-FLOATS . FREE-FLOATS))\n\
1204 Garbage collection happens automatically if you cons more than\n\
1205 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1208 register struct gcpro
*tail
;
1209 register struct specbinding
*bind
;
1210 struct catchtag
*catch;
1211 struct handler
*handler
;
1212 register struct backtrace
*backlist
;
1213 register Lisp_Object tem
;
1214 char *omessage
= echo_area_glyphs
;
1215 char stack_top_variable
;
1218 /* Save a copy of the contents of the stack, for debugging. */
1219 #if MAX_SAVE_STACK > 0
1220 if (NILP (Vpurify_flag
))
1222 i
= &stack_top_variable
- stack_bottom
;
1224 if (i
< MAX_SAVE_STACK
)
1226 if (stack_copy
== 0)
1227 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1228 else if (stack_copy_size
< i
)
1229 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1232 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1233 bcopy (stack_bottom
, stack_copy
, i
);
1235 bcopy (&stack_top_variable
, stack_copy
, i
);
1239 #endif /* MAX_SAVE_STACK > 0 */
1241 if (!noninteractive
)
1242 message1 ("Garbage collecting...");
1244 /* Don't keep command history around forever */
1245 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1247 XCONS (tem
)->cdr
= Qnil
;
1249 /* Likewise for undo information. */
1251 register struct buffer
*nextb
= all_buffers
;
1255 /* If a buffer's undo list is Qt, that means that undo is
1256 turned off in that buffer. Calling truncate_undo_list on
1257 Qt tends to return NULL, which effectively turns undo back on.
1258 So don't call truncate_undo_list if undo_list is Qt. */
1259 if (! EQ (nextb
->undo_list
, Qt
))
1261 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1263 nextb
= nextb
->next
;
1269 /* clear_marks (); */
1271 /* In each "large string", set the MARKBIT of the size field.
1272 That enables mark_object to recognize them. */
1274 register struct string_block
*b
;
1275 for (b
= large_string_blocks
; b
; b
= b
->next
)
1276 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1279 /* Mark all the special slots that serve as the roots of accessibility.
1281 Usually the special slots to mark are contained in particular structures.
1282 Then we know no slot is marked twice because the structures don't overlap.
1283 In some cases, the structures point to the slots to be marked.
1284 For these, we use MARKBIT to avoid double marking of the slot. */
1286 for (i
= 0; i
< staticidx
; i
++)
1287 mark_object (staticvec
[i
]);
1288 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1289 for (i
= 0; i
< tail
->nvars
; i
++)
1290 if (!XMARKBIT (tail
->var
[i
]))
1292 mark_object (&tail
->var
[i
]);
1293 XMARK (tail
->var
[i
]);
1295 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1297 mark_object (&bind
->symbol
);
1298 mark_object (&bind
->old_value
);
1300 for (catch = catchlist
; catch; catch = catch->next
)
1302 mark_object (&catch->tag
);
1303 mark_object (&catch->val
);
1305 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1307 mark_object (&handler
->handler
);
1308 mark_object (&handler
->var
);
1310 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1312 if (!XMARKBIT (*backlist
->function
))
1314 mark_object (backlist
->function
);
1315 XMARK (*backlist
->function
);
1317 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1320 i
= backlist
->nargs
- 1;
1322 if (!XMARKBIT (backlist
->args
[i
]))
1324 mark_object (&backlist
->args
[i
]);
1325 XMARK (backlist
->args
[i
]);
1331 /* Clear the mark bits that we set in certain root slots. */
1333 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1334 for (i
= 0; i
< tail
->nvars
; i
++)
1335 XUNMARK (tail
->var
[i
]);
1336 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1338 XUNMARK (*backlist
->function
);
1339 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1342 i
= backlist
->nargs
- 1;
1344 XUNMARK (backlist
->args
[i
]);
1346 XUNMARK (buffer_defaults
.name
);
1347 XUNMARK (buffer_local_symbols
.name
);
1349 /* clear_marks (); */
1352 consing_since_gc
= 0;
1353 if (gc_cons_threshold
< 10000)
1354 gc_cons_threshold
= 10000;
1357 message1 (omessage
);
1358 else if (!noninteractive
)
1359 message1 ("Garbage collecting...done");
1361 return Fcons (Fcons (make_number (total_conses
),
1362 make_number (total_free_conses
)),
1363 Fcons (Fcons (make_number (total_symbols
),
1364 make_number (total_free_symbols
)),
1365 Fcons (Fcons (make_number (total_markers
),
1366 make_number (total_free_markers
)),
1367 Fcons (make_number (total_string_size
),
1368 Fcons (make_number (total_vector_size
),
1370 #ifdef LISP_FLOAT_TYPE
1371 Fcons (Fcons (make_number (total_floats
),
1372 make_number (total_free_floats
)),
1374 #else /* not LISP_FLOAT_TYPE */
1376 #endif /* not LISP_FLOAT_TYPE */
1384 /* Clear marks on all conses */
1386 register struct cons_block
*cblk
;
1387 register int lim
= cons_block_index
;
1389 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1392 for (i
= 0; i
< lim
; i
++)
1393 XUNMARK (cblk
->conses
[i
].car
);
1394 lim
= CONS_BLOCK_SIZE
;
1397 /* Clear marks on all symbols */
1399 register struct symbol_block
*sblk
;
1400 register int lim
= symbol_block_index
;
1402 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1405 for (i
= 0; i
< lim
; i
++)
1407 XUNMARK (sblk
->symbols
[i
].plist
);
1409 lim
= SYMBOL_BLOCK_SIZE
;
1412 /* Clear marks on all markers */
1414 register struct marker_block
*sblk
;
1415 register int lim
= marker_block_index
;
1417 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1420 for (i
= 0; i
< lim
; i
++)
1421 XUNMARK (sblk
->markers
[i
].chain
);
1422 lim
= MARKER_BLOCK_SIZE
;
1425 /* Clear mark bits on all buffers */
1427 register struct buffer
*nextb
= all_buffers
;
1431 XUNMARK (nextb
->name
);
1432 nextb
= nextb
->next
;
1438 /* Mark reference to a Lisp_Object.
1439 If the object referred to has not been seen yet, recursively mark
1440 all the references contained in it.
1442 If the object referenced is a short string, the referrencing slot
1443 is threaded into a chain of such slots, pointed to from
1444 the `size' field of the string. The actual string size
1445 lives in the last slot in the chain. We recognize the end
1446 because it is < (unsigned) STRING_BLOCK_SIZE. */
1448 #define LAST_MARKED_SIZE 500
1449 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1450 int last_marked_index
;
1453 mark_object (objptr
)
1454 Lisp_Object
*objptr
;
1456 register Lisp_Object obj
;
1463 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1464 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1467 last_marked
[last_marked_index
++] = objptr
;
1468 if (last_marked_index
== LAST_MARKED_SIZE
)
1469 last_marked_index
= 0;
1471 #ifdef SWITCH_ENUM_BUG
1472 switch ((int) XGCTYPE (obj
))
1474 switch (XGCTYPE (obj
))
1479 register struct Lisp_String
*ptr
= XSTRING (obj
);
1481 MARK_INTERVAL_TREE (ptr
->intervals
);
1482 if (ptr
->size
& MARKBIT
)
1483 /* A large string. Just set ARRAY_MARK_FLAG. */
1484 ptr
->size
|= ARRAY_MARK_FLAG
;
1487 /* A small string. Put this reference
1488 into the chain of references to it.
1489 The address OBJPTR is even, so if the address
1490 includes MARKBIT, put it in the low bit
1491 when we store OBJPTR into the size field. */
1493 if (XMARKBIT (*objptr
))
1495 XFASTINT (*objptr
) = ptr
->size
;
1499 XFASTINT (*objptr
) = ptr
->size
;
1500 if ((int)objptr
& 1) abort ();
1501 ptr
->size
= (int) objptr
& ~MARKBIT
;
1502 if ((int) objptr
& MARKBIT
)
1511 case Lisp_Window_Configuration
:
1513 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1514 register int size
= ptr
->size
;
1515 struct Lisp_Vector
*volatile ptr1
= ptr
;
1518 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1519 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1520 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1524 mark_object (&ptr
->contents
[i
]);
1530 /* We could treat this just like a vector, but it is better
1531 to save the COMPILED_CONSTANTS element for last and avoid recursion
1534 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1535 register int size
= ptr
->size
;
1536 struct Lisp_Vector
*volatile ptr1
= ptr
;
1539 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1540 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1541 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1545 if (i
!= COMPILED_CONSTANTS
)
1546 mark_object (&ptr
->contents
[i
]);
1548 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1556 register struct frame
*ptr
= XFRAME (obj
);
1557 register int size
= ptr
->size
;
1559 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1560 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1562 mark_object (&ptr
->name
);
1563 mark_object (&ptr
->focus_frame
);
1564 mark_object (&ptr
->width
);
1565 mark_object (&ptr
->height
);
1566 mark_object (&ptr
->selected_window
);
1567 mark_object (&ptr
->minibuffer_window
);
1568 mark_object (&ptr
->param_alist
);
1569 mark_object (&ptr
->scroll_bars
);
1570 mark_object (&ptr
->condemned_scroll_bars
);
1571 mark_object (&ptr
->menu_bar_items
);
1572 mark_object (&ptr
->face_alist
);
1575 #endif /* MULTI_FRAME */
1579 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1580 struct Lisp_Symbol
*ptrx
;
1582 if (XMARKBIT (ptr
->plist
)) break;
1584 mark_object ((Lisp_Object
*) &ptr
->value
);
1585 mark_object (&ptr
->function
);
1586 mark_object (&ptr
->plist
);
1587 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1588 mark_object (&ptr
->name
);
1592 ptrx
= ptr
; /* Use pf ptrx avoids compiler bug on Sun */
1593 XSETSYMBOL (obj
, ptrx
);
1600 XMARK (XMARKER (obj
)->chain
);
1601 /* DO NOT mark thru the marker's chain.
1602 The buffer's markers chain does not preserve markers from gc;
1603 instead, markers are removed from the chain when freed by gc. */
1607 case Lisp_Buffer_Local_Value
:
1608 case Lisp_Some_Buffer_Local_Value
:
1610 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1611 if (XMARKBIT (ptr
->car
)) break;
1613 /* If the cdr is nil, avoid recursion for the car. */
1614 if (EQ (ptr
->cdr
, Qnil
))
1621 mark_object (&ptr
->car
);
1627 #ifdef LISP_FLOAT_TYPE
1629 XMARK (XFLOAT (obj
)->type
);
1631 #endif /* LISP_FLOAT_TYPE */
1634 if (!XMARKBIT (XBUFFER (obj
)->name
))
1644 case Lisp_Buffer_Objfwd
:
1645 case Lisp_Internal_Stream
:
1646 /* Don't bother with Lisp_Buffer_Objfwd,
1647 since all markable slots in current buffer marked anyway. */
1648 /* Don't need to do Lisp_Objfwd, since the places they point
1649 are protected with staticpro. */
1657 /* Mark the pointers in a buffer structure. */
1663 register struct buffer
*buffer
= XBUFFER (buf
);
1664 register Lisp_Object
*ptr
;
1666 /* This is the buffer's markbit */
1667 mark_object (&buffer
->name
);
1668 XMARK (buffer
->name
);
1670 MARK_INTERVAL_TREE (buffer
->intervals
);
1673 mark_object (buffer
->syntax_table
);
1675 /* Mark the various string-pointers in the buffer object.
1676 Since the strings may be relocated, we must mark them
1677 in their actual slots. So gc_sweep must convert each slot
1678 back to an ordinary C pointer. */
1679 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1680 Lisp_String
, buffer
->upcase_table
);
1681 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1682 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1683 Lisp_String
, buffer
->downcase_table
);
1684 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1686 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1687 Lisp_String
, buffer
->sort_table
);
1688 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1689 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1690 Lisp_String
, buffer
->folding_sort_table
);
1691 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1694 for (ptr
= &buffer
->name
+ 1;
1695 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1700 /* Sweep: find all structures not marked, and free them. */
1705 total_string_size
= 0;
1708 /* Put all unmarked conses on free list */
1710 register struct cons_block
*cblk
;
1711 register int lim
= cons_block_index
;
1712 register int num_free
= 0, num_used
= 0;
1716 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1719 for (i
= 0; i
< lim
; i
++)
1720 if (!XMARKBIT (cblk
->conses
[i
].car
))
1722 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1724 cons_free_list
= &cblk
->conses
[i
];
1729 XUNMARK (cblk
->conses
[i
].car
);
1731 lim
= CONS_BLOCK_SIZE
;
1733 total_conses
= num_used
;
1734 total_free_conses
= num_free
;
1737 #ifdef LISP_FLOAT_TYPE
1738 /* Put all unmarked floats on free list */
1740 register struct float_block
*fblk
;
1741 register int lim
= float_block_index
;
1742 register int num_free
= 0, num_used
= 0;
1744 float_free_list
= 0;
1746 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1749 for (i
= 0; i
< lim
; i
++)
1750 if (!XMARKBIT (fblk
->floats
[i
].type
))
1752 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1754 float_free_list
= &fblk
->floats
[i
];
1759 XUNMARK (fblk
->floats
[i
].type
);
1761 lim
= FLOAT_BLOCK_SIZE
;
1763 total_floats
= num_used
;
1764 total_free_floats
= num_free
;
1766 #endif /* LISP_FLOAT_TYPE */
1768 #ifdef USE_TEXT_PROPERTIES
1769 /* Put all unmarked intervals on free list */
1771 register struct interval_block
*iblk
;
1772 register int lim
= interval_block_index
;
1773 register int num_free
= 0, num_used
= 0;
1775 interval_free_list
= 0;
1777 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1781 for (i
= 0; i
< lim
; i
++)
1783 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1785 iblk
->intervals
[i
].parent
= interval_free_list
;
1786 interval_free_list
= &iblk
->intervals
[i
];
1792 XUNMARK (iblk
->intervals
[i
].plist
);
1795 lim
= INTERVAL_BLOCK_SIZE
;
1797 total_intervals
= num_used
;
1798 total_free_intervals
= num_free
;
1800 #endif /* USE_TEXT_PROPERTIES */
1802 /* Put all unmarked symbols on free list */
1804 register struct symbol_block
*sblk
;
1805 register int lim
= symbol_block_index
;
1806 register int num_free
= 0, num_used
= 0;
1808 symbol_free_list
= 0;
1810 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1813 for (i
= 0; i
< lim
; i
++)
1814 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1816 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1817 symbol_free_list
= &sblk
->symbols
[i
];
1823 sblk
->symbols
[i
].name
1824 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1825 XUNMARK (sblk
->symbols
[i
].plist
);
1827 lim
= SYMBOL_BLOCK_SIZE
;
1829 total_symbols
= num_used
;
1830 total_free_symbols
= num_free
;
1834 /* Put all unmarked markers on free list.
1835 Dechain each one first from the buffer it points into. */
1837 register struct marker_block
*mblk
;
1838 struct Lisp_Marker
*tem1
;
1839 register int lim
= marker_block_index
;
1840 register int num_free
= 0, num_used
= 0;
1842 marker_free_list
= 0;
1844 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1847 for (i
= 0; i
< lim
; i
++)
1848 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1851 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1852 XSET (tem
, Lisp_Marker
, tem1
);
1853 unchain_marker (tem
);
1854 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1855 marker_free_list
= &mblk
->markers
[i
];
1861 XUNMARK (mblk
->markers
[i
].chain
);
1863 lim
= MARKER_BLOCK_SIZE
;
1866 total_markers
= num_used
;
1867 total_free_markers
= num_free
;
1870 /* Free all unmarked buffers */
1872 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1875 if (!XMARKBIT (buffer
->name
))
1878 prev
->next
= buffer
->next
;
1880 all_buffers
= buffer
->next
;
1881 next
= buffer
->next
;
1887 XUNMARK (buffer
->name
);
1888 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1891 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1892 for purposes of marking and relocation.
1893 Turn them back into C pointers now. */
1894 buffer
->upcase_table
1895 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1896 buffer
->downcase_table
1897 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1899 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1900 buffer
->folding_sort_table
1901 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1904 prev
= buffer
, buffer
= buffer
->next
;
1908 #endif /* standalone */
1910 /* Free all unmarked vectors */
1912 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1913 total_vector_size
= 0;
1916 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1919 prev
->next
= vector
->next
;
1921 all_vectors
= vector
->next
;
1922 next
= vector
->next
;
1928 vector
->size
&= ~ARRAY_MARK_FLAG
;
1929 total_vector_size
+= vector
->size
;
1930 prev
= vector
, vector
= vector
->next
;
1934 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1936 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1939 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1942 prev
->next
= sb
->next
;
1944 large_string_blocks
= sb
->next
;
1951 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1952 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1953 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1954 prev
= sb
, sb
= sb
->next
;
1959 /* Compactify strings, relocate references, and free empty string blocks. */
1964 /* String block of old strings we are scanning. */
1965 register struct string_block
*from_sb
;
1966 /* A preceding string block (or maybe the same one)
1967 where we are copying the still-live strings to. */
1968 register struct string_block
*to_sb
;
1972 to_sb
= first_string_block
;
1975 /* Scan each existing string block sequentially, string by string. */
1976 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1979 /* POS is the index of the next string in the block. */
1980 while (pos
< from_sb
->pos
)
1982 register struct Lisp_String
*nextstr
1983 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1985 register struct Lisp_String
*newaddr
;
1986 register int size
= nextstr
->size
;
1988 /* NEXTSTR is the old address of the next string.
1989 Just skip it if it isn't marked. */
1990 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1992 /* It is marked, so its size field is really a chain of refs.
1993 Find the end of the chain, where the actual size lives. */
1994 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1996 if (size
& 1) size
^= MARKBIT
| 1;
1997 size
= *(int *)size
& ~MARKBIT
;
2000 total_string_size
+= size
;
2002 /* If it won't fit in TO_SB, close it out,
2003 and move to the next sb. Keep doing so until
2004 TO_SB reaches a large enough, empty enough string block.
2005 We know that TO_SB cannot advance past FROM_SB here
2006 since FROM_SB is large enough to contain this string.
2007 Any string blocks skipped here
2008 will be patched out and freed later. */
2009 while (to_pos
+ STRING_FULLSIZE (size
)
2010 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2012 to_sb
->pos
= to_pos
;
2013 to_sb
= to_sb
->next
;
2016 /* Compute new address of this string
2017 and update TO_POS for the space being used. */
2018 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2019 to_pos
+= STRING_FULLSIZE (size
);
2021 /* Copy the string itself to the new place. */
2022 if (nextstr
!= newaddr
)
2023 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
2024 + INTERVAL_PTR_SIZE
);
2026 /* Go through NEXTSTR's chain of references
2027 and make each slot in the chain point to
2028 the new address of this string. */
2029 size
= newaddr
->size
;
2030 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2032 register Lisp_Object
*objptr
;
2033 if (size
& 1) size
^= MARKBIT
| 1;
2034 objptr
= (Lisp_Object
*)size
;
2036 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2037 if (XMARKBIT (*objptr
))
2039 XSET (*objptr
, Lisp_String
, newaddr
);
2043 XSET (*objptr
, Lisp_String
, newaddr
);
2045 /* Store the actual size in the size field. */
2046 newaddr
->size
= size
;
2048 pos
+= STRING_FULLSIZE (size
);
2052 /* Close out the last string block still used and free any that follow. */
2053 to_sb
->pos
= to_pos
;
2054 current_string_block
= to_sb
;
2056 from_sb
= to_sb
->next
;
2060 to_sb
= from_sb
->next
;
2065 /* Free any empty string blocks further back in the chain.
2066 This loop will never free first_string_block, but it is very
2067 unlikely that that one will become empty, so why bother checking? */
2069 from_sb
= first_string_block
;
2070 while (to_sb
= from_sb
->next
)
2072 if (to_sb
->pos
== 0)
2074 if (from_sb
->next
= to_sb
->next
)
2075 from_sb
->next
->prev
= from_sb
;
2083 /* Debugging aids. */
2085 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2086 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2087 This may be helpful in debugging Emacs's memory usage.\n\
2088 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2093 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2099 /* Initialization */
2103 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2106 pure_size
= PURESIZE
;
2109 ignore_warnings
= 1;
2114 #ifdef LISP_FLOAT_TYPE
2116 #endif /* LISP_FLOAT_TYPE */
2119 ignore_warnings
= 0;
2122 consing_since_gc
= 0;
2123 gc_cons_threshold
= 100000;
2124 #ifdef VIRT_ADDR_VARIES
2125 malloc_sbrk_unused
= 1<<22; /* A large number */
2126 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2127 #endif /* VIRT_ADDR_VARIES */
2138 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2139 "*Number of bytes of consing between garbage collections.\n\
2140 Garbage collection can happen automatically once this many bytes have been\n\
2141 allocated since the last garbage collection. All data types count.\n\n\
2142 Garbage collection happens automatically only when `eval' is called.\n\n\
2143 By binding this temporarily to a large number, you can effectively\n\
2144 prevent garbage collection during a part of the program.");
2146 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2147 "Number of bytes of sharable Lisp data allocated so far.");
2150 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2151 "Number of bytes of unshared memory allocated in this session.");
2153 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2154 "Number of bytes of unshared memory remaining available in this session.");
2157 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2158 "Non-nil means loading Lisp code in order to dump an executable.\n\
2159 This means that certain objects should be allocated in shared (pure) space.");
2161 DEFVAR_INT ("undo-limit", &undo_limit
,
2162 "Keep no more undo information once it exceeds this size.\n\
2163 This limit is applied when garbage collection happens.\n\
2164 The size is counted as the number of bytes occupied,\n\
2165 which includes both saved text and other data.");
2168 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2169 "Don't keep more than this much size of undo information.\n\
2170 A command which pushes past this size is itself forgotten.\n\
2171 This limit is applied when garbage collection happens.\n\
2172 The size is counted as the number of bytes occupied,\n\
2173 which includes both saved text and other data.");
2174 undo_strong_limit
= 30000;
2179 defsubr (&Smake_byte_code
);
2180 defsubr (&Smake_list
);
2181 defsubr (&Smake_vector
);
2182 defsubr (&Smake_string
);
2183 defsubr (&Smake_symbol
);
2184 defsubr (&Smake_marker
);
2185 defsubr (&Spurecopy
);
2186 defsubr (&Sgarbage_collect
);
2187 defsubr (&Smemory_limit
);