1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "intervals.h"
30 #include "blockinput.h"
33 #include "syssignal.h"
35 #define max(A,B) ((A) > (B) ? (A) : (B))
37 /* Macro to verify that storage intended for Lisp objects is not
38 out of range to fit in the space for a pointer.
39 ADDRESS is the start of the block, and SIZE
40 is the amount of space within which objects can start. */
41 #define VALIDATE_LISP_STORAGE(address, size) \
45 XSETCONS (val, (char *) address + size); \
46 if ((char *) XCONS (val) != (char *) address + size) \
53 /* Number of bytes of consing done since the last gc */
56 /* Number of bytes of consing since gc before another gc should be done. */
57 int gc_cons_threshold
;
59 /* Nonzero during gc */
62 #ifndef VIRT_ADDR_VARIES
64 #endif /* VIRT_ADDR_VARIES */
67 #ifndef VIRT_ADDR_VARIES
69 #endif /* VIRT_ADDR_VARIES */
70 int malloc_sbrk_unused
;
72 /* Two limits controlling how much undo information to keep. */
74 int undo_strong_limit
;
76 /* Non-nil means defun should do purecopy on the function definition */
77 Lisp_Object Vpurify_flag
;
80 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
81 #define PUREBEG (char *) pure
83 #define pure PURE_SEG_BITS /* Use shared memory segment */
84 #define PUREBEG (char *)PURE_SEG_BITS
86 /* This variable is used only by the XPNTR macro when HAVE_SHM is
87 defined. If we used the PURESIZE macro directly there, that would
88 make most of emacs dependent on puresize.h, which we don't want -
89 you should be able to change that without too much recompilation.
90 So map_in_data initializes pure_size, and the dependencies work
93 #endif /* not HAVE_SHM */
95 /* Index in pure at which next pure object will be allocated. */
98 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
99 char *pending_malloc_warning
;
101 /* Pre-computed signal argument for use when memory is exhausted. */
102 Lisp_Object memory_signal_data
;
104 /* Maximum amount of C stack to save when a GC happens. */
106 #ifndef MAX_SAVE_STACK
107 #define MAX_SAVE_STACK 16000
110 /* 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 XSETFASTINT (ptr
->type
, (EMACS_INT
) float_free_list
);
439 float_free_list
= ptr
;
443 make_float (float_value
)
446 register Lisp_Object val
;
450 XSETFLOAT (val
, 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 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
465 XFLOAT (val
)->data
= float_value
;
466 XSETFASTINT (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 XSETFASTINT (ptr
->car
, (EMACS_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 XSETCONS (val
, 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 XSETCONS (val
, &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 XSETFASTINT (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 (!INTEGERP (length
) || 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 (!INTEGERP (length
) || 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 XSETVECTOR (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 XSETFASTINT (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 XSETFASTINT (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 XSETSYMBOL (val
, 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 XSETSYMBOL (val
, &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 and other objects that share that structure.
737 Works like allocation of conses. */
739 #define MARKER_BLOCK_SIZE \
740 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
744 struct marker_block
*next
;
745 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
748 struct marker_block
*marker_block
;
749 int marker_block_index
;
751 union Lisp_Misc
*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 /* Return a newly allocated Lisp_Misc object, with no substructure. */
769 if (marker_free_list
)
771 XSETMISC (val
, marker_free_list
);
772 marker_free_list
= marker_free_list
->u_free
.chain
;
776 if (marker_block_index
== MARKER_BLOCK_SIZE
)
778 struct marker_block
*new
779 = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
780 VALIDATE_LISP_STORAGE (new, sizeof *new);
781 new->next
= marker_block
;
783 marker_block_index
= 0;
785 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
787 consing_since_gc
+= sizeof (union Lisp_Misc
);
791 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
792 "Return a newly allocated marker which does not point at any place.")
795 register Lisp_Object val
;
796 register struct Lisp_Marker
*p
;
798 val
= allocate_misc ();
799 XMISC (val
)->type
= Lisp_Misc_Marker
;
807 /* Allocation of strings */
809 /* Strings reside inside of string_blocks. The entire data of the string,
810 both the size and the contents, live in part of the `chars' component of a string_block.
811 The `pos' component is the index within `chars' of the first free byte.
813 first_string_block points to the first string_block ever allocated.
814 Each block points to the next one with its `next' field.
815 The `prev' fields chain in reverse order.
816 The last one allocated is the one currently being filled.
817 current_string_block points to it.
819 The string_blocks that hold individual large strings
820 go in a separate chain, started by large_string_blocks. */
823 /* String blocks contain this many useful bytes.
824 8188 is power of 2, minus 4 for malloc overhead. */
825 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
827 /* A string bigger than this gets its own specially-made string block
828 if it doesn't fit in the current one. */
829 #define STRING_BLOCK_OUTSIZE 1024
831 struct string_block_head
833 struct string_block
*next
, *prev
;
839 struct string_block
*next
, *prev
;
841 char chars
[STRING_BLOCK_SIZE
];
844 /* This points to the string block we are now allocating strings. */
846 struct string_block
*current_string_block
;
848 /* This points to the oldest string block, the one that starts the chain. */
850 struct string_block
*first_string_block
;
852 /* Last string block in chain of those made for individual large strings. */
854 struct string_block
*large_string_blocks
;
856 /* If SIZE is the length of a string, this returns how many bytes
857 the string occupies in a string_block (including padding). */
859 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
861 #define PAD (sizeof (EMACS_INT))
864 #define STRING_FULLSIZE(SIZE) \
865 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
871 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
872 first_string_block
= current_string_block
;
873 consing_since_gc
+= sizeof (struct string_block
);
874 current_string_block
->next
= 0;
875 current_string_block
->prev
= 0;
876 current_string_block
->pos
= 0;
877 large_string_blocks
= 0;
880 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
881 "Return a newly created string of length LENGTH, with each element being INIT.\n\
882 Both LENGTH and INIT must be numbers.")
884 Lisp_Object length
, init
;
886 register Lisp_Object val
;
887 register unsigned char *p
, *end
, c
;
889 if (!INTEGERP (length
) || XINT (length
) < 0)
890 length
= wrong_type_argument (Qnatnump
, length
);
891 CHECK_NUMBER (init
, 1);
892 val
= make_uninit_string (XINT (length
));
894 p
= XSTRING (val
)->data
;
895 end
= p
+ XSTRING (val
)->size
;
903 make_string (contents
, length
)
907 register Lisp_Object val
;
908 val
= make_uninit_string (length
);
909 bcopy (contents
, XSTRING (val
)->data
, length
);
917 return make_string (str
, strlen (str
));
921 make_uninit_string (length
)
924 register Lisp_Object val
;
925 register int fullsize
= STRING_FULLSIZE (length
);
927 if (length
< 0) abort ();
929 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
930 /* This string can fit in the current string block */
933 ((struct Lisp_String
*)
934 (current_string_block
->chars
+ current_string_block
->pos
)));
935 current_string_block
->pos
+= fullsize
;
937 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
938 /* This string gets its own string block */
940 register struct string_block
*new
941 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
942 VALIDATE_LISP_STORAGE (new, 0);
943 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
945 new->next
= large_string_blocks
;
946 large_string_blocks
= new;
948 ((struct Lisp_String
*)
949 ((struct string_block_head
*)new + 1)));
952 /* Make a new current string block and start it off with this string */
954 register struct string_block
*new
955 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
956 VALIDATE_LISP_STORAGE (new, sizeof *new);
957 consing_since_gc
+= sizeof (struct string_block
);
958 current_string_block
->next
= new;
959 new->prev
= current_string_block
;
961 current_string_block
= new;
964 (struct Lisp_String
*) current_string_block
->chars
);
967 XSTRING (val
)->size
= length
;
968 XSTRING (val
)->data
[length
] = 0;
969 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
974 /* Return a newly created vector or string with specified arguments as
975 elements. If all the arguments are characters that can fit
976 in a string of events, make a string; otherwise, make a vector.
978 Any number of arguments, even zero arguments, are allowed. */
981 make_event_array (nargs
, args
)
987 for (i
= 0; i
< nargs
; i
++)
988 /* The things that fit in a string
989 are characters that are in 0...127,
990 after discarding the meta bit and all the bits above it. */
991 if (!INTEGERP (args
[i
])
992 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
993 return Fvector (nargs
, args
);
995 /* Since the loop exited, we know that all the things in it are
996 characters, so we can make a string. */
1000 result
= Fmake_string (nargs
, make_number (0));
1001 for (i
= 0; i
< nargs
; i
++)
1003 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1004 /* Move the meta bit to the right place for a string char. */
1005 if (XINT (args
[i
]) & CHAR_META
)
1006 XSTRING (result
)->data
[i
] |= 0x80;
1013 /* Pure storage management. */
1015 /* Must get an error if pure storage is full,
1016 since if it cannot hold a large string
1017 it may be able to hold conses that point to that string;
1018 then the string is not protected from gc. */
1021 make_pure_string (data
, length
)
1025 register Lisp_Object
new;
1026 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1028 if (pureptr
+ size
> PURESIZE
)
1029 error ("Pure Lisp storage exhausted");
1030 XSETSTRING (new, PUREBEG
+ pureptr
);
1031 XSTRING (new)->size
= length
;
1032 bcopy (data
, XSTRING (new)->data
, length
);
1033 XSTRING (new)->data
[length
] = 0;
1035 /* We must give strings in pure storage some kind of interval. So we
1036 give them a null one. */
1037 #if defined (USE_TEXT_PROPERTIES)
1038 XSTRING (new)->intervals
= NULL_INTERVAL
;
1040 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1041 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1046 pure_cons (car
, cdr
)
1047 Lisp_Object car
, cdr
;
1049 register Lisp_Object
new;
1051 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1052 error ("Pure Lisp storage exhausted");
1053 XSETCONS (new, PUREBEG
+ pureptr
);
1054 pureptr
+= sizeof (struct Lisp_Cons
);
1055 XCONS (new)->car
= Fpurecopy (car
);
1056 XCONS (new)->cdr
= Fpurecopy (cdr
);
1060 #ifdef LISP_FLOAT_TYPE
1063 make_pure_float (num
)
1066 register Lisp_Object
new;
1068 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1069 (double) boundary. Some architectures (like the sparc) require
1070 this, and I suspect that floats are rare enough that it's no
1071 tragedy for those that do. */
1074 char *p
= PUREBEG
+ pureptr
;
1078 alignment
= __alignof (struct Lisp_Float
);
1080 alignment
= sizeof (struct Lisp_Float
);
1083 alignment
= sizeof (struct Lisp_Float
);
1085 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1086 pureptr
= p
- PUREBEG
;
1089 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1090 error ("Pure Lisp storage exhausted");
1091 XSETFLOAT (new, PUREBEG
+ pureptr
);
1092 pureptr
+= sizeof (struct Lisp_Float
);
1093 XFLOAT (new)->data
= num
;
1094 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1098 #endif /* LISP_FLOAT_TYPE */
1101 make_pure_vector (len
)
1104 register Lisp_Object
new;
1105 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1107 if (pureptr
+ size
> PURESIZE
)
1108 error ("Pure Lisp storage exhausted");
1110 XSETVECTOR (new, PUREBEG
+ pureptr
);
1112 XVECTOR (new)->size
= len
;
1116 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1117 "Make a copy of OBJECT in pure storage.\n\
1118 Recursively copies contents of vectors and cons cells.\n\
1119 Does not copy symbols.")
1121 register Lisp_Object obj
;
1123 register Lisp_Object
new, tem
;
1126 if (NILP (Vpurify_flag
))
1129 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1130 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1133 #ifdef SWITCH_ENUM_BUG
1134 switch ((int) XTYPE (obj
))
1136 switch (XTYPE (obj
))
1140 switch (XMISC (obj
)->type
)
1142 case Lisp_Misc_Marker
:
1143 error ("Attempt to copy a marker to pure storage");
1150 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1152 #ifdef LISP_FLOAT_TYPE
1154 return make_pure_float (XFLOAT (obj
)->data
);
1155 #endif /* LISP_FLOAT_TYPE */
1158 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1162 new = make_pure_vector (XVECTOR (obj
)->size
);
1163 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1165 tem
= XVECTOR (obj
)->contents
[i
];
1166 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1168 XSETTYPE (new, XTYPE (obj
));
1176 /* Recording what needs to be marked for gc. */
1178 struct gcpro
*gcprolist
;
1180 #define NSTATICS 512
1182 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1186 /* Put an entry in staticvec, pointing at the variable whose address is given */
1189 staticpro (varaddress
)
1190 Lisp_Object
*varaddress
;
1192 staticvec
[staticidx
++] = varaddress
;
1193 if (staticidx
>= NSTATICS
)
1201 struct catchtag
*next
;
1202 /* jmp_buf jmp; /* We don't need this for GC purposes */
1207 struct backtrace
*next
;
1208 Lisp_Object
*function
;
1209 Lisp_Object
*args
; /* Points to vector of args. */
1210 int nargs
; /* length of vector */
1211 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1215 /* Garbage collection! */
1217 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1218 int total_free_conses
, total_free_markers
, total_free_symbols
;
1219 #ifdef LISP_FLOAT_TYPE
1220 int total_free_floats
, total_floats
;
1221 #endif /* LISP_FLOAT_TYPE */
1223 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1224 "Reclaim storage for Lisp objects no longer needed.\n\
1225 Returns info on amount of space in use:\n\
1226 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1227 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1228 (USED-FLOATS . FREE-FLOATS))\n\
1229 Garbage collection happens automatically if you cons more than\n\
1230 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1233 register struct gcpro
*tail
;
1234 register struct specbinding
*bind
;
1235 struct catchtag
*catch;
1236 struct handler
*handler
;
1237 register struct backtrace
*backlist
;
1238 register Lisp_Object tem
;
1239 char *omessage
= echo_area_glyphs
;
1240 int omessage_length
= echo_area_glyphs_length
;
1241 char stack_top_variable
;
1244 /* Save a copy of the contents of the stack, for debugging. */
1245 #if MAX_SAVE_STACK > 0
1246 if (NILP (Vpurify_flag
))
1248 i
= &stack_top_variable
- stack_bottom
;
1250 if (i
< MAX_SAVE_STACK
)
1252 if (stack_copy
== 0)
1253 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1254 else if (stack_copy_size
< i
)
1255 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1258 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1259 bcopy (stack_bottom
, stack_copy
, i
);
1261 bcopy (&stack_top_variable
, stack_copy
, i
);
1265 #endif /* MAX_SAVE_STACK > 0 */
1267 if (!noninteractive
)
1268 message1 ("Garbage collecting...");
1270 /* Don't keep command history around forever */
1271 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1273 XCONS (tem
)->cdr
= Qnil
;
1275 /* Likewise for undo information. */
1277 register struct buffer
*nextb
= all_buffers
;
1281 /* If a buffer's undo list is Qt, that means that undo is
1282 turned off in that buffer. Calling truncate_undo_list on
1283 Qt tends to return NULL, which effectively turns undo back on.
1284 So don't call truncate_undo_list if undo_list is Qt. */
1285 if (! EQ (nextb
->undo_list
, Qt
))
1287 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1289 nextb
= nextb
->next
;
1295 /* clear_marks (); */
1297 /* In each "large string", set the MARKBIT of the size field.
1298 That enables mark_object to recognize them. */
1300 register struct string_block
*b
;
1301 for (b
= large_string_blocks
; b
; b
= b
->next
)
1302 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1305 /* Mark all the special slots that serve as the roots of accessibility.
1307 Usually the special slots to mark are contained in particular structures.
1308 Then we know no slot is marked twice because the structures don't overlap.
1309 In some cases, the structures point to the slots to be marked.
1310 For these, we use MARKBIT to avoid double marking of the slot. */
1312 for (i
= 0; i
< staticidx
; i
++)
1313 mark_object (staticvec
[i
]);
1314 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1315 for (i
= 0; i
< tail
->nvars
; i
++)
1316 if (!XMARKBIT (tail
->var
[i
]))
1318 mark_object (&tail
->var
[i
]);
1319 XMARK (tail
->var
[i
]);
1321 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1323 mark_object (&bind
->symbol
);
1324 mark_object (&bind
->old_value
);
1326 for (catch = catchlist
; catch; catch = catch->next
)
1328 mark_object (&catch->tag
);
1329 mark_object (&catch->val
);
1331 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1333 mark_object (&handler
->handler
);
1334 mark_object (&handler
->var
);
1336 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1338 if (!XMARKBIT (*backlist
->function
))
1340 mark_object (backlist
->function
);
1341 XMARK (*backlist
->function
);
1343 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1346 i
= backlist
->nargs
- 1;
1348 if (!XMARKBIT (backlist
->args
[i
]))
1350 mark_object (&backlist
->args
[i
]);
1351 XMARK (backlist
->args
[i
]);
1357 /* Clear the mark bits that we set in certain root slots. */
1359 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1360 for (i
= 0; i
< tail
->nvars
; i
++)
1361 XUNMARK (tail
->var
[i
]);
1362 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1364 XUNMARK (*backlist
->function
);
1365 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1368 i
= backlist
->nargs
- 1;
1370 XUNMARK (backlist
->args
[i
]);
1372 XUNMARK (buffer_defaults
.name
);
1373 XUNMARK (buffer_local_symbols
.name
);
1375 /* clear_marks (); */
1378 consing_since_gc
= 0;
1379 if (gc_cons_threshold
< 10000)
1380 gc_cons_threshold
= 10000;
1382 if (omessage
|| minibuf_level
> 0)
1383 message2 (omessage
, omessage_length
);
1384 else if (!noninteractive
)
1385 message1 ("Garbage collecting...done");
1387 return Fcons (Fcons (make_number (total_conses
),
1388 make_number (total_free_conses
)),
1389 Fcons (Fcons (make_number (total_symbols
),
1390 make_number (total_free_symbols
)),
1391 Fcons (Fcons (make_number (total_markers
),
1392 make_number (total_free_markers
)),
1393 Fcons (make_number (total_string_size
),
1394 Fcons (make_number (total_vector_size
),
1396 #ifdef LISP_FLOAT_TYPE
1397 Fcons (Fcons (make_number (total_floats
),
1398 make_number (total_free_floats
)),
1400 #else /* not LISP_FLOAT_TYPE */
1402 #endif /* not LISP_FLOAT_TYPE */
1410 /* Clear marks on all conses */
1412 register struct cons_block
*cblk
;
1413 register int lim
= cons_block_index
;
1415 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1418 for (i
= 0; i
< lim
; i
++)
1419 XUNMARK (cblk
->conses
[i
].car
);
1420 lim
= CONS_BLOCK_SIZE
;
1423 /* Clear marks on all symbols */
1425 register struct symbol_block
*sblk
;
1426 register int lim
= symbol_block_index
;
1428 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1431 for (i
= 0; i
< lim
; i
++)
1433 XUNMARK (sblk
->symbols
[i
].plist
);
1435 lim
= SYMBOL_BLOCK_SIZE
;
1438 /* Clear marks on all markers */
1440 register struct marker_block
*sblk
;
1441 register int lim
= marker_block_index
;
1443 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1446 for (i
= 0; i
< lim
; i
++)
1447 if (sblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1448 XUNMARK (sblk
->markers
[i
].u_marker
.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 XSETFASTINT (*objptr
, ptr
->size
);
1526 XSETFASTINT (*objptr
, ptr
->size
);
1527 if ((EMACS_INT
) objptr
& 1) abort ();
1528 ptr
->size
= (EMACS_INT
) objptr
& ~MARKBIT
;
1529 if ((EMACS_INT
) objptr
& MARKBIT
)
1538 case Lisp_Window_Configuration
:
1540 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1541 register EMACS_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 EMACS_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 /* This cast should be unnecessary, but some Mips compiler complains
1577 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1578 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1585 /* See comment above under Lisp_Vector for why this is volatile. */
1586 register struct frame
*volatile ptr
= XFRAME (obj
);
1587 register EMACS_INT size
= ptr
->size
;
1589 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1590 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1592 mark_object (&ptr
->name
);
1593 mark_object (&ptr
->focus_frame
);
1594 mark_object (&ptr
->width
);
1595 mark_object (&ptr
->height
);
1596 mark_object (&ptr
->selected_window
);
1597 mark_object (&ptr
->minibuffer_window
);
1598 mark_object (&ptr
->param_alist
);
1599 mark_object (&ptr
->scroll_bars
);
1600 mark_object (&ptr
->condemned_scroll_bars
);
1601 mark_object (&ptr
->menu_bar_items
);
1602 mark_object (&ptr
->menu_bar_vector
);
1603 mark_object (&ptr
->face_alist
);
1606 #endif /* MULTI_FRAME */
1610 /* See comment above under Lisp_Vector for why this is volatile. */
1611 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1612 struct Lisp_Symbol
*ptrx
;
1614 if (XMARKBIT (ptr
->plist
)) break;
1616 mark_object ((Lisp_Object
*) &ptr
->value
);
1617 mark_object (&ptr
->function
);
1618 mark_object (&ptr
->plist
);
1619 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1620 mark_object (&ptr
->name
);
1624 /* For the benefit of the last_marked log. */
1625 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1626 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1627 XSETSYMBOL (obj
, ptrx
);
1628 /* We can't goto loop here because *objptr doesn't contain an
1629 actual Lisp_Object with valid datatype field. */
1636 switch (XMISC (obj
)->type
)
1638 case Lisp_Misc_Marker
:
1639 XMARK (XMARKER (obj
)->chain
);
1640 /* DO NOT mark thru the marker's chain.
1641 The buffer's markers chain does not preserve markers from gc;
1642 instead, markers are removed from the chain when freed by gc. */
1645 case Lisp_Misc_Intfwd
:
1646 case Lisp_Misc_Boolfwd
:
1647 case Lisp_Misc_Objfwd
:
1648 case Lisp_Misc_Buffer_Objfwd
:
1649 /* Don't bother with Lisp_Buffer_Objfwd,
1650 since all markable slots in current buffer marked anyway. */
1651 /* Don't need to do Lisp_Objfwd, since the places they point
1652 are protected with staticpro. */
1661 case Lisp_Buffer_Local_Value
:
1662 case Lisp_Some_Buffer_Local_Value
:
1665 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1666 if (XMARKBIT (ptr
->car
)) break;
1668 /* If the cdr is nil, avoid recursion for the car. */
1669 if (EQ (ptr
->cdr
, Qnil
))
1674 mark_object (&ptr
->car
);
1675 /* See comment above under Lisp_Vector for why not use ptr here. */
1676 objptr
= &XCONS (obj
)->cdr
;
1680 #ifdef LISP_FLOAT_TYPE
1682 XMARK (XFLOAT (obj
)->type
);
1684 #endif /* LISP_FLOAT_TYPE */
1687 if (!XMARKBIT (XBUFFER (obj
)->name
))
1700 /* Mark the pointers in a buffer structure. */
1706 register struct buffer
*buffer
= XBUFFER (buf
);
1707 register Lisp_Object
*ptr
;
1709 /* This is the buffer's markbit */
1710 mark_object (&buffer
->name
);
1711 XMARK (buffer
->name
);
1713 MARK_INTERVAL_TREE (buffer
->intervals
);
1716 mark_object (buffer
->syntax_table
);
1718 /* Mark the various string-pointers in the buffer object.
1719 Since the strings may be relocated, we must mark them
1720 in their actual slots. So gc_sweep must convert each slot
1721 back to an ordinary C pointer. */
1722 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1723 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1724 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1725 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1727 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1728 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1729 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1730 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1733 for (ptr
= &buffer
->name
+ 1;
1734 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1739 /* Sweep: find all structures not marked, and free them. */
1744 total_string_size
= 0;
1747 /* Put all unmarked conses on free list */
1749 register struct cons_block
*cblk
;
1750 register int lim
= cons_block_index
;
1751 register int num_free
= 0, num_used
= 0;
1755 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1758 for (i
= 0; i
< lim
; i
++)
1759 if (!XMARKBIT (cblk
->conses
[i
].car
))
1761 XSETFASTINT (cblk
->conses
[i
].car
, (EMACS_INT
) cons_free_list
);
1763 cons_free_list
= &cblk
->conses
[i
];
1768 XUNMARK (cblk
->conses
[i
].car
);
1770 lim
= CONS_BLOCK_SIZE
;
1772 total_conses
= num_used
;
1773 total_free_conses
= num_free
;
1776 #ifdef LISP_FLOAT_TYPE
1777 /* Put all unmarked floats on free list */
1779 register struct float_block
*fblk
;
1780 register int lim
= float_block_index
;
1781 register int num_free
= 0, num_used
= 0;
1783 float_free_list
= 0;
1785 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1788 for (i
= 0; i
< lim
; i
++)
1789 if (!XMARKBIT (fblk
->floats
[i
].type
))
1791 XSETFASTINT (fblk
->floats
[i
].type
, (EMACS_INT
) float_free_list
);
1793 float_free_list
= &fblk
->floats
[i
];
1798 XUNMARK (fblk
->floats
[i
].type
);
1800 lim
= FLOAT_BLOCK_SIZE
;
1802 total_floats
= num_used
;
1803 total_free_floats
= num_free
;
1805 #endif /* LISP_FLOAT_TYPE */
1807 #ifdef USE_TEXT_PROPERTIES
1808 /* Put all unmarked intervals on free list */
1810 register struct interval_block
*iblk
;
1811 register int lim
= interval_block_index
;
1812 register int num_free
= 0, num_used
= 0;
1814 interval_free_list
= 0;
1816 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1820 for (i
= 0; i
< lim
; i
++)
1822 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1824 iblk
->intervals
[i
].parent
= interval_free_list
;
1825 interval_free_list
= &iblk
->intervals
[i
];
1831 XUNMARK (iblk
->intervals
[i
].plist
);
1834 lim
= INTERVAL_BLOCK_SIZE
;
1836 total_intervals
= num_used
;
1837 total_free_intervals
= num_free
;
1839 #endif /* USE_TEXT_PROPERTIES */
1841 /* Put all unmarked symbols on free list */
1843 register struct symbol_block
*sblk
;
1844 register int lim
= symbol_block_index
;
1845 register int num_free
= 0, num_used
= 0;
1847 symbol_free_list
= 0;
1849 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1852 for (i
= 0; i
< lim
; i
++)
1853 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1855 XSETFASTINT (sblk
->symbols
[i
].value
, (EMACS_INT
) symbol_free_list
);
1856 symbol_free_list
= &sblk
->symbols
[i
];
1862 sblk
->symbols
[i
].name
1863 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1864 XUNMARK (sblk
->symbols
[i
].plist
);
1866 lim
= SYMBOL_BLOCK_SIZE
;
1868 total_symbols
= num_used
;
1869 total_free_symbols
= num_free
;
1873 /* Put all unmarked markers on free list.
1874 Dechain each one first from the buffer it points into. */
1876 register struct marker_block
*mblk
;
1877 struct Lisp_Marker
*tem1
;
1878 register int lim
= marker_block_index
;
1879 register int num_free
= 0, num_used
= 0;
1881 marker_free_list
= 0;
1883 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1886 for (i
= 0; i
< lim
; i
++)
1887 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1889 if (!XMARKBIT (mblk
->markers
[i
].u_marker
.chain
))
1892 tem1
= &mblk
->markers
[i
].u_marker
; /* tem1 avoids Sun compiler bug */
1893 XSETMARKER (tem
, tem1
);
1894 unchain_marker (tem
);
1895 /* We could leave the type alone, since nobody checks it,
1896 but this might catch bugs faster. */
1897 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
1898 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
1899 marker_free_list
= &mblk
->markers
[i
];
1905 XUNMARK (mblk
->markers
[i
].u_marker
.chain
);
1908 lim
= MARKER_BLOCK_SIZE
;
1911 total_markers
= num_used
;
1912 total_free_markers
= num_free
;
1915 /* Free all unmarked buffers */
1917 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1920 if (!XMARKBIT (buffer
->name
))
1923 prev
->next
= buffer
->next
;
1925 all_buffers
= buffer
->next
;
1926 next
= buffer
->next
;
1932 XUNMARK (buffer
->name
);
1933 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1936 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1937 for purposes of marking and relocation.
1938 Turn them back into C pointers now. */
1939 buffer
->upcase_table
1940 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1941 buffer
->downcase_table
1942 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1944 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1945 buffer
->folding_sort_table
1946 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1949 prev
= buffer
, buffer
= buffer
->next
;
1953 #endif /* standalone */
1955 /* Free all unmarked vectors */
1957 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1958 total_vector_size
= 0;
1961 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1964 prev
->next
= vector
->next
;
1966 all_vectors
= vector
->next
;
1967 next
= vector
->next
;
1973 vector
->size
&= ~ARRAY_MARK_FLAG
;
1974 total_vector_size
+= vector
->size
;
1975 prev
= vector
, vector
= vector
->next
;
1979 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1981 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1982 struct Lisp_String
*s
;
1986 s
= (struct Lisp_String
*) &sb
->chars
[0];
1987 if (s
->size
& ARRAY_MARK_FLAG
)
1989 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1990 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1991 UNMARK_BALANCE_INTERVALS (s
->intervals
);
1992 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1993 prev
= sb
, sb
= sb
->next
;
1998 prev
->next
= sb
->next
;
2000 large_string_blocks
= sb
->next
;
2009 /* Compactify strings, relocate references, and free empty string blocks. */
2014 /* String block of old strings we are scanning. */
2015 register struct string_block
*from_sb
;
2016 /* A preceding string block (or maybe the same one)
2017 where we are copying the still-live strings to. */
2018 register struct string_block
*to_sb
;
2022 to_sb
= first_string_block
;
2025 /* Scan each existing string block sequentially, string by string. */
2026 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2029 /* POS is the index of the next string in the block. */
2030 while (pos
< from_sb
->pos
)
2032 register struct Lisp_String
*nextstr
2033 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2035 register struct Lisp_String
*newaddr
;
2036 register EMACS_INT size
= nextstr
->size
;
2038 /* NEXTSTR is the old address of the next string.
2039 Just skip it if it isn't marked. */
2040 if ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2042 /* It is marked, so its size field is really a chain of refs.
2043 Find the end of the chain, where the actual size lives. */
2044 while ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2046 if (size
& 1) size
^= MARKBIT
| 1;
2047 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2050 total_string_size
+= size
;
2052 /* If it won't fit in TO_SB, close it out,
2053 and move to the next sb. Keep doing so until
2054 TO_SB reaches a large enough, empty enough string block.
2055 We know that TO_SB cannot advance past FROM_SB here
2056 since FROM_SB is large enough to contain this string.
2057 Any string blocks skipped here
2058 will be patched out and freed later. */
2059 while (to_pos
+ STRING_FULLSIZE (size
)
2060 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2062 to_sb
->pos
= to_pos
;
2063 to_sb
= to_sb
->next
;
2066 /* Compute new address of this string
2067 and update TO_POS for the space being used. */
2068 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2069 to_pos
+= STRING_FULLSIZE (size
);
2071 /* Copy the string itself to the new place. */
2072 if (nextstr
!= newaddr
)
2073 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2074 + INTERVAL_PTR_SIZE
);
2076 /* Go through NEXTSTR's chain of references
2077 and make each slot in the chain point to
2078 the new address of this string. */
2079 size
= newaddr
->size
;
2080 while ((EMACS_UINT
) size
> STRING_BLOCK_SIZE
)
2082 register Lisp_Object
*objptr
;
2083 if (size
& 1) size
^= MARKBIT
| 1;
2084 objptr
= (Lisp_Object
*)size
;
2086 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2087 if (XMARKBIT (*objptr
))
2089 XSETSTRING (*objptr
, newaddr
);
2093 XSETSTRING (*objptr
, newaddr
);
2095 /* Store the actual size in the size field. */
2096 newaddr
->size
= size
;
2098 #ifdef USE_TEXT_PROPERTIES
2099 /* Now that the string has been relocated, rebalance its
2100 interval tree, and update the tree's parent pointer. */
2101 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2103 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2104 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2107 #endif /* USE_TEXT_PROPERTIES */
2109 pos
+= STRING_FULLSIZE (size
);
2113 /* Close out the last string block still used and free any that follow. */
2114 to_sb
->pos
= to_pos
;
2115 current_string_block
= to_sb
;
2117 from_sb
= to_sb
->next
;
2121 to_sb
= from_sb
->next
;
2126 /* Free any empty string blocks further back in the chain.
2127 This loop will never free first_string_block, but it is very
2128 unlikely that that one will become empty, so why bother checking? */
2130 from_sb
= first_string_block
;
2131 while (to_sb
= from_sb
->next
)
2133 if (to_sb
->pos
== 0)
2135 if (from_sb
->next
= to_sb
->next
)
2136 from_sb
->next
->prev
= from_sb
;
2144 /* Debugging aids. */
2146 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2147 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2148 This may be helpful in debugging Emacs's memory usage.\n\
2149 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2154 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2160 /* Initialization */
2164 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2167 pure_size
= PURESIZE
;
2170 ignore_warnings
= 1;
2175 #ifdef LISP_FLOAT_TYPE
2177 #endif /* LISP_FLOAT_TYPE */
2180 ignore_warnings
= 0;
2183 consing_since_gc
= 0;
2184 gc_cons_threshold
= 100000;
2185 #ifdef VIRT_ADDR_VARIES
2186 malloc_sbrk_unused
= 1<<22; /* A large number */
2187 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2188 #endif /* VIRT_ADDR_VARIES */
2199 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2200 "*Number of bytes of consing between garbage collections.\n\
2201 Garbage collection can happen automatically once this many bytes have been\n\
2202 allocated since the last garbage collection. All data types count.\n\n\
2203 Garbage collection happens automatically only when `eval' is called.\n\n\
2204 By binding this temporarily to a large number, you can effectively\n\
2205 prevent garbage collection during a part of the program.");
2207 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2208 "Number of bytes of sharable Lisp data allocated so far.");
2211 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2212 "Number of bytes of unshared memory allocated in this session.");
2214 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2215 "Number of bytes of unshared memory remaining available in this session.");
2218 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2219 "Non-nil means loading Lisp code in order to dump an executable.\n\
2220 This means that certain objects should be allocated in shared (pure) space.");
2222 DEFVAR_INT ("undo-limit", &undo_limit
,
2223 "Keep no more undo information once it exceeds this size.\n\
2224 This limit is applied when garbage collection happens.\n\
2225 The size is counted as the number of bytes occupied,\n\
2226 which includes both saved text and other data.");
2229 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2230 "Don't keep more than this much size of undo information.\n\
2231 A command which pushes past this size is itself forgotten.\n\
2232 This limit is applied when garbage collection happens.\n\
2233 The size is counted as the number of bytes occupied,\n\
2234 which includes both saved text and other data.");
2235 undo_strong_limit
= 30000;
2237 /* We build this in advance because if we wait until we need it, we might
2238 not be able to allocate the memory to hold it. */
2240 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted"), Qnil
));
2241 staticpro (&memory_signal_data
);
2246 defsubr (&Smake_byte_code
);
2247 defsubr (&Smake_list
);
2248 defsubr (&Smake_vector
);
2249 defsubr (&Smake_string
);
2250 defsubr (&Smake_symbol
);
2251 defsubr (&Smake_marker
);
2252 defsubr (&Spurecopy
);
2253 defsubr (&Sgarbage_collect
);
2254 defsubr (&Smemory_limit
);