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 /* Pre-computed signal argument for use when memory is exhausted. */
102 static Lisp_Object memory_signal_data
;
104 /* Maximum amount of C stack to save when a GC happens. */
106 #ifndef MAX_SAVE_STACK
107 #define MAX_SAVE_STACK 16000
110 /* Buffer in which we save a copy of the C stack at each GC. */
115 /* Non-zero means ignore malloc warnings. Set during initialization. */
118 static void mark_object (), mark_buffer ();
119 static void clear_marks (), gc_sweep ();
120 static void compact_strings ();
122 /* Versions of malloc and realloc that print warnings as memory gets full. */
125 malloc_warning_1 (str
)
128 Fprinc (str
, Vstandard_output
);
129 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
130 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
131 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
135 /* malloc calls this if it finds we are near exhausting storage */
139 pending_malloc_warning
= str
;
142 display_malloc_warning ()
144 register Lisp_Object val
;
146 val
= build_string (pending_malloc_warning
);
147 pending_malloc_warning
= 0;
148 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
151 /* Called if malloc returns zero */
154 /* This used to call error, but if we've run out of memory, we could get
155 infinite recursion trying to build the string. */
157 Fsignal (Qerror
, memory_signal_data
);
160 /* like malloc routines but check for no memory and block interrupt input. */
169 val
= (long *) malloc (size
);
172 if (!val
&& size
) memory_full ();
177 xrealloc (block
, size
)
184 /* We must call malloc explicitly when BLOCK is 0, since some
185 reallocs don't do this. */
187 val
= (long *) malloc (size
);
189 val
= (long *) realloc (block
, size
);
192 if (!val
&& size
) memory_full ();
206 /* Arranging to disable input signals while we're in malloc.
208 This only works with GNU malloc. To help out systems which can't
209 use GNU malloc, all the calls to malloc, realloc, and free
210 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
211 pairs; unfortunately, we have no idea what C library functions
212 might call malloc, so we can't really protect them unless you're
213 using GNU malloc. Fortunately, most of the major operating can use
216 #ifndef SYSTEM_MALLOC
217 extern void * (*__malloc_hook
) ();
218 static void * (*old_malloc_hook
) ();
219 extern void * (*__realloc_hook
) ();
220 static void * (*old_realloc_hook
) ();
221 extern void (*__free_hook
) ();
222 static void (*old_free_hook
) ();
225 emacs_blocked_free (ptr
)
229 __free_hook
= old_free_hook
;
231 __free_hook
= emacs_blocked_free
;
236 emacs_blocked_malloc (size
)
242 __malloc_hook
= old_malloc_hook
;
243 value
= (void *) malloc (size
);
244 __malloc_hook
= emacs_blocked_malloc
;
251 emacs_blocked_realloc (ptr
, size
)
258 __realloc_hook
= old_realloc_hook
;
259 value
= (void *) realloc (ptr
, size
);
260 __realloc_hook
= emacs_blocked_realloc
;
267 uninterrupt_malloc ()
269 old_free_hook
= __free_hook
;
270 __free_hook
= emacs_blocked_free
;
272 old_malloc_hook
= __malloc_hook
;
273 __malloc_hook
= emacs_blocked_malloc
;
275 old_realloc_hook
= __realloc_hook
;
276 __realloc_hook
= emacs_blocked_realloc
;
280 /* Interval allocation. */
282 #ifdef USE_TEXT_PROPERTIES
283 #define INTERVAL_BLOCK_SIZE \
284 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
286 struct interval_block
288 struct interval_block
*next
;
289 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
292 struct interval_block
*interval_block
;
293 static int interval_block_index
;
295 INTERVAL interval_free_list
;
301 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
302 interval_block
->next
= 0;
303 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
304 interval_block_index
= 0;
305 interval_free_list
= 0;
308 #define INIT_INTERVALS init_intervals ()
315 if (interval_free_list
)
317 val
= interval_free_list
;
318 interval_free_list
= interval_free_list
->parent
;
322 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
324 register struct interval_block
*newi
325 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
327 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
328 newi
->next
= interval_block
;
329 interval_block
= newi
;
330 interval_block_index
= 0;
332 val
= &interval_block
->intervals
[interval_block_index
++];
334 consing_since_gc
+= sizeof (struct interval
);
335 RESET_INTERVAL (val
);
339 static int total_free_intervals
, total_intervals
;
341 /* Mark the pointers of one interval. */
344 mark_interval (i
, dummy
)
348 if (XMARKBIT (i
->plist
))
350 mark_object (&i
->plist
);
355 mark_interval_tree (tree
)
356 register INTERVAL tree
;
358 /* No need to test if this tree has been marked already; this
359 function is always called through the MARK_INTERVAL_TREE macro,
360 which takes care of that. */
362 /* XMARK expands to an assignment; the LHS of an assignment can't be
364 XMARK (* (Lisp_Object
*) &tree
->parent
);
366 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
369 #define MARK_INTERVAL_TREE(i) \
371 if (!NULL_INTERVAL_P (i) \
372 && ! XMARKBIT ((Lisp_Object) i->parent)) \
373 mark_interval_tree (i); \
376 /* The oddity in the call to XUNMARK is necessary because XUNMARK
377 expands to an assignment to its argument, and most C compilers don't
378 support casts on the left operand of `='. */
379 #define UNMARK_BALANCE_INTERVALS(i) \
381 if (! NULL_INTERVAL_P (i)) \
383 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
384 (i) = balance_intervals (i); \
388 #else /* no interval use */
390 #define INIT_INTERVALS
392 #define UNMARK_BALANCE_INTERVALS(i)
393 #define MARK_INTERVAL_TREE(i)
395 #endif /* no interval use */
397 /* Floating point allocation. */
399 #ifdef LISP_FLOAT_TYPE
400 /* Allocation of float cells, just like conses */
401 /* We store float cells inside of float_blocks, allocating a new
402 float_block with malloc whenever necessary. Float cells reclaimed by
403 GC are put on a free list to be reallocated before allocating
404 any new float cells from the latest float_block.
406 Each float_block is just under 1020 bytes long,
407 since malloc really allocates in units of powers of two
408 and uses 4 bytes for its own overhead. */
410 #define FLOAT_BLOCK_SIZE \
411 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
415 struct float_block
*next
;
416 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
419 struct float_block
*float_block
;
420 int float_block_index
;
422 struct Lisp_Float
*float_free_list
;
427 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
428 float_block
->next
= 0;
429 bzero (float_block
->floats
, sizeof float_block
->floats
);
430 float_block_index
= 0;
434 /* Explicitly free a float cell. */
436 struct Lisp_Float
*ptr
;
438 XFASTINT (ptr
->type
) = (int) float_free_list
;
439 float_free_list
= ptr
;
443 make_float (float_value
)
446 register Lisp_Object val
;
450 XSET (val
, Lisp_Float
, float_free_list
);
451 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
455 if (float_block_index
== FLOAT_BLOCK_SIZE
)
457 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
458 VALIDATE_LISP_STORAGE (new, sizeof *new);
459 new->next
= float_block
;
461 float_block_index
= 0;
463 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
465 XFLOAT (val
)->data
= float_value
;
466 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
467 consing_since_gc
+= sizeof (struct Lisp_Float
);
471 #endif /* LISP_FLOAT_TYPE */
473 /* Allocation of cons cells */
474 /* We store cons cells inside of cons_blocks, allocating a new
475 cons_block with malloc whenever necessary. Cons cells reclaimed by
476 GC are put on a free list to be reallocated before allocating
477 any new cons cells from the latest cons_block.
479 Each cons_block is just under 1020 bytes long,
480 since malloc really allocates in units of powers of two
481 and uses 4 bytes for its own overhead. */
483 #define CONS_BLOCK_SIZE \
484 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
488 struct cons_block
*next
;
489 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
492 struct cons_block
*cons_block
;
493 int cons_block_index
;
495 struct Lisp_Cons
*cons_free_list
;
500 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
501 cons_block
->next
= 0;
502 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
503 cons_block_index
= 0;
507 /* Explicitly free a cons cell. */
509 struct Lisp_Cons
*ptr
;
511 XFASTINT (ptr
->car
) = (int) cons_free_list
;
512 cons_free_list
= ptr
;
515 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
516 "Create a new cons, give it CAR and CDR as components, and return it.")
518 Lisp_Object car
, cdr
;
520 register Lisp_Object val
;
524 XSET (val
, Lisp_Cons
, cons_free_list
);
525 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
529 if (cons_block_index
== CONS_BLOCK_SIZE
)
531 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
532 VALIDATE_LISP_STORAGE (new, sizeof *new);
533 new->next
= cons_block
;
535 cons_block_index
= 0;
537 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
539 XCONS (val
)->car
= car
;
540 XCONS (val
)->cdr
= cdr
;
541 consing_since_gc
+= sizeof (struct Lisp_Cons
);
545 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
546 "Return a newly created list with specified arguments as elements.\n\
547 Any number of arguments, even zero arguments, are allowed.")
550 register Lisp_Object
*args
;
552 register Lisp_Object len
, val
, val_tail
;
554 XFASTINT (len
) = nargs
;
555 val
= Fmake_list (len
, Qnil
);
557 while (!NILP (val_tail
))
559 XCONS (val_tail
)->car
= *args
++;
560 val_tail
= XCONS (val_tail
)->cdr
;
565 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
566 "Return a newly created list of length LENGTH, with each element being INIT.")
568 register Lisp_Object length
, init
;
570 register Lisp_Object val
;
573 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
574 length
= wrong_type_argument (Qnatnump
, length
);
575 size
= XINT (length
);
579 val
= Fcons (init
, val
);
583 /* Allocation of vectors */
585 struct Lisp_Vector
*all_vectors
;
587 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
588 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
589 See also the function `vector'.")
591 register Lisp_Object length
, init
;
593 register int sizei
, index
;
594 register Lisp_Object vector
;
595 register struct Lisp_Vector
*p
;
597 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
598 length
= wrong_type_argument (Qnatnump
, length
);
599 sizei
= XINT (length
);
601 p
= (struct Lisp_Vector
*) xmalloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
602 VALIDATE_LISP_STORAGE (p
, 0);
604 XSET (vector
, Lisp_Vector
, p
);
605 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
608 p
->next
= all_vectors
;
611 for (index
= 0; index
< sizei
; index
++)
612 p
->contents
[index
] = init
;
617 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
618 "Return a newly created vector with specified arguments as elements.\n\
619 Any number of arguments, even zero arguments, are allowed.")
624 register Lisp_Object len
, val
;
626 register struct Lisp_Vector
*p
;
628 XFASTINT (len
) = nargs
;
629 val
= Fmake_vector (len
, Qnil
);
631 for (index
= 0; index
< nargs
; index
++)
632 p
->contents
[index
] = args
[index
];
636 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
637 "Create a byte-code object with specified arguments as elements.\n\
638 The arguments should be the arglist, bytecode-string, constant vector,\n\
639 stack size, (optional) doc string, and (optional) interactive spec.\n\
640 The first four arguments are required; at most six have any\n\
646 register Lisp_Object len
, val
;
648 register struct Lisp_Vector
*p
;
650 XFASTINT (len
) = nargs
;
651 if (!NILP (Vpurify_flag
))
652 val
= make_pure_vector (len
);
654 val
= Fmake_vector (len
, Qnil
);
656 for (index
= 0; index
< nargs
; index
++)
658 if (!NILP (Vpurify_flag
))
659 args
[index
] = Fpurecopy (args
[index
]);
660 p
->contents
[index
] = args
[index
];
662 XSETTYPE (val
, Lisp_Compiled
);
666 /* Allocation of symbols.
667 Just like allocation of conses!
669 Each symbol_block is just under 1020 bytes long,
670 since malloc really allocates in units of powers of two
671 and uses 4 bytes for its own overhead. */
673 #define SYMBOL_BLOCK_SIZE \
674 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
678 struct symbol_block
*next
;
679 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
682 struct symbol_block
*symbol_block
;
683 int symbol_block_index
;
685 struct Lisp_Symbol
*symbol_free_list
;
690 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
691 symbol_block
->next
= 0;
692 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
693 symbol_block_index
= 0;
694 symbol_free_list
= 0;
697 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
698 "Return a newly allocated uninterned symbol whose name is NAME.\n\
699 Its value and function definition are void, and its property list is nil.")
703 register Lisp_Object val
;
704 register struct Lisp_Symbol
*p
;
706 CHECK_STRING (str
, 0);
708 if (symbol_free_list
)
710 XSET (val
, Lisp_Symbol
, symbol_free_list
);
712 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
716 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
718 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
719 VALIDATE_LISP_STORAGE (new, sizeof *new);
720 new->next
= symbol_block
;
722 symbol_block_index
= 0;
724 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
727 p
->name
= XSTRING (str
);
730 p
->function
= Qunbound
;
732 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
736 /* Allocation of markers.
737 Works like allocation of conses. */
739 #define MARKER_BLOCK_SIZE \
740 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
744 struct marker_block
*next
;
745 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
748 struct marker_block
*marker_block
;
749 int marker_block_index
;
751 struct Lisp_Marker
*marker_free_list
;
756 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
757 marker_block
->next
= 0;
758 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
759 marker_block_index
= 0;
760 marker_free_list
= 0;
763 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
764 "Return a newly allocated marker which does not point at any place.")
767 register Lisp_Object val
;
768 register struct Lisp_Marker
*p
;
770 if (marker_free_list
)
772 XSET (val
, Lisp_Marker
, marker_free_list
);
774 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
778 if (marker_block_index
== MARKER_BLOCK_SIZE
)
780 struct marker_block
*new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
781 VALIDATE_LISP_STORAGE (new, sizeof *new);
782 new->next
= marker_block
;
784 marker_block_index
= 0;
786 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
792 consing_since_gc
+= sizeof (struct Lisp_Marker
);
796 /* Allocation of strings */
798 /* Strings reside inside of string_blocks. The entire data of the string,
799 both the size and the contents, live in part of the `chars' component of a string_block.
800 The `pos' component is the index within `chars' of the first free byte.
802 first_string_block points to the first string_block ever allocated.
803 Each block points to the next one with its `next' field.
804 The `prev' fields chain in reverse order.
805 The last one allocated is the one currently being filled.
806 current_string_block points to it.
808 The string_blocks that hold individual large strings
809 go in a separate chain, started by large_string_blocks. */
812 /* String blocks contain this many useful bytes.
813 8188 is power of 2, minus 4 for malloc overhead. */
814 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
816 /* A string bigger than this gets its own specially-made string block
817 if it doesn't fit in the current one. */
818 #define STRING_BLOCK_OUTSIZE 1024
820 struct string_block_head
822 struct string_block
*next
, *prev
;
828 struct string_block
*next
, *prev
;
830 char chars
[STRING_BLOCK_SIZE
];
833 /* This points to the string block we are now allocating strings. */
835 struct string_block
*current_string_block
;
837 /* This points to the oldest string block, the one that starts the chain. */
839 struct string_block
*first_string_block
;
841 /* Last string block in chain of those made for individual large strings. */
843 struct string_block
*large_string_blocks
;
845 /* If SIZE is the length of a string, this returns how many bytes
846 the string occupies in a string_block (including padding). */
848 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
850 #define PAD (sizeof (int))
853 #define STRING_FULLSIZE(SIZE) \
854 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
860 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
861 first_string_block
= current_string_block
;
862 consing_since_gc
+= sizeof (struct string_block
);
863 current_string_block
->next
= 0;
864 current_string_block
->prev
= 0;
865 current_string_block
->pos
= 0;
866 large_string_blocks
= 0;
869 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
870 "Return a newly created string of length LENGTH, with each element being INIT.\n\
871 Both LENGTH and INIT must be numbers.")
873 Lisp_Object length
, init
;
875 register Lisp_Object val
;
876 register unsigned char *p
, *end
, c
;
878 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
879 length
= wrong_type_argument (Qnatnump
, length
);
880 CHECK_NUMBER (init
, 1);
881 val
= make_uninit_string (XINT (length
));
883 p
= XSTRING (val
)->data
;
884 end
= p
+ XSTRING (val
)->size
;
892 make_string (contents
, length
)
896 register Lisp_Object val
;
897 val
= make_uninit_string (length
);
898 bcopy (contents
, XSTRING (val
)->data
, length
);
906 return make_string (str
, strlen (str
));
910 make_uninit_string (length
)
913 register Lisp_Object val
;
914 register int fullsize
= STRING_FULLSIZE (length
);
916 if (length
< 0) abort ();
918 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
919 /* This string can fit in the current string block */
921 XSET (val
, Lisp_String
,
922 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
923 current_string_block
->pos
+= fullsize
;
925 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
926 /* This string gets its own string block */
928 register struct string_block
*new
929 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
930 VALIDATE_LISP_STORAGE (new, 0);
931 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
933 new->next
= large_string_blocks
;
934 large_string_blocks
= new;
935 XSET (val
, Lisp_String
,
936 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
939 /* Make a new current string block and start it off with this string */
941 register struct string_block
*new
942 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
943 VALIDATE_LISP_STORAGE (new, sizeof *new);
944 consing_since_gc
+= sizeof (struct string_block
);
945 current_string_block
->next
= new;
946 new->prev
= current_string_block
;
948 current_string_block
= new;
950 XSET (val
, Lisp_String
,
951 (struct Lisp_String
*) current_string_block
->chars
);
954 XSTRING (val
)->size
= length
;
955 XSTRING (val
)->data
[length
] = 0;
956 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
961 /* Return a newly created vector or string with specified arguments as
962 elements. If all the arguments are characters that can fit
963 in a string of events, make a string; otherwise, make a vector.
965 Any number of arguments, even zero arguments, are allowed. */
968 make_event_array (nargs
, args
)
974 for (i
= 0; i
< nargs
; i
++)
975 /* The things that fit in a string
976 are characters that are in 0...127,
977 after discarding the meta bit and all the bits above it. */
978 if (XTYPE (args
[i
]) != Lisp_Int
979 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
980 return Fvector (nargs
, args
);
982 /* Since the loop exited, we know that all the things in it are
983 characters, so we can make a string. */
985 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
987 for (i
= 0; i
< nargs
; i
++)
989 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
990 /* Move the meta bit to the right place for a string char. */
991 if (XINT (args
[i
]) & CHAR_META
)
992 XSTRING (result
)->data
[i
] |= 0x80;
999 /* Pure storage management. */
1001 /* Must get an error if pure storage is full,
1002 since if it cannot hold a large string
1003 it may be able to hold conses that point to that string;
1004 then the string is not protected from gc. */
1007 make_pure_string (data
, length
)
1011 register Lisp_Object
new;
1012 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
1014 if (pureptr
+ size
> PURESIZE
)
1015 error ("Pure Lisp storage exhausted");
1016 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
1017 XSTRING (new)->size
= length
;
1018 bcopy (data
, XSTRING (new)->data
, length
);
1019 XSTRING (new)->data
[length
] = 0;
1021 /* We must give strings in pure storage some kind of interval. So we
1022 give them a null one. */
1023 #if defined (USE_TEXT_PROPERTIES)
1024 XSTRING (new)->intervals
= NULL_INTERVAL
;
1026 pureptr
+= (size
+ sizeof (int) - 1)
1027 / sizeof (int) * sizeof (int);
1032 pure_cons (car
, cdr
)
1033 Lisp_Object car
, cdr
;
1035 register Lisp_Object
new;
1037 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1038 error ("Pure Lisp storage exhausted");
1039 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
1040 pureptr
+= sizeof (struct Lisp_Cons
);
1041 XCONS (new)->car
= Fpurecopy (car
);
1042 XCONS (new)->cdr
= Fpurecopy (cdr
);
1046 #ifdef LISP_FLOAT_TYPE
1049 make_pure_float (num
)
1052 register Lisp_Object
new;
1054 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1055 (double) boundary. Some architectures (like the sparc) require
1056 this, and I suspect that floats are rare enough that it's no
1057 tragedy for those that do. */
1060 char *p
= PUREBEG
+ pureptr
;
1064 alignment
= __alignof (struct Lisp_Float
);
1066 alignment
= sizeof (struct Lisp_Float
);
1069 alignment
= sizeof (struct Lisp_Float
);
1071 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1072 pureptr
= p
- PUREBEG
;
1075 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1076 error ("Pure Lisp storage exhausted");
1077 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1078 pureptr
+= sizeof (struct Lisp_Float
);
1079 XFLOAT (new)->data
= num
;
1080 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1084 #endif /* LISP_FLOAT_TYPE */
1087 make_pure_vector (len
)
1090 register Lisp_Object
new;
1091 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1093 if (pureptr
+ size
> PURESIZE
)
1094 error ("Pure Lisp storage exhausted");
1096 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1098 XVECTOR (new)->size
= len
;
1102 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1103 "Make a copy of OBJECT in pure storage.\n\
1104 Recursively copies contents of vectors and cons cells.\n\
1105 Does not copy symbols.")
1107 register Lisp_Object obj
;
1109 register Lisp_Object
new, tem
;
1112 if (NILP (Vpurify_flag
))
1115 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1116 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1119 #ifdef SWITCH_ENUM_BUG
1120 switch ((int) XTYPE (obj
))
1122 switch (XTYPE (obj
))
1126 error ("Attempt to copy a marker to pure storage");
1129 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1131 #ifdef LISP_FLOAT_TYPE
1133 return make_pure_float (XFLOAT (obj
)->data
);
1134 #endif /* LISP_FLOAT_TYPE */
1137 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1141 new = make_pure_vector (XVECTOR (obj
)->size
);
1142 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1144 tem
= XVECTOR (obj
)->contents
[i
];
1145 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1147 XSETTYPE (new, XTYPE (obj
));
1155 /* Recording what needs to be marked for gc. */
1157 struct gcpro
*gcprolist
;
1159 #define NSTATICS 512
1161 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1165 /* Put an entry in staticvec, pointing at the variable whose address is given */
1168 staticpro (varaddress
)
1169 Lisp_Object
*varaddress
;
1171 staticvec
[staticidx
++] = varaddress
;
1172 if (staticidx
>= NSTATICS
)
1180 struct catchtag
*next
;
1181 /* jmp_buf jmp; /* We don't need this for GC purposes */
1186 struct backtrace
*next
;
1187 Lisp_Object
*function
;
1188 Lisp_Object
*args
; /* Points to vector of args. */
1189 int nargs
; /* length of vector */
1190 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1194 /* Two flags that are set during GC in the `size' component
1195 of a string or vector. On some machines, these flags
1196 are defined by the m- file to be different bits. */
1198 /* On vector, means it has been marked.
1199 On string size field or a reference to a string,
1200 means not the last reference in the chain. */
1202 #ifndef ARRAY_MARK_FLAG
1203 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1204 #endif /* no ARRAY_MARK_FLAG */
1206 /* Any slot that is a Lisp_Object can point to a string
1207 and thus can be put on a string's reference-chain
1208 and thus may need to have its ARRAY_MARK_FLAG set.
1209 This includes the slots whose markbits are used to mark
1210 the containing objects. */
1212 #if ARRAY_MARK_FLAG == MARKBIT
1216 /* Garbage collection! */
1218 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1219 int total_free_conses
, total_free_markers
, total_free_symbols
;
1220 #ifdef LISP_FLOAT_TYPE
1221 int total_free_floats
, total_floats
;
1222 #endif /* LISP_FLOAT_TYPE */
1224 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1225 "Reclaim storage for Lisp objects no longer needed.\n\
1226 Returns info on amount of space in use:\n\
1227 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1228 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1229 (USED-FLOATS . FREE-FLOATS))\n\
1230 Garbage collection happens automatically if you cons more than\n\
1231 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1234 register struct gcpro
*tail
;
1235 register struct specbinding
*bind
;
1236 struct catchtag
*catch;
1237 struct handler
*handler
;
1238 register struct backtrace
*backlist
;
1239 register Lisp_Object tem
;
1240 char *omessage
= echo_area_glyphs
;
1241 int omessage_length
= echo_area_glyphs_length
;
1242 char stack_top_variable
;
1245 /* Save a copy of the contents of the stack, for debugging. */
1246 #if MAX_SAVE_STACK > 0
1247 if (NILP (Vpurify_flag
))
1249 i
= &stack_top_variable
- stack_bottom
;
1251 if (i
< MAX_SAVE_STACK
)
1253 if (stack_copy
== 0)
1254 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1255 else if (stack_copy_size
< i
)
1256 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1259 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1260 bcopy (stack_bottom
, stack_copy
, i
);
1262 bcopy (&stack_top_variable
, stack_copy
, i
);
1266 #endif /* MAX_SAVE_STACK > 0 */
1268 if (!noninteractive
)
1269 message1 ("Garbage collecting...");
1271 /* Don't keep command history around forever */
1272 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1274 XCONS (tem
)->cdr
= Qnil
;
1276 /* Likewise for undo information. */
1278 register struct buffer
*nextb
= all_buffers
;
1282 /* If a buffer's undo list is Qt, that means that undo is
1283 turned off in that buffer. Calling truncate_undo_list on
1284 Qt tends to return NULL, which effectively turns undo back on.
1285 So don't call truncate_undo_list if undo_list is Qt. */
1286 if (! EQ (nextb
->undo_list
, Qt
))
1288 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1290 nextb
= nextb
->next
;
1296 /* clear_marks (); */
1298 /* In each "large string", set the MARKBIT of the size field.
1299 That enables mark_object to recognize them. */
1301 register struct string_block
*b
;
1302 for (b
= large_string_blocks
; b
; b
= b
->next
)
1303 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1306 /* Mark all the special slots that serve as the roots of accessibility.
1308 Usually the special slots to mark are contained in particular structures.
1309 Then we know no slot is marked twice because the structures don't overlap.
1310 In some cases, the structures point to the slots to be marked.
1311 For these, we use MARKBIT to avoid double marking of the slot. */
1313 for (i
= 0; i
< staticidx
; i
++)
1314 mark_object (staticvec
[i
]);
1315 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1316 for (i
= 0; i
< tail
->nvars
; i
++)
1317 if (!XMARKBIT (tail
->var
[i
]))
1319 mark_object (&tail
->var
[i
]);
1320 XMARK (tail
->var
[i
]);
1322 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1324 mark_object (&bind
->symbol
);
1325 mark_object (&bind
->old_value
);
1327 for (catch = catchlist
; catch; catch = catch->next
)
1329 mark_object (&catch->tag
);
1330 mark_object (&catch->val
);
1332 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1334 mark_object (&handler
->handler
);
1335 mark_object (&handler
->var
);
1337 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1339 if (!XMARKBIT (*backlist
->function
))
1341 mark_object (backlist
->function
);
1342 XMARK (*backlist
->function
);
1344 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1347 i
= backlist
->nargs
- 1;
1349 if (!XMARKBIT (backlist
->args
[i
]))
1351 mark_object (&backlist
->args
[i
]);
1352 XMARK (backlist
->args
[i
]);
1358 /* Clear the mark bits that we set in certain root slots. */
1360 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1361 for (i
= 0; i
< tail
->nvars
; i
++)
1362 XUNMARK (tail
->var
[i
]);
1363 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1365 XUNMARK (*backlist
->function
);
1366 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1369 i
= backlist
->nargs
- 1;
1371 XUNMARK (backlist
->args
[i
]);
1373 XUNMARK (buffer_defaults
.name
);
1374 XUNMARK (buffer_local_symbols
.name
);
1376 /* clear_marks (); */
1379 consing_since_gc
= 0;
1380 if (gc_cons_threshold
< 10000)
1381 gc_cons_threshold
= 10000;
1383 if (omessage
|| minibuf_level
> 0)
1384 message2 (omessage
, omessage_length
);
1385 else if (!noninteractive
)
1386 message1 ("Garbage collecting...done");
1388 return Fcons (Fcons (make_number (total_conses
),
1389 make_number (total_free_conses
)),
1390 Fcons (Fcons (make_number (total_symbols
),
1391 make_number (total_free_symbols
)),
1392 Fcons (Fcons (make_number (total_markers
),
1393 make_number (total_free_markers
)),
1394 Fcons (make_number (total_string_size
),
1395 Fcons (make_number (total_vector_size
),
1397 #ifdef LISP_FLOAT_TYPE
1398 Fcons (Fcons (make_number (total_floats
),
1399 make_number (total_free_floats
)),
1401 #else /* not LISP_FLOAT_TYPE */
1403 #endif /* not LISP_FLOAT_TYPE */
1411 /* Clear marks on all conses */
1413 register struct cons_block
*cblk
;
1414 register int lim
= cons_block_index
;
1416 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1419 for (i
= 0; i
< lim
; i
++)
1420 XUNMARK (cblk
->conses
[i
].car
);
1421 lim
= CONS_BLOCK_SIZE
;
1424 /* Clear marks on all symbols */
1426 register struct symbol_block
*sblk
;
1427 register int lim
= symbol_block_index
;
1429 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1432 for (i
= 0; i
< lim
; i
++)
1434 XUNMARK (sblk
->symbols
[i
].plist
);
1436 lim
= SYMBOL_BLOCK_SIZE
;
1439 /* Clear marks on all markers */
1441 register struct marker_block
*sblk
;
1442 register int lim
= marker_block_index
;
1444 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1447 for (i
= 0; i
< lim
; i
++)
1448 XUNMARK (sblk
->markers
[i
].chain
);
1449 lim
= MARKER_BLOCK_SIZE
;
1452 /* Clear mark bits on all buffers */
1454 register struct buffer
*nextb
= all_buffers
;
1458 XUNMARK (nextb
->name
);
1459 nextb
= nextb
->next
;
1465 /* Mark reference to a Lisp_Object.
1466 If the object referred to has not been seen yet, recursively mark
1467 all the references contained in it.
1469 If the object referenced is a short string, the referencing slot
1470 is threaded into a chain of such slots, pointed to from
1471 the `size' field of the string. The actual string size
1472 lives in the last slot in the chain. We recognize the end
1473 because it is < (unsigned) STRING_BLOCK_SIZE. */
1475 #define LAST_MARKED_SIZE 500
1476 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1477 int last_marked_index
;
1480 mark_object (objptr
)
1481 Lisp_Object
*objptr
;
1483 register Lisp_Object obj
;
1490 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1491 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1494 last_marked
[last_marked_index
++] = objptr
;
1495 if (last_marked_index
== LAST_MARKED_SIZE
)
1496 last_marked_index
= 0;
1498 #ifdef SWITCH_ENUM_BUG
1499 switch ((int) XGCTYPE (obj
))
1501 switch (XGCTYPE (obj
))
1506 register struct Lisp_String
*ptr
= XSTRING (obj
);
1508 MARK_INTERVAL_TREE (ptr
->intervals
);
1509 if (ptr
->size
& MARKBIT
)
1510 /* A large string. Just set ARRAY_MARK_FLAG. */
1511 ptr
->size
|= ARRAY_MARK_FLAG
;
1514 /* A small string. Put this reference
1515 into the chain of references to it.
1516 The address OBJPTR is even, so if the address
1517 includes MARKBIT, put it in the low bit
1518 when we store OBJPTR into the size field. */
1520 if (XMARKBIT (*objptr
))
1522 XFASTINT (*objptr
) = ptr
->size
;
1526 XFASTINT (*objptr
) = ptr
->size
;
1527 if ((int)objptr
& 1) abort ();
1528 ptr
->size
= (int) objptr
& ~MARKBIT
;
1529 if ((int) objptr
& MARKBIT
)
1538 case Lisp_Window_Configuration
:
1540 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1541 register int size
= ptr
->size
;
1542 /* The reason we use ptr1 is to avoid an apparent hardware bug
1543 that happens occasionally on the FSF's HP 300s.
1544 The bug is that a2 gets clobbered by recursive calls to mark_object.
1545 The clobberage seems to happen during function entry,
1546 perhaps in the moveml instruction.
1547 Yes, this is a crock, but we have to do it. */
1548 struct Lisp_Vector
*volatile ptr1
= ptr
;
1551 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1552 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1553 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1554 mark_object (&ptr1
->contents
[i
]);
1559 /* We could treat this just like a vector, but it is better
1560 to save the COMPILED_CONSTANTS element for last and avoid recursion
1563 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1564 register int size
= ptr
->size
;
1565 /* See comment above under Lisp_Vector. */
1566 struct Lisp_Vector
*volatile ptr1
= ptr
;
1569 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1570 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1571 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1573 if (i
!= COMPILED_CONSTANTS
)
1574 mark_object (&ptr1
->contents
[i
]);
1576 objptr
= &ptr1
->contents
[COMPILED_CONSTANTS
];
1583 /* See comment above under Lisp_Vector for why this is volatile. */
1584 register struct frame
*volatile ptr
= XFRAME (obj
);
1585 register int size
= ptr
->size
;
1587 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1588 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1590 mark_object (&ptr
->name
);
1591 mark_object (&ptr
->focus_frame
);
1592 mark_object (&ptr
->width
);
1593 mark_object (&ptr
->height
);
1594 mark_object (&ptr
->selected_window
);
1595 mark_object (&ptr
->minibuffer_window
);
1596 mark_object (&ptr
->param_alist
);
1597 mark_object (&ptr
->scroll_bars
);
1598 mark_object (&ptr
->condemned_scroll_bars
);
1599 mark_object (&ptr
->menu_bar_items
);
1600 mark_object (&ptr
->face_alist
);
1603 #endif /* MULTI_FRAME */
1607 /* See comment above under Lisp_Vector for why this is volatile. */
1608 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1609 struct Lisp_Symbol
*ptrx
;
1611 if (XMARKBIT (ptr
->plist
)) break;
1613 mark_object ((Lisp_Object
*) &ptr
->value
);
1614 mark_object (&ptr
->function
);
1615 mark_object (&ptr
->plist
);
1616 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1617 mark_object (&ptr
->name
);
1621 /* For the benefit of the last_marked log. */
1622 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1623 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1624 XSETSYMBOL (obj
, ptrx
);
1625 /* We can't goto loop here because *objptr doesn't contain an
1626 actual Lisp_Object with valid datatype field. */
1633 XMARK (XMARKER (obj
)->chain
);
1634 /* DO NOT mark thru the marker's chain.
1635 The buffer's markers chain does not preserve markers from gc;
1636 instead, markers are removed from the chain when freed by gc. */
1640 case Lisp_Buffer_Local_Value
:
1641 case Lisp_Some_Buffer_Local_Value
:
1644 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1645 if (XMARKBIT (ptr
->car
)) break;
1647 /* If the cdr is nil, avoid recursion for the car. */
1648 if (EQ (ptr
->cdr
, Qnil
))
1653 mark_object (&ptr
->car
);
1654 /* See comment above under Lisp_Vector for why not use ptr here. */
1655 objptr
= &XCONS (obj
)->cdr
;
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, 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;
2225 /* We build this in advance because if we wait until we need it, we might
2226 not be able to allocate the memory to hold it. */
2227 memory_signal_data
= Fcons (build_string ("Memory exhausted"), Qnil
);
2228 staticpro (&memory_signal_data
);
2233 defsubr (&Smake_byte_code
);
2234 defsubr (&Smake_list
);
2235 defsubr (&Smake_vector
);
2236 defsubr (&Smake_string
);
2237 defsubr (&Smake_symbol
);
2238 defsubr (&Smake_marker
);
2239 defsubr (&Spurecopy
);
2240 defsubr (&Sgarbage_collect
);
2241 defsubr (&Smemory_limit
);