1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1993 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
24 #include "intervals.h"
30 #include "blockinput.h"
33 #include "syssignal.h"
35 #define max(A,B) ((A) > (B) ? (A) : (B))
37 /* Macro to verify that storage intended for Lisp objects is not
38 out of range to fit in the space for a pointer.
39 ADDRESS is the start of the block, and SIZE
40 is the amount of space within which objects can start. */
41 #define VALIDATE_LISP_STORAGE(address, size) \
45 XSET (val, Lisp_Cons, (char *) address + size); \
46 if ((char *) XCONS (val) != (char *) address + size) \
53 /* Number of bytes of consing done since the last gc */
56 /* Number of bytes of consing since gc before another gc should be done. */
57 int gc_cons_threshold
;
59 /* Nonzero during gc */
62 #ifndef VIRT_ADDR_VARIES
64 #endif /* VIRT_ADDR_VARIES */
67 #ifndef VIRT_ADDR_VARIES
69 #endif /* VIRT_ADDR_VARIES */
70 int malloc_sbrk_unused
;
72 /* Two limits controlling how much undo information to keep. */
74 int undo_strong_limit
;
76 /* Non-nil means defun should do purecopy on the function definition */
77 Lisp_Object Vpurify_flag
;
80 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
81 #define PUREBEG (char *) pure
83 #define pure PURE_SEG_BITS /* Use shared memory segment */
84 #define PUREBEG (char *)PURE_SEG_BITS
86 /* This variable is used only by the XPNTR macro when HAVE_SHM is
87 defined. If we used the PURESIZE macro directly there, that would
88 make most of emacs dependent on puresize.h, which we don't want -
89 you should be able to change that without too much recompilation.
90 So map_in_data initializes pure_size, and the dependencies work
93 #endif /* not HAVE_SHM */
95 /* Index in pure at which next pure object will be allocated. */
98 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
99 char *pending_malloc_warning
;
101 /* Maximum amount of C stack to save when a GC happens. */
103 #ifndef MAX_SAVE_STACK
104 #define MAX_SAVE_STACK 16000
107 /* Buffer in which we save a copy of the C stack at each GC. */
112 /* Non-zero means ignore malloc warnings. Set during initialization. */
115 static void mark_object (), mark_buffer ();
116 static void clear_marks (), gc_sweep ();
117 static void compact_strings ();
119 /* Versions of malloc and realloc that print warnings as memory gets full. */
122 malloc_warning_1 (str
)
125 Fprinc (str
, Vstandard_output
);
126 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
127 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
128 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
132 /* malloc calls this if it finds we are near exhausting storage */
136 pending_malloc_warning
= str
;
139 display_malloc_warning ()
141 register Lisp_Object val
;
143 val
= build_string (pending_malloc_warning
);
144 pending_malloc_warning
= 0;
145 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
148 /* Called if malloc returns zero */
151 error ("Memory exhausted");
154 /* like malloc routines but check for no memory and block interrupt input. */
163 val
= (long *) malloc (size
);
166 if (!val
&& size
) memory_full ();
171 xrealloc (block
, size
)
178 /* We must call malloc explicitly when BLOCK is 0, since some
179 reallocs don't do this. */
181 val
= (long *) malloc (size
);
183 val
= (long *) realloc (block
, size
);
186 if (!val
&& size
) memory_full ();
200 /* Arranging to disable input signals while we're in malloc.
202 This only works with GNU malloc. To help out systems which can't
203 use GNU malloc, all the calls to malloc, realloc, and free
204 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
205 pairs; unfortunately, we have no idea what C library functions
206 might call malloc, so we can't really protect them unless you're
207 using GNU malloc. Fortunately, most of the major operating can use
210 #ifndef SYSTEM_MALLOC
211 extern void * (*__malloc_hook
) ();
212 static void * (*old_malloc_hook
) ();
213 extern void * (*__realloc_hook
) ();
214 static void * (*old_realloc_hook
) ();
215 extern void (*__free_hook
) ();
216 static void (*old_free_hook
) ();
219 emacs_blocked_free (ptr
)
223 __free_hook
= old_free_hook
;
225 __free_hook
= emacs_blocked_free
;
230 emacs_blocked_malloc (size
)
236 __malloc_hook
= old_malloc_hook
;
237 value
= (void *) malloc (size
);
238 __malloc_hook
= emacs_blocked_malloc
;
245 emacs_blocked_realloc (ptr
, size
)
252 __realloc_hook
= old_realloc_hook
;
253 value
= (void *) realloc (ptr
, size
);
254 __realloc_hook
= emacs_blocked_realloc
;
261 uninterrupt_malloc ()
263 old_free_hook
= __free_hook
;
264 __free_hook
= emacs_blocked_free
;
266 old_malloc_hook
= __malloc_hook
;
267 __malloc_hook
= emacs_blocked_malloc
;
269 old_realloc_hook
= __realloc_hook
;
270 __realloc_hook
= emacs_blocked_realloc
;
274 /* Interval allocation. */
276 #ifdef USE_TEXT_PROPERTIES
277 #define INTERVAL_BLOCK_SIZE \
278 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
280 struct interval_block
282 struct interval_block
*next
;
283 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
286 struct interval_block
*interval_block
;
287 static int interval_block_index
;
289 INTERVAL interval_free_list
;
295 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
296 interval_block
->next
= 0;
297 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
298 interval_block_index
= 0;
299 interval_free_list
= 0;
302 #define INIT_INTERVALS init_intervals ()
309 if (interval_free_list
)
311 val
= interval_free_list
;
312 interval_free_list
= interval_free_list
->parent
;
316 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
318 register struct interval_block
*newi
319 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
321 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
322 newi
->next
= interval_block
;
323 interval_block
= newi
;
324 interval_block_index
= 0;
326 val
= &interval_block
->intervals
[interval_block_index
++];
328 consing_since_gc
+= sizeof (struct interval
);
329 RESET_INTERVAL (val
);
333 static int total_free_intervals
, total_intervals
;
335 /* Mark the pointers of one interval. */
338 mark_interval (i
, dummy
)
342 if (XMARKBIT (i
->plist
))
344 mark_object (&i
->plist
);
349 mark_interval_tree (tree
)
350 register INTERVAL tree
;
352 if (XMARKBIT (tree
->plist
))
355 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
358 #define MARK_INTERVAL_TREE(i) \
359 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
361 /* The oddity in the call to XUNMARK is necessary because XUNMARK
362 expands to an assignment to its argument, and most C compilers don't
363 support casts on the left operand of `='. */
364 #define UNMARK_BALANCE_INTERVALS(i) \
366 if (! NULL_INTERVAL_P (i)) \
368 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
369 (i) = balance_intervals (i); \
373 #else /* no interval use */
375 #define INIT_INTERVALS
377 #define UNMARK_BALANCE_INTERVALS(i)
378 #define MARK_INTERVAL_TREE(i)
380 #endif /* no interval use */
382 /* Floating point allocation. */
384 #ifdef LISP_FLOAT_TYPE
385 /* Allocation of float cells, just like conses */
386 /* We store float cells inside of float_blocks, allocating a new
387 float_block with malloc whenever necessary. Float cells reclaimed by
388 GC are put on a free list to be reallocated before allocating
389 any new float cells from the latest float_block.
391 Each float_block is just under 1020 bytes long,
392 since malloc really allocates in units of powers of two
393 and uses 4 bytes for its own overhead. */
395 #define FLOAT_BLOCK_SIZE \
396 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
400 struct float_block
*next
;
401 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
404 struct float_block
*float_block
;
405 int float_block_index
;
407 struct Lisp_Float
*float_free_list
;
412 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
413 float_block
->next
= 0;
414 bzero (float_block
->floats
, sizeof float_block
->floats
);
415 float_block_index
= 0;
419 /* Explicitly free a float cell. */
421 struct Lisp_Float
*ptr
;
423 XFASTINT (ptr
->type
) = (int) float_free_list
;
424 float_free_list
= ptr
;
428 make_float (float_value
)
431 register Lisp_Object val
;
435 XSET (val
, Lisp_Float
, float_free_list
);
436 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
440 if (float_block_index
== FLOAT_BLOCK_SIZE
)
442 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
443 VALIDATE_LISP_STORAGE (new, sizeof *new);
444 new->next
= float_block
;
446 float_block_index
= 0;
448 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
450 XFLOAT (val
)->data
= float_value
;
451 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
452 consing_since_gc
+= sizeof (struct Lisp_Float
);
456 #endif /* LISP_FLOAT_TYPE */
458 /* Allocation of cons cells */
459 /* We store cons cells inside of cons_blocks, allocating a new
460 cons_block with malloc whenever necessary. Cons cells reclaimed by
461 GC are put on a free list to be reallocated before allocating
462 any new cons cells from the latest cons_block.
464 Each cons_block is just under 1020 bytes long,
465 since malloc really allocates in units of powers of two
466 and uses 4 bytes for its own overhead. */
468 #define CONS_BLOCK_SIZE \
469 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
473 struct cons_block
*next
;
474 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
477 struct cons_block
*cons_block
;
478 int cons_block_index
;
480 struct Lisp_Cons
*cons_free_list
;
485 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
486 cons_block
->next
= 0;
487 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
488 cons_block_index
= 0;
492 /* Explicitly free a cons cell. */
494 struct Lisp_Cons
*ptr
;
496 XFASTINT (ptr
->car
) = (int) cons_free_list
;
497 cons_free_list
= ptr
;
500 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
501 "Create a new cons, give it CAR and CDR as components, and return it.")
503 Lisp_Object car
, cdr
;
505 register Lisp_Object val
;
509 XSET (val
, Lisp_Cons
, cons_free_list
);
510 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
514 if (cons_block_index
== CONS_BLOCK_SIZE
)
516 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
517 VALIDATE_LISP_STORAGE (new, sizeof *new);
518 new->next
= cons_block
;
520 cons_block_index
= 0;
522 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
524 XCONS (val
)->car
= car
;
525 XCONS (val
)->cdr
= cdr
;
526 consing_since_gc
+= sizeof (struct Lisp_Cons
);
530 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
531 "Return a newly created list with specified arguments as elements.\n\
532 Any number of arguments, even zero arguments, are allowed.")
535 register Lisp_Object
*args
;
537 register Lisp_Object len
, val
, val_tail
;
539 XFASTINT (len
) = nargs
;
540 val
= Fmake_list (len
, Qnil
);
542 while (!NILP (val_tail
))
544 XCONS (val_tail
)->car
= *args
++;
545 val_tail
= XCONS (val_tail
)->cdr
;
550 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
551 "Return a newly created list of length LENGTH, with each element being INIT.")
553 register Lisp_Object length
, init
;
555 register Lisp_Object val
;
558 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
559 length
= wrong_type_argument (Qnatnump
, length
);
560 size
= XINT (length
);
564 val
= Fcons (init
, val
);
568 /* Allocation of vectors */
570 struct Lisp_Vector
*all_vectors
;
572 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
573 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
574 See also the function `vector'.")
576 register Lisp_Object length
, init
;
578 register int sizei
, index
;
579 register Lisp_Object vector
;
580 register struct Lisp_Vector
*p
;
582 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
583 length
= wrong_type_argument (Qnatnump
, length
);
584 sizei
= XINT (length
);
586 p
= (struct Lisp_Vector
*) xmalloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
587 VALIDATE_LISP_STORAGE (p
, 0);
589 XSET (vector
, Lisp_Vector
, p
);
590 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
593 p
->next
= all_vectors
;
596 for (index
= 0; index
< sizei
; index
++)
597 p
->contents
[index
] = init
;
602 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
603 "Return a newly created vector with specified arguments as elements.\n\
604 Any number of arguments, even zero arguments, are allowed.")
609 register Lisp_Object len
, val
;
611 register struct Lisp_Vector
*p
;
613 XFASTINT (len
) = nargs
;
614 val
= Fmake_vector (len
, Qnil
);
616 for (index
= 0; index
< nargs
; index
++)
617 p
->contents
[index
] = args
[index
];
621 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
622 "Create a byte-code object with specified arguments as elements.\n\
623 The arguments should be the arglist, bytecode-string, constant vector,\n\
624 stack size, (optional) doc string, and (optional) interactive spec.\n\
625 The first four arguments are required; at most six have any\n\
631 register Lisp_Object len
, val
;
633 register struct Lisp_Vector
*p
;
635 XFASTINT (len
) = nargs
;
636 if (!NILP (Vpurify_flag
))
637 val
= make_pure_vector (len
);
639 val
= Fmake_vector (len
, Qnil
);
641 for (index
= 0; index
< nargs
; index
++)
643 if (!NILP (Vpurify_flag
))
644 args
[index
] = Fpurecopy (args
[index
]);
645 p
->contents
[index
] = args
[index
];
647 XSETTYPE (val
, Lisp_Compiled
);
651 /* Allocation of symbols.
652 Just like allocation of conses!
654 Each symbol_block is just under 1020 bytes long,
655 since malloc really allocates in units of powers of two
656 and uses 4 bytes for its own overhead. */
658 #define SYMBOL_BLOCK_SIZE \
659 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
663 struct symbol_block
*next
;
664 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
667 struct symbol_block
*symbol_block
;
668 int symbol_block_index
;
670 struct Lisp_Symbol
*symbol_free_list
;
675 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
676 symbol_block
->next
= 0;
677 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
678 symbol_block_index
= 0;
679 symbol_free_list
= 0;
682 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
683 "Return a newly allocated uninterned symbol whose name is NAME.\n\
684 Its value and function definition are void, and its property list is nil.")
688 register Lisp_Object val
;
689 register struct Lisp_Symbol
*p
;
691 CHECK_STRING (str
, 0);
693 if (symbol_free_list
)
695 XSET (val
, Lisp_Symbol
, symbol_free_list
);
697 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
701 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
703 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
704 VALIDATE_LISP_STORAGE (new, sizeof *new);
705 new->next
= symbol_block
;
707 symbol_block_index
= 0;
709 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
712 p
->name
= XSTRING (str
);
715 p
->function
= Qunbound
;
717 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
721 /* Allocation of markers.
722 Works like allocation of conses. */
724 #define MARKER_BLOCK_SIZE \
725 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
729 struct marker_block
*next
;
730 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
733 struct marker_block
*marker_block
;
734 int marker_block_index
;
736 struct Lisp_Marker
*marker_free_list
;
741 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
742 marker_block
->next
= 0;
743 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
744 marker_block_index
= 0;
745 marker_free_list
= 0;
748 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
749 "Return a newly allocated marker which does not point at any place.")
752 register Lisp_Object val
;
753 register struct Lisp_Marker
*p
;
755 if (marker_free_list
)
757 XSET (val
, Lisp_Marker
, marker_free_list
);
759 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
763 if (marker_block_index
== MARKER_BLOCK_SIZE
)
765 struct marker_block
*new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
766 VALIDATE_LISP_STORAGE (new, sizeof *new);
767 new->next
= marker_block
;
769 marker_block_index
= 0;
771 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
777 consing_since_gc
+= sizeof (struct Lisp_Marker
);
781 /* Allocation of strings */
783 /* Strings reside inside of string_blocks. The entire data of the string,
784 both the size and the contents, live in part of the `chars' component of a string_block.
785 The `pos' component is the index within `chars' of the first free byte.
787 first_string_block points to the first string_block ever allocated.
788 Each block points to the next one with its `next' field.
789 The `prev' fields chain in reverse order.
790 The last one allocated is the one currently being filled.
791 current_string_block points to it.
793 The string_blocks that hold individual large strings
794 go in a separate chain, started by large_string_blocks. */
797 /* String blocks contain this many useful bytes.
798 8188 is power of 2, minus 4 for malloc overhead. */
799 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
801 /* A string bigger than this gets its own specially-made string block
802 if it doesn't fit in the current one. */
803 #define STRING_BLOCK_OUTSIZE 1024
805 struct string_block_head
807 struct string_block
*next
, *prev
;
813 struct string_block
*next
, *prev
;
815 char chars
[STRING_BLOCK_SIZE
];
818 /* This points to the string block we are now allocating strings. */
820 struct string_block
*current_string_block
;
822 /* This points to the oldest string block, the one that starts the chain. */
824 struct string_block
*first_string_block
;
826 /* Last string block in chain of those made for individual large strings. */
828 struct string_block
*large_string_blocks
;
830 /* If SIZE is the length of a string, this returns how many bytes
831 the string occupies in a string_block (including padding). */
833 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
835 #define PAD (sizeof (int))
838 #define STRING_FULLSIZE(SIZE) \
839 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
845 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
846 first_string_block
= current_string_block
;
847 consing_since_gc
+= sizeof (struct string_block
);
848 current_string_block
->next
= 0;
849 current_string_block
->prev
= 0;
850 current_string_block
->pos
= 0;
851 large_string_blocks
= 0;
854 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
855 "Return a newly created string of length LENGTH, with each element being INIT.\n\
856 Both LENGTH and INIT must be numbers.")
858 Lisp_Object length
, init
;
860 register Lisp_Object val
;
861 register unsigned char *p
, *end
, c
;
863 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
864 length
= wrong_type_argument (Qnatnump
, length
);
865 CHECK_NUMBER (init
, 1);
866 val
= make_uninit_string (XINT (length
));
868 p
= XSTRING (val
)->data
;
869 end
= p
+ XSTRING (val
)->size
;
877 make_string (contents
, length
)
881 register Lisp_Object val
;
882 val
= make_uninit_string (length
);
883 bcopy (contents
, XSTRING (val
)->data
, length
);
891 return make_string (str
, strlen (str
));
895 make_uninit_string (length
)
898 register Lisp_Object val
;
899 register int fullsize
= STRING_FULLSIZE (length
);
901 if (length
< 0) abort ();
903 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
904 /* This string can fit in the current string block */
906 XSET (val
, Lisp_String
,
907 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
908 current_string_block
->pos
+= fullsize
;
910 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
911 /* This string gets its own string block */
913 register struct string_block
*new
914 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
915 VALIDATE_LISP_STORAGE (new, 0);
916 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
918 new->next
= large_string_blocks
;
919 large_string_blocks
= new;
920 XSET (val
, Lisp_String
,
921 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
924 /* Make a new current string block and start it off with this string */
926 register struct string_block
*new
927 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
928 VALIDATE_LISP_STORAGE (new, sizeof *new);
929 consing_since_gc
+= sizeof (struct string_block
);
930 current_string_block
->next
= new;
931 new->prev
= current_string_block
;
933 current_string_block
= new;
935 XSET (val
, Lisp_String
,
936 (struct Lisp_String
*) current_string_block
->chars
);
939 XSTRING (val
)->size
= length
;
940 XSTRING (val
)->data
[length
] = 0;
941 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
946 /* Return a newly created vector or string with specified arguments as
947 elements. If all the arguments are characters that can fit
948 in a string of events, make a string; otherwise, make a vector.
950 Any number of arguments, even zero arguments, are allowed. */
953 make_event_array (nargs
, args
)
959 for (i
= 0; i
< nargs
; i
++)
960 /* The things that fit in a string
961 are characters that are in 0...127,
962 after discarding the meta bit and all the bits above it. */
963 if (XTYPE (args
[i
]) != Lisp_Int
964 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
965 return Fvector (nargs
, args
);
967 /* Since the loop exited, we know that all the things in it are
968 characters, so we can make a string. */
970 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
972 for (i
= 0; i
< nargs
; i
++)
974 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
975 /* Move the meta bit to the right place for a string char. */
976 if (XINT (args
[i
]) & CHAR_META
)
977 XSTRING (result
)->data
[i
] |= 0x80;
984 /* Pure storage management. */
986 /* Must get an error if pure storage is full,
987 since if it cannot hold a large string
988 it may be able to hold conses that point to that string;
989 then the string is not protected from gc. */
992 make_pure_string (data
, length
)
996 register Lisp_Object
new;
997 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
999 if (pureptr
+ size
> PURESIZE
)
1000 error ("Pure Lisp storage exhausted");
1001 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
1002 XSTRING (new)->size
= length
;
1003 bcopy (data
, XSTRING (new)->data
, length
);
1004 XSTRING (new)->data
[length
] = 0;
1005 pureptr
+= (size
+ sizeof (int) - 1)
1006 / sizeof (int) * sizeof (int);
1011 pure_cons (car
, cdr
)
1012 Lisp_Object car
, cdr
;
1014 register Lisp_Object
new;
1016 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1017 error ("Pure Lisp storage exhausted");
1018 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
1019 pureptr
+= sizeof (struct Lisp_Cons
);
1020 XCONS (new)->car
= Fpurecopy (car
);
1021 XCONS (new)->cdr
= Fpurecopy (cdr
);
1025 #ifdef LISP_FLOAT_TYPE
1028 make_pure_float (num
)
1031 register Lisp_Object
new;
1033 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1034 (double) boundary. Some architectures (like the sparc) require
1035 this, and I suspect that floats are rare enough that it's no
1036 tragedy for those that do. */
1039 char *p
= PUREBEG
+ pureptr
;
1043 alignment
= __alignof (struct Lisp_Float
);
1045 alignment
= sizeof (struct Lisp_Float
);
1048 alignment
= sizeof (struct Lisp_Float
);
1050 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1051 pureptr
= p
- PUREBEG
;
1054 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1055 error ("Pure Lisp storage exhausted");
1056 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1057 pureptr
+= sizeof (struct Lisp_Float
);
1058 XFLOAT (new)->data
= num
;
1059 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1063 #endif /* LISP_FLOAT_TYPE */
1066 make_pure_vector (len
)
1069 register Lisp_Object
new;
1070 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1072 if (pureptr
+ size
> PURESIZE
)
1073 error ("Pure Lisp storage exhausted");
1075 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1077 XVECTOR (new)->size
= len
;
1081 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1082 "Make a copy of OBJECT in pure storage.\n\
1083 Recursively copies contents of vectors and cons cells.\n\
1084 Does not copy symbols.")
1086 register Lisp_Object obj
;
1088 register Lisp_Object
new, tem
;
1091 if (NILP (Vpurify_flag
))
1094 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1095 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1098 #ifdef SWITCH_ENUM_BUG
1099 switch ((int) XTYPE (obj
))
1101 switch (XTYPE (obj
))
1105 error ("Attempt to copy a marker to pure storage");
1108 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1110 #ifdef LISP_FLOAT_TYPE
1112 return make_pure_float (XFLOAT (obj
)->data
);
1113 #endif /* LISP_FLOAT_TYPE */
1116 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1120 new = make_pure_vector (XVECTOR (obj
)->size
);
1121 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1123 tem
= XVECTOR (obj
)->contents
[i
];
1124 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1126 XSETTYPE (new, XTYPE (obj
));
1134 /* Recording what needs to be marked for gc. */
1136 struct gcpro
*gcprolist
;
1138 #define NSTATICS 512
1140 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1144 /* Put an entry in staticvec, pointing at the variable whose address is given */
1147 staticpro (varaddress
)
1148 Lisp_Object
*varaddress
;
1150 staticvec
[staticidx
++] = varaddress
;
1151 if (staticidx
>= NSTATICS
)
1159 struct catchtag
*next
;
1160 /* jmp_buf jmp; /* We don't need this for GC purposes */
1165 struct backtrace
*next
;
1166 Lisp_Object
*function
;
1167 Lisp_Object
*args
; /* Points to vector of args. */
1168 int nargs
; /* length of vector */
1169 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1173 /* Two flags that are set during GC in the `size' component
1174 of a string or vector. On some machines, these flags
1175 are defined by the m- file to be different bits. */
1177 /* On vector, means it has been marked.
1178 On string size field or a reference to a string,
1179 means not the last reference in the chain. */
1181 #ifndef ARRAY_MARK_FLAG
1182 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1183 #endif /* no ARRAY_MARK_FLAG */
1185 /* Any slot that is a Lisp_Object can point to a string
1186 and thus can be put on a string's reference-chain
1187 and thus may need to have its ARRAY_MARK_FLAG set.
1188 This includes the slots whose markbits are used to mark
1189 the containing objects. */
1191 #if ARRAY_MARK_FLAG == MARKBIT
1195 /* Garbage collection! */
1197 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1198 int total_free_conses
, total_free_markers
, total_free_symbols
;
1199 #ifdef LISP_FLOAT_TYPE
1200 int total_free_floats
, total_floats
;
1201 #endif /* LISP_FLOAT_TYPE */
1203 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1204 "Reclaim storage for Lisp objects no longer needed.\n\
1205 Returns info on amount of space in use:\n\
1206 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1207 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1208 (USED-FLOATS . FREE-FLOATS))\n\
1209 Garbage collection happens automatically if you cons more than\n\
1210 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1213 register struct gcpro
*tail
;
1214 register struct specbinding
*bind
;
1215 struct catchtag
*catch;
1216 struct handler
*handler
;
1217 register struct backtrace
*backlist
;
1218 register Lisp_Object tem
;
1219 char *omessage
= echo_area_glyphs
;
1220 char stack_top_variable
;
1223 /* Save a copy of the contents of the stack, for debugging. */
1224 #if MAX_SAVE_STACK > 0
1225 if (NILP (Vpurify_flag
))
1227 i
= &stack_top_variable
- stack_bottom
;
1229 if (i
< MAX_SAVE_STACK
)
1231 if (stack_copy
== 0)
1232 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1233 else if (stack_copy_size
< i
)
1234 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1237 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1238 bcopy (stack_bottom
, stack_copy
, i
);
1240 bcopy (&stack_top_variable
, stack_copy
, i
);
1244 #endif /* MAX_SAVE_STACK > 0 */
1246 if (!noninteractive
)
1247 message1 ("Garbage collecting...");
1249 /* Don't keep command history around forever */
1250 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1252 XCONS (tem
)->cdr
= Qnil
;
1254 /* Likewise for undo information. */
1256 register struct buffer
*nextb
= all_buffers
;
1260 /* If a buffer's undo list is Qt, that means that undo is
1261 turned off in that buffer. Calling truncate_undo_list on
1262 Qt tends to return NULL, which effectively turns undo back on.
1263 So don't call truncate_undo_list if undo_list is Qt. */
1264 if (! EQ (nextb
->undo_list
, Qt
))
1266 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1268 nextb
= nextb
->next
;
1274 /* clear_marks (); */
1276 /* In each "large string", set the MARKBIT of the size field.
1277 That enables mark_object to recognize them. */
1279 register struct string_block
*b
;
1280 for (b
= large_string_blocks
; b
; b
= b
->next
)
1281 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1284 /* Mark all the special slots that serve as the roots of accessibility.
1286 Usually the special slots to mark are contained in particular structures.
1287 Then we know no slot is marked twice because the structures don't overlap.
1288 In some cases, the structures point to the slots to be marked.
1289 For these, we use MARKBIT to avoid double marking of the slot. */
1291 for (i
= 0; i
< staticidx
; i
++)
1292 mark_object (staticvec
[i
]);
1293 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1294 for (i
= 0; i
< tail
->nvars
; i
++)
1295 if (!XMARKBIT (tail
->var
[i
]))
1297 mark_object (&tail
->var
[i
]);
1298 XMARK (tail
->var
[i
]);
1300 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1302 mark_object (&bind
->symbol
);
1303 mark_object (&bind
->old_value
);
1305 for (catch = catchlist
; catch; catch = catch->next
)
1307 mark_object (&catch->tag
);
1308 mark_object (&catch->val
);
1310 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1312 mark_object (&handler
->handler
);
1313 mark_object (&handler
->var
);
1315 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1317 if (!XMARKBIT (*backlist
->function
))
1319 mark_object (backlist
->function
);
1320 XMARK (*backlist
->function
);
1322 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1325 i
= backlist
->nargs
- 1;
1327 if (!XMARKBIT (backlist
->args
[i
]))
1329 mark_object (&backlist
->args
[i
]);
1330 XMARK (backlist
->args
[i
]);
1336 /* Clear the mark bits that we set in certain root slots. */
1338 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1339 for (i
= 0; i
< tail
->nvars
; i
++)
1340 XUNMARK (tail
->var
[i
]);
1341 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1343 XUNMARK (*backlist
->function
);
1344 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1347 i
= backlist
->nargs
- 1;
1349 XUNMARK (backlist
->args
[i
]);
1351 XUNMARK (buffer_defaults
.name
);
1352 XUNMARK (buffer_local_symbols
.name
);
1354 /* clear_marks (); */
1357 consing_since_gc
= 0;
1358 if (gc_cons_threshold
< 10000)
1359 gc_cons_threshold
= 10000;
1362 message1 (omessage
);
1363 else if (!noninteractive
)
1364 message1 ("Garbage collecting...done");
1366 return Fcons (Fcons (make_number (total_conses
),
1367 make_number (total_free_conses
)),
1368 Fcons (Fcons (make_number (total_symbols
),
1369 make_number (total_free_symbols
)),
1370 Fcons (Fcons (make_number (total_markers
),
1371 make_number (total_free_markers
)),
1372 Fcons (make_number (total_string_size
),
1373 Fcons (make_number (total_vector_size
),
1375 #ifdef LISP_FLOAT_TYPE
1376 Fcons (Fcons (make_number (total_floats
),
1377 make_number (total_free_floats
)),
1379 #else /* not LISP_FLOAT_TYPE */
1381 #endif /* not LISP_FLOAT_TYPE */
1389 /* Clear marks on all conses */
1391 register struct cons_block
*cblk
;
1392 register int lim
= cons_block_index
;
1394 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1397 for (i
= 0; i
< lim
; i
++)
1398 XUNMARK (cblk
->conses
[i
].car
);
1399 lim
= CONS_BLOCK_SIZE
;
1402 /* Clear marks on all symbols */
1404 register struct symbol_block
*sblk
;
1405 register int lim
= symbol_block_index
;
1407 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1410 for (i
= 0; i
< lim
; i
++)
1412 XUNMARK (sblk
->symbols
[i
].plist
);
1414 lim
= SYMBOL_BLOCK_SIZE
;
1417 /* Clear marks on all markers */
1419 register struct marker_block
*sblk
;
1420 register int lim
= marker_block_index
;
1422 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1425 for (i
= 0; i
< lim
; i
++)
1426 XUNMARK (sblk
->markers
[i
].chain
);
1427 lim
= MARKER_BLOCK_SIZE
;
1430 /* Clear mark bits on all buffers */
1432 register struct buffer
*nextb
= all_buffers
;
1436 XUNMARK (nextb
->name
);
1437 nextb
= nextb
->next
;
1443 /* Mark reference to a Lisp_Object.
1444 If the object referred to has not been seen yet, recursively mark
1445 all the references contained in it.
1447 If the object referenced is a short string, the referencing slot
1448 is threaded into a chain of such slots, pointed to from
1449 the `size' field of the string. The actual string size
1450 lives in the last slot in the chain. We recognize the end
1451 because it is < (unsigned) STRING_BLOCK_SIZE. */
1453 #define LAST_MARKED_SIZE 500
1454 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1455 int last_marked_index
;
1458 mark_object (objptr
)
1459 Lisp_Object
*objptr
;
1461 register Lisp_Object obj
;
1468 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1469 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1472 last_marked
[last_marked_index
++] = objptr
;
1473 if (last_marked_index
== LAST_MARKED_SIZE
)
1474 last_marked_index
= 0;
1476 #ifdef SWITCH_ENUM_BUG
1477 switch ((int) XGCTYPE (obj
))
1479 switch (XGCTYPE (obj
))
1484 register struct Lisp_String
*ptr
= XSTRING (obj
);
1486 MARK_INTERVAL_TREE (ptr
->intervals
);
1487 if (ptr
->size
& MARKBIT
)
1488 /* A large string. Just set ARRAY_MARK_FLAG. */
1489 ptr
->size
|= ARRAY_MARK_FLAG
;
1492 /* A small string. Put this reference
1493 into the chain of references to it.
1494 The address OBJPTR is even, so if the address
1495 includes MARKBIT, put it in the low bit
1496 when we store OBJPTR into the size field. */
1498 if (XMARKBIT (*objptr
))
1500 XFASTINT (*objptr
) = ptr
->size
;
1504 XFASTINT (*objptr
) = ptr
->size
;
1505 if ((int)objptr
& 1) abort ();
1506 ptr
->size
= (int) objptr
& ~MARKBIT
;
1507 if ((int) objptr
& MARKBIT
)
1516 case Lisp_Window_Configuration
:
1518 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1519 register int size
= ptr
->size
;
1520 struct Lisp_Vector
*volatile ptr1
= ptr
;
1523 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1524 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1525 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1529 mark_object (&ptr
->contents
[i
]);
1535 /* We could treat this just like a vector, but it is better
1536 to save the COMPILED_CONSTANTS element for last and avoid recursion
1539 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1540 register int size
= ptr
->size
;
1541 struct Lisp_Vector
*volatile ptr1
= ptr
;
1544 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1545 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1546 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1550 if (i
!= COMPILED_CONSTANTS
)
1551 mark_object (&ptr
->contents
[i
]);
1553 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1561 register struct frame
*ptr
= XFRAME (obj
);
1562 register int size
= ptr
->size
;
1564 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1565 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1567 mark_object (&ptr
->name
);
1568 mark_object (&ptr
->focus_frame
);
1569 mark_object (&ptr
->width
);
1570 mark_object (&ptr
->height
);
1571 mark_object (&ptr
->selected_window
);
1572 mark_object (&ptr
->minibuffer_window
);
1573 mark_object (&ptr
->param_alist
);
1574 mark_object (&ptr
->scroll_bars
);
1575 mark_object (&ptr
->condemned_scroll_bars
);
1576 mark_object (&ptr
->menu_bar_items
);
1577 mark_object (&ptr
->face_alist
);
1580 #endif /* MULTI_FRAME */
1584 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1585 struct Lisp_Symbol
*ptrx
;
1587 if (XMARKBIT (ptr
->plist
)) break;
1589 mark_object ((Lisp_Object
*) &ptr
->value
);
1590 mark_object (&ptr
->function
);
1591 mark_object (&ptr
->plist
);
1592 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1593 mark_object (&ptr
->name
);
1597 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1598 XSETSYMBOL (obj
, ptrx
);
1605 XMARK (XMARKER (obj
)->chain
);
1606 /* DO NOT mark thru the marker's chain.
1607 The buffer's markers chain does not preserve markers from gc;
1608 instead, markers are removed from the chain when freed by gc. */
1612 case Lisp_Buffer_Local_Value
:
1613 case Lisp_Some_Buffer_Local_Value
:
1616 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1617 if (XMARKBIT (ptr
->car
)) break;
1619 /* If the cdr is nil, avoid recursion for the car. */
1620 if (EQ (ptr
->cdr
, Qnil
))
1629 mark_object (&ptr
->car
);
1637 #ifdef LISP_FLOAT_TYPE
1639 XMARK (XFLOAT (obj
)->type
);
1641 #endif /* LISP_FLOAT_TYPE */
1644 if (!XMARKBIT (XBUFFER (obj
)->name
))
1654 case Lisp_Buffer_Objfwd
:
1655 case Lisp_Internal_Stream
:
1656 /* Don't bother with Lisp_Buffer_Objfwd,
1657 since all markable slots in current buffer marked anyway. */
1658 /* Don't need to do Lisp_Objfwd, since the places they point
1659 are protected with staticpro. */
1667 /* Mark the pointers in a buffer structure. */
1673 register struct buffer
*buffer
= XBUFFER (buf
);
1674 register Lisp_Object
*ptr
;
1676 /* This is the buffer's markbit */
1677 mark_object (&buffer
->name
);
1678 XMARK (buffer
->name
);
1680 MARK_INTERVAL_TREE (buffer
->intervals
);
1683 mark_object (buffer
->syntax_table
);
1685 /* Mark the various string-pointers in the buffer object.
1686 Since the strings may be relocated, we must mark them
1687 in their actual slots. So gc_sweep must convert each slot
1688 back to an ordinary C pointer. */
1689 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1690 Lisp_String
, buffer
->upcase_table
);
1691 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1692 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1693 Lisp_String
, buffer
->downcase_table
);
1694 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1696 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1697 Lisp_String
, buffer
->sort_table
);
1698 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1699 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1700 Lisp_String
, buffer
->folding_sort_table
);
1701 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1704 for (ptr
= &buffer
->name
+ 1;
1705 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1710 /* Sweep: find all structures not marked, and free them. */
1715 total_string_size
= 0;
1718 /* Put all unmarked conses on free list */
1720 register struct cons_block
*cblk
;
1721 register int lim
= cons_block_index
;
1722 register int num_free
= 0, num_used
= 0;
1726 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1729 for (i
= 0; i
< lim
; i
++)
1730 if (!XMARKBIT (cblk
->conses
[i
].car
))
1732 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1734 cons_free_list
= &cblk
->conses
[i
];
1739 XUNMARK (cblk
->conses
[i
].car
);
1741 lim
= CONS_BLOCK_SIZE
;
1743 total_conses
= num_used
;
1744 total_free_conses
= num_free
;
1747 #ifdef LISP_FLOAT_TYPE
1748 /* Put all unmarked floats on free list */
1750 register struct float_block
*fblk
;
1751 register int lim
= float_block_index
;
1752 register int num_free
= 0, num_used
= 0;
1754 float_free_list
= 0;
1756 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1759 for (i
= 0; i
< lim
; i
++)
1760 if (!XMARKBIT (fblk
->floats
[i
].type
))
1762 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1764 float_free_list
= &fblk
->floats
[i
];
1769 XUNMARK (fblk
->floats
[i
].type
);
1771 lim
= FLOAT_BLOCK_SIZE
;
1773 total_floats
= num_used
;
1774 total_free_floats
= num_free
;
1776 #endif /* LISP_FLOAT_TYPE */
1778 #ifdef USE_TEXT_PROPERTIES
1779 /* Put all unmarked intervals on free list */
1781 register struct interval_block
*iblk
;
1782 register int lim
= interval_block_index
;
1783 register int num_free
= 0, num_used
= 0;
1785 interval_free_list
= 0;
1787 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1791 for (i
= 0; i
< lim
; i
++)
1793 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1795 iblk
->intervals
[i
].parent
= interval_free_list
;
1796 interval_free_list
= &iblk
->intervals
[i
];
1802 XUNMARK (iblk
->intervals
[i
].plist
);
1805 lim
= INTERVAL_BLOCK_SIZE
;
1807 total_intervals
= num_used
;
1808 total_free_intervals
= num_free
;
1810 #endif /* USE_TEXT_PROPERTIES */
1812 /* Put all unmarked symbols on free list */
1814 register struct symbol_block
*sblk
;
1815 register int lim
= symbol_block_index
;
1816 register int num_free
= 0, num_used
= 0;
1818 symbol_free_list
= 0;
1820 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1823 for (i
= 0; i
< lim
; i
++)
1824 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1826 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1827 symbol_free_list
= &sblk
->symbols
[i
];
1833 sblk
->symbols
[i
].name
1834 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1835 XUNMARK (sblk
->symbols
[i
].plist
);
1837 lim
= SYMBOL_BLOCK_SIZE
;
1839 total_symbols
= num_used
;
1840 total_free_symbols
= num_free
;
1844 /* Put all unmarked markers on free list.
1845 Dechain each one first from the buffer it points into. */
1847 register struct marker_block
*mblk
;
1848 struct Lisp_Marker
*tem1
;
1849 register int lim
= marker_block_index
;
1850 register int num_free
= 0, num_used
= 0;
1852 marker_free_list
= 0;
1854 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1857 for (i
= 0; i
< lim
; i
++)
1858 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1861 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1862 XSET (tem
, Lisp_Marker
, tem1
);
1863 unchain_marker (tem
);
1864 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1865 marker_free_list
= &mblk
->markers
[i
];
1871 XUNMARK (mblk
->markers
[i
].chain
);
1873 lim
= MARKER_BLOCK_SIZE
;
1876 total_markers
= num_used
;
1877 total_free_markers
= num_free
;
1880 /* Free all unmarked buffers */
1882 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1885 if (!XMARKBIT (buffer
->name
))
1888 prev
->next
= buffer
->next
;
1890 all_buffers
= buffer
->next
;
1891 next
= buffer
->next
;
1897 XUNMARK (buffer
->name
);
1898 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1901 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1902 for purposes of marking and relocation.
1903 Turn them back into C pointers now. */
1904 buffer
->upcase_table
1905 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1906 buffer
->downcase_table
1907 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1909 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1910 buffer
->folding_sort_table
1911 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1914 prev
= buffer
, buffer
= buffer
->next
;
1918 #endif /* standalone */
1920 /* Free all unmarked vectors */
1922 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1923 total_vector_size
= 0;
1926 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1929 prev
->next
= vector
->next
;
1931 all_vectors
= vector
->next
;
1932 next
= vector
->next
;
1938 vector
->size
&= ~ARRAY_MARK_FLAG
;
1939 total_vector_size
+= vector
->size
;
1940 prev
= vector
, vector
= vector
->next
;
1944 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1946 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1949 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1952 prev
->next
= sb
->next
;
1954 large_string_blocks
= sb
->next
;
1961 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1962 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1963 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1964 prev
= sb
, sb
= sb
->next
;
1969 /* Compactify strings, relocate references, and free empty string blocks. */
1974 /* String block of old strings we are scanning. */
1975 register struct string_block
*from_sb
;
1976 /* A preceding string block (or maybe the same one)
1977 where we are copying the still-live strings to. */
1978 register struct string_block
*to_sb
;
1982 to_sb
= first_string_block
;
1985 /* Scan each existing string block sequentially, string by string. */
1986 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1989 /* POS is the index of the next string in the block. */
1990 while (pos
< from_sb
->pos
)
1992 register struct Lisp_String
*nextstr
1993 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1995 register struct Lisp_String
*newaddr
;
1996 register int size
= nextstr
->size
;
1998 /* NEXTSTR is the old address of the next string.
1999 Just skip it if it isn't marked. */
2000 if ((unsigned) size
> STRING_BLOCK_SIZE
)
2002 /* It is marked, so its size field is really a chain of refs.
2003 Find the end of the chain, where the actual size lives. */
2004 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2006 if (size
& 1) size
^= MARKBIT
| 1;
2007 size
= *(int *)size
& ~MARKBIT
;
2010 total_string_size
+= size
;
2012 /* If it won't fit in TO_SB, close it out,
2013 and move to the next sb. Keep doing so until
2014 TO_SB reaches a large enough, empty enough string block.
2015 We know that TO_SB cannot advance past FROM_SB here
2016 since FROM_SB is large enough to contain this string.
2017 Any string blocks skipped here
2018 will be patched out and freed later. */
2019 while (to_pos
+ STRING_FULLSIZE (size
)
2020 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2022 to_sb
->pos
= to_pos
;
2023 to_sb
= to_sb
->next
;
2026 /* Compute new address of this string
2027 and update TO_POS for the space being used. */
2028 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2029 to_pos
+= STRING_FULLSIZE (size
);
2031 /* Copy the string itself to the new place. */
2032 if (nextstr
!= newaddr
)
2033 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
2034 + INTERVAL_PTR_SIZE
);
2036 /* Go through NEXTSTR's chain of references
2037 and make each slot in the chain point to
2038 the new address of this string. */
2039 size
= newaddr
->size
;
2040 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2042 register Lisp_Object
*objptr
;
2043 if (size
& 1) size
^= MARKBIT
| 1;
2044 objptr
= (Lisp_Object
*)size
;
2046 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2047 if (XMARKBIT (*objptr
))
2049 XSET (*objptr
, Lisp_String
, newaddr
);
2053 XSET (*objptr
, Lisp_String
, newaddr
);
2055 /* Store the actual size in the size field. */
2056 newaddr
->size
= size
;
2058 pos
+= STRING_FULLSIZE (size
);
2062 /* Close out the last string block still used and free any that follow. */
2063 to_sb
->pos
= to_pos
;
2064 current_string_block
= to_sb
;
2066 from_sb
= to_sb
->next
;
2070 to_sb
= from_sb
->next
;
2075 /* Free any empty string blocks further back in the chain.
2076 This loop will never free first_string_block, but it is very
2077 unlikely that that one will become empty, so why bother checking? */
2079 from_sb
= first_string_block
;
2080 while (to_sb
= from_sb
->next
)
2082 if (to_sb
->pos
== 0)
2084 if (from_sb
->next
= to_sb
->next
)
2085 from_sb
->next
->prev
= from_sb
;
2093 /* Debugging aids. */
2095 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2096 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2097 This may be helpful in debugging Emacs's memory usage.\n\
2098 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2103 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2109 /* Initialization */
2113 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2116 pure_size
= PURESIZE
;
2119 ignore_warnings
= 1;
2124 #ifdef LISP_FLOAT_TYPE
2126 #endif /* LISP_FLOAT_TYPE */
2129 ignore_warnings
= 0;
2132 consing_since_gc
= 0;
2133 gc_cons_threshold
= 100000;
2134 #ifdef VIRT_ADDR_VARIES
2135 malloc_sbrk_unused
= 1<<22; /* A large number */
2136 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2137 #endif /* VIRT_ADDR_VARIES */
2148 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2149 "*Number of bytes of consing between garbage collections.\n\
2150 Garbage collection can happen automatically once this many bytes have been\n\
2151 allocated since the last garbage collection. All data types count.\n\n\
2152 Garbage collection happens automatically only when `eval' is called.\n\n\
2153 By binding this temporarily to a large number, you can effectively\n\
2154 prevent garbage collection during a part of the program.");
2156 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2157 "Number of bytes of sharable Lisp data allocated so far.");
2160 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2161 "Number of bytes of unshared memory allocated in this session.");
2163 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2164 "Number of bytes of unshared memory remaining available in this session.");
2167 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2168 "Non-nil means loading Lisp code in order to dump an executable.\n\
2169 This means that certain objects should be allocated in shared (pure) space.");
2171 DEFVAR_INT ("undo-limit", &undo_limit
,
2172 "Keep no more undo information once it exceeds this size.\n\
2173 This limit is applied when garbage collection happens.\n\
2174 The size is counted as the number of bytes occupied,\n\
2175 which includes both saved text and other data.");
2178 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2179 "Don't keep more than this much size of undo information.\n\
2180 A command which pushes past this size is itself forgotten.\n\
2181 This limit is applied when garbage collection happens.\n\
2182 The size is counted as the number of bytes occupied,\n\
2183 which includes both saved text and other data.");
2184 undo_strong_limit
= 30000;
2189 defsubr (&Smake_byte_code
);
2190 defsubr (&Smake_list
);
2191 defsubr (&Smake_vector
);
2192 defsubr (&Smake_string
);
2193 defsubr (&Smake_symbol
);
2194 defsubr (&Smake_marker
);
2195 defsubr (&Spurecopy
);
2196 defsubr (&Sgarbage_collect
);
2197 defsubr (&Smemory_limit
);