1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
23 #include "intervals.h"
29 #include "blockinput.h"
32 #include "syssignal.h"
34 #define max(A,B) ((A) > (B) ? (A) : (B))
36 /* Macro to verify that storage intended for Lisp objects is not
37 out of range to fit in the space for a pointer.
38 ADDRESS is the start of the block, and SIZE
39 is the amount of space within which objects can start. */
40 #define VALIDATE_LISP_STORAGE(address, size) \
44 XSET (val, Lisp_Cons, (char *) address + size); \
45 if ((char *) XCONS (val) != (char *) address + size) \
52 /* Number of bytes of consing done since the last gc */
55 /* Number of bytes of consing since gc before another gc should be done. */
56 int gc_cons_threshold
;
58 /* Nonzero during gc */
61 #ifndef VIRT_ADDR_VARIES
63 #endif /* VIRT_ADDR_VARIES */
66 #ifndef VIRT_ADDR_VARIES
68 #endif /* VIRT_ADDR_VARIES */
69 int malloc_sbrk_unused
;
71 /* Two limits controlling how much undo information to keep. */
73 int undo_strong_limit
;
75 /* Non-nil means defun should do purecopy on the function definition */
76 Lisp_Object Vpurify_flag
;
79 int pure
[PURESIZE
/ sizeof (int)] = {0,}; /* Force it into data space! */
80 #define PUREBEG (char *) pure
82 #define pure PURE_SEG_BITS /* Use shared memory segment */
83 #define PUREBEG (char *)PURE_SEG_BITS
85 /* This variable is used only by the XPNTR macro when HAVE_SHM is
86 defined. If we used the PURESIZE macro directly there, that would
87 make most of emacs dependent on puresize.h, which we don't want -
88 you should be able to change that without too much recompilation.
89 So map_in_data initializes pure_size, and the dependencies work
92 #endif /* not HAVE_SHM */
94 /* Index in pure at which next pure object will be allocated. */
97 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
98 char *pending_malloc_warning
;
100 /* Maximum amount of C stack to save when a GC happens. */
102 #ifndef MAX_SAVE_STACK
103 #define MAX_SAVE_STACK 16000
106 /* Buffer in which we save a copy of the C stack at each GC. */
111 /* Non-zero means ignore malloc warnings. Set during initialization. */
114 static void mark_object (), mark_buffer ();
115 static void clear_marks (), gc_sweep ();
116 static void compact_strings ();
118 /* Versions of malloc and realloc that print warnings as memory gets full. */
121 malloc_warning_1 (str
)
124 Fprinc (str
, Vstandard_output
);
125 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
126 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
127 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
131 /* malloc calls this if it finds we are near exhausting storage */
135 pending_malloc_warning
= str
;
138 display_malloc_warning ()
140 register Lisp_Object val
;
142 val
= build_string (pending_malloc_warning
);
143 pending_malloc_warning
= 0;
144 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
147 /* Called if malloc returns zero */
150 error ("Memory exhausted");
153 /* like malloc routines but check for no memory and block interrupt input. */
162 val
= (long *) malloc (size
);
165 if (!val
&& size
) memory_full ();
170 xrealloc (block
, size
)
177 /* We must call malloc explicitly when BLOCK is 0, since some
178 reallocs don't do this. */
180 val
= (long *) malloc (size
);
182 val
= (long *) realloc (block
, size
);
185 if (!val
&& size
) memory_full ();
199 /* Arranging to disable input signals while we're in malloc.
201 This only works with GNU malloc. To help out systems which can't
202 use GNU malloc, all the calls to malloc, realloc, and free
203 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
204 pairs; unfortunately, we have no idea what C library functions
205 might call malloc, so we can't really protect them unless you're
206 using GNU malloc. Fortunately, most of the major operating can use
209 #ifndef SYSTEM_MALLOC
210 extern void * (*__malloc_hook
) ();
211 static void * (*old_malloc_hook
) ();
212 extern void * (*__realloc_hook
) ();
213 static void * (*old_realloc_hook
) ();
214 extern void (*__free_hook
) ();
215 static void (*old_free_hook
) ();
218 emacs_blocked_free (ptr
)
222 __free_hook
= old_free_hook
;
224 __free_hook
= emacs_blocked_free
;
229 emacs_blocked_malloc (size
)
235 __malloc_hook
= old_malloc_hook
;
236 value
= malloc (size
);
237 __malloc_hook
= emacs_blocked_malloc
;
244 emacs_blocked_realloc (ptr
, size
)
251 __realloc_hook
= old_realloc_hook
;
252 value
= realloc (ptr
, size
);
253 __realloc_hook
= emacs_blocked_realloc
;
260 uninterrupt_malloc ()
262 old_free_hook
= __free_hook
;
263 __free_hook
= emacs_blocked_free
;
265 old_malloc_hook
= __malloc_hook
;
266 __malloc_hook
= emacs_blocked_malloc
;
268 old_realloc_hook
= __realloc_hook
;
269 __realloc_hook
= emacs_blocked_realloc
;
273 /* Interval allocation. */
275 #ifdef USE_TEXT_PROPERTIES
276 #define INTERVAL_BLOCK_SIZE \
277 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
279 struct interval_block
281 struct interval_block
*next
;
282 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
285 struct interval_block
*interval_block
;
286 static int interval_block_index
;
288 INTERVAL interval_free_list
;
294 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
295 interval_block
->next
= 0;
296 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
297 interval_block_index
= 0;
298 interval_free_list
= 0;
301 #define INIT_INTERVALS init_intervals ()
308 if (interval_free_list
)
310 val
= interval_free_list
;
311 interval_free_list
= interval_free_list
->parent
;
315 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
317 register struct interval_block
*newi
318 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
320 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
321 newi
->next
= interval_block
;
322 interval_block
= newi
;
323 interval_block_index
= 0;
325 val
= &interval_block
->intervals
[interval_block_index
++];
327 consing_since_gc
+= sizeof (struct interval
);
328 RESET_INTERVAL (val
);
332 static int total_free_intervals
, total_intervals
;
334 /* Mark the pointers of one interval. */
337 mark_interval (i
, dummy
)
341 if (XMARKBIT (i
->plist
))
343 mark_object (&i
->plist
);
348 mark_interval_tree (tree
)
349 register INTERVAL tree
;
351 if (XMARKBIT (tree
->plist
))
354 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
357 #define MARK_INTERVAL_TREE(i) \
358 { if (!NULL_INTERVAL_P (i)) mark_interval_tree (i); }
360 /* The oddity in the call to XUNMARK is necessary because XUNMARK
361 expands to an assigment to its argument, and most C compilers don't
362 support casts on the left operand of `='. */
363 #define UNMARK_BALANCE_INTERVALS(i) \
365 if (! NULL_INTERVAL_P (i)) \
367 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
368 (i) = balance_intervals (i); \
372 #else /* no interval use */
374 #define INIT_INTERVALS
376 #define UNMARK_BALANCE_INTERVALS(i)
377 #define MARK_INTERVAL_TREE(i)
379 #endif /* no interval use */
381 /* Floating point allocation. */
383 #ifdef LISP_FLOAT_TYPE
384 /* Allocation of float cells, just like conses */
385 /* We store float cells inside of float_blocks, allocating a new
386 float_block with malloc whenever necessary. Float cells reclaimed by
387 GC are put on a free list to be reallocated before allocating
388 any new float cells from the latest float_block.
390 Each float_block is just under 1020 bytes long,
391 since malloc really allocates in units of powers of two
392 and uses 4 bytes for its own overhead. */
394 #define FLOAT_BLOCK_SIZE \
395 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
399 struct float_block
*next
;
400 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
403 struct float_block
*float_block
;
404 int float_block_index
;
406 struct Lisp_Float
*float_free_list
;
411 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
412 float_block
->next
= 0;
413 bzero (float_block
->floats
, sizeof float_block
->floats
);
414 float_block_index
= 0;
418 /* Explicitly free a float cell. */
420 struct Lisp_Float
*ptr
;
422 XFASTINT (ptr
->type
) = (int) float_free_list
;
423 float_free_list
= ptr
;
427 make_float (float_value
)
430 register Lisp_Object val
;
434 XSET (val
, Lisp_Float
, float_free_list
);
435 float_free_list
= (struct Lisp_Float
*) XFASTINT (float_free_list
->type
);
439 if (float_block_index
== FLOAT_BLOCK_SIZE
)
441 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
442 VALIDATE_LISP_STORAGE (new, sizeof *new);
443 new->next
= float_block
;
445 float_block_index
= 0;
447 XSET (val
, Lisp_Float
, &float_block
->floats
[float_block_index
++]);
449 XFLOAT (val
)->data
= float_value
;
450 XFLOAT (val
)->type
= 0; /* bug chasing -wsr */
451 consing_since_gc
+= sizeof (struct Lisp_Float
);
455 #endif /* LISP_FLOAT_TYPE */
457 /* Allocation of cons cells */
458 /* We store cons cells inside of cons_blocks, allocating a new
459 cons_block with malloc whenever necessary. Cons cells reclaimed by
460 GC are put on a free list to be reallocated before allocating
461 any new cons cells from the latest cons_block.
463 Each cons_block is just under 1020 bytes long,
464 since malloc really allocates in units of powers of two
465 and uses 4 bytes for its own overhead. */
467 #define CONS_BLOCK_SIZE \
468 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
472 struct cons_block
*next
;
473 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
476 struct cons_block
*cons_block
;
477 int cons_block_index
;
479 struct Lisp_Cons
*cons_free_list
;
484 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
485 cons_block
->next
= 0;
486 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
487 cons_block_index
= 0;
491 /* Explicitly free a cons cell. */
493 struct Lisp_Cons
*ptr
;
495 XFASTINT (ptr
->car
) = (int) cons_free_list
;
496 cons_free_list
= ptr
;
499 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
500 "Create a new cons, give it CAR and CDR as components, and return it.")
502 Lisp_Object car
, cdr
;
504 register Lisp_Object val
;
508 XSET (val
, Lisp_Cons
, cons_free_list
);
509 cons_free_list
= (struct Lisp_Cons
*) XFASTINT (cons_free_list
->car
);
513 if (cons_block_index
== CONS_BLOCK_SIZE
)
515 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
516 VALIDATE_LISP_STORAGE (new, sizeof *new);
517 new->next
= cons_block
;
519 cons_block_index
= 0;
521 XSET (val
, Lisp_Cons
, &cons_block
->conses
[cons_block_index
++]);
523 XCONS (val
)->car
= car
;
524 XCONS (val
)->cdr
= cdr
;
525 consing_since_gc
+= sizeof (struct Lisp_Cons
);
529 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
530 "Return a newly created list with specified arguments as elements.\n\
531 Any number of arguments, even zero arguments, are allowed.")
534 register Lisp_Object
*args
;
536 register Lisp_Object len
, val
, val_tail
;
538 XFASTINT (len
) = nargs
;
539 val
= Fmake_list (len
, Qnil
);
541 while (!NILP (val_tail
))
543 XCONS (val_tail
)->car
= *args
++;
544 val_tail
= XCONS (val_tail
)->cdr
;
549 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
550 "Return a newly created list of length LENGTH, with each element being INIT.")
552 register Lisp_Object length
, init
;
554 register Lisp_Object val
;
557 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
558 length
= wrong_type_argument (Qnatnump
, length
);
559 size
= XINT (length
);
563 val
= Fcons (init
, val
);
567 /* Allocation of vectors */
569 struct Lisp_Vector
*all_vectors
;
571 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
572 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
573 See also the function `vector'.")
575 register Lisp_Object length
, init
;
577 register int sizei
, index
;
578 register Lisp_Object vector
;
579 register struct Lisp_Vector
*p
;
581 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
582 length
= wrong_type_argument (Qnatnump
, length
);
583 sizei
= XINT (length
);
585 p
= (struct Lisp_Vector
*) xmalloc (sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
));
586 VALIDATE_LISP_STORAGE (p
, 0);
588 XSET (vector
, Lisp_Vector
, p
);
589 consing_since_gc
+= sizeof (struct Lisp_Vector
) + (sizei
- 1) * sizeof (Lisp_Object
);
592 p
->next
= all_vectors
;
595 for (index
= 0; index
< sizei
; index
++)
596 p
->contents
[index
] = init
;
601 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
602 "Return a newly created vector with specified arguments as elements.\n\
603 Any number of arguments, even zero arguments, are allowed.")
608 register Lisp_Object len
, val
;
610 register struct Lisp_Vector
*p
;
612 XFASTINT (len
) = nargs
;
613 val
= Fmake_vector (len
, Qnil
);
615 for (index
= 0; index
< nargs
; index
++)
616 p
->contents
[index
] = args
[index
];
620 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
621 "Create a byte-code object with specified arguments as elements.\n\
622 The arguments should be the arglist, bytecode-string, constant vector,\n\
623 stack size, (optional) doc string, and (optional) interactive spec.\n\
624 The first four arguments are required; at most six have any\n\
630 register Lisp_Object len
, val
;
632 register struct Lisp_Vector
*p
;
634 XFASTINT (len
) = nargs
;
635 if (!NILP (Vpurify_flag
))
636 val
= make_pure_vector (len
);
638 val
= Fmake_vector (len
, Qnil
);
640 for (index
= 0; index
< nargs
; index
++)
642 if (!NILP (Vpurify_flag
))
643 args
[index
] = Fpurecopy (args
[index
]);
644 p
->contents
[index
] = args
[index
];
646 XSETTYPE (val
, Lisp_Compiled
);
650 /* Allocation of symbols.
651 Just like allocation of conses!
653 Each symbol_block is just under 1020 bytes long,
654 since malloc really allocates in units of powers of two
655 and uses 4 bytes for its own overhead. */
657 #define SYMBOL_BLOCK_SIZE \
658 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
662 struct symbol_block
*next
;
663 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
666 struct symbol_block
*symbol_block
;
667 int symbol_block_index
;
669 struct Lisp_Symbol
*symbol_free_list
;
674 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
675 symbol_block
->next
= 0;
676 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
677 symbol_block_index
= 0;
678 symbol_free_list
= 0;
681 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
682 "Return a newly allocated uninterned symbol whose name is NAME.\n\
683 Its value and function definition are void, and its property list is nil.")
687 register Lisp_Object val
;
688 register struct Lisp_Symbol
*p
;
690 CHECK_STRING (str
, 0);
692 if (symbol_free_list
)
694 XSET (val
, Lisp_Symbol
, symbol_free_list
);
696 = (struct Lisp_Symbol
*) XFASTINT (symbol_free_list
->value
);
700 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
702 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
703 VALIDATE_LISP_STORAGE (new, sizeof *new);
704 new->next
= symbol_block
;
706 symbol_block_index
= 0;
708 XSET (val
, Lisp_Symbol
, &symbol_block
->symbols
[symbol_block_index
++]);
711 p
->name
= XSTRING (str
);
714 p
->function
= Qunbound
;
716 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
720 /* Allocation of markers.
721 Works like allocation of conses. */
723 #define MARKER_BLOCK_SIZE \
724 ((1020 - sizeof (struct marker_block *)) / sizeof (struct Lisp_Marker))
728 struct marker_block
*next
;
729 struct Lisp_Marker markers
[MARKER_BLOCK_SIZE
];
732 struct marker_block
*marker_block
;
733 int marker_block_index
;
735 struct Lisp_Marker
*marker_free_list
;
740 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
741 marker_block
->next
= 0;
742 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
743 marker_block_index
= 0;
744 marker_free_list
= 0;
747 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
748 "Return a newly allocated marker which does not point at any place.")
751 register Lisp_Object val
;
752 register struct Lisp_Marker
*p
;
754 if (marker_free_list
)
756 XSET (val
, Lisp_Marker
, marker_free_list
);
758 = (struct Lisp_Marker
*) XFASTINT (marker_free_list
->chain
);
762 if (marker_block_index
== MARKER_BLOCK_SIZE
)
764 struct marker_block
*new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
765 VALIDATE_LISP_STORAGE (new, sizeof *new);
766 new->next
= marker_block
;
768 marker_block_index
= 0;
770 XSET (val
, Lisp_Marker
, &marker_block
->markers
[marker_block_index
++]);
776 consing_since_gc
+= sizeof (struct Lisp_Marker
);
780 /* Allocation of strings */
782 /* Strings reside inside of string_blocks. The entire data of the string,
783 both the size and the contents, live in part of the `chars' component of a string_block.
784 The `pos' component is the index within `chars' of the first free byte.
786 first_string_block points to the first string_block ever allocated.
787 Each block points to the next one with its `next' field.
788 The `prev' fields chain in reverse order.
789 The last one allocated is the one currently being filled.
790 current_string_block points to it.
792 The string_blocks that hold individual large strings
793 go in a separate chain, started by large_string_blocks. */
796 /* String blocks contain this many useful bytes.
797 8188 is power of 2, minus 4 for malloc overhead. */
798 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
800 /* A string bigger than this gets its own specially-made string block
801 if it doesn't fit in the current one. */
802 #define STRING_BLOCK_OUTSIZE 1024
804 struct string_block_head
806 struct string_block
*next
, *prev
;
812 struct string_block
*next
, *prev
;
814 char chars
[STRING_BLOCK_SIZE
];
817 /* This points to the string block we are now allocating strings. */
819 struct string_block
*current_string_block
;
821 /* This points to the oldest string block, the one that starts the chain. */
823 struct string_block
*first_string_block
;
825 /* Last string block in chain of those made for individual large strings. */
827 struct string_block
*large_string_blocks
;
829 /* If SIZE is the length of a string, this returns how many bytes
830 the string occupies in a string_block (including padding). */
832 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
834 #define PAD (sizeof (int))
837 #define STRING_FULLSIZE(SIZE) \
838 (((SIZE) + 2 * sizeof (int)) & ~(sizeof (int) - 1))
844 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
845 first_string_block
= current_string_block
;
846 consing_since_gc
+= sizeof (struct string_block
);
847 current_string_block
->next
= 0;
848 current_string_block
->prev
= 0;
849 current_string_block
->pos
= 0;
850 large_string_blocks
= 0;
853 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
854 "Return a newly created string of length LENGTH, with each element being INIT.\n\
855 Both LENGTH and INIT must be numbers.")
857 Lisp_Object length
, init
;
859 register Lisp_Object val
;
860 register unsigned char *p
, *end
, c
;
862 if (XTYPE (length
) != Lisp_Int
|| XINT (length
) < 0)
863 length
= wrong_type_argument (Qnatnump
, length
);
864 CHECK_NUMBER (init
, 1);
865 val
= make_uninit_string (XINT (length
));
867 p
= XSTRING (val
)->data
;
868 end
= p
+ XSTRING (val
)->size
;
876 make_string (contents
, length
)
880 register Lisp_Object val
;
881 val
= make_uninit_string (length
);
882 bcopy (contents
, XSTRING (val
)->data
, length
);
890 return make_string (str
, strlen (str
));
894 make_uninit_string (length
)
897 register Lisp_Object val
;
898 register int fullsize
= STRING_FULLSIZE (length
);
900 if (length
< 0) abort ();
902 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
903 /* This string can fit in the current string block */
905 XSET (val
, Lisp_String
,
906 (struct Lisp_String
*) (current_string_block
->chars
+ current_string_block
->pos
));
907 current_string_block
->pos
+= fullsize
;
909 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
910 /* This string gets its own string block */
912 register struct string_block
*new
913 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
914 VALIDATE_LISP_STORAGE (new, 0);
915 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
917 new->next
= large_string_blocks
;
918 large_string_blocks
= new;
919 XSET (val
, Lisp_String
,
920 (struct Lisp_String
*) ((struct string_block_head
*)new + 1));
923 /* Make a new current string block and start it off with this string */
925 register struct string_block
*new
926 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
927 VALIDATE_LISP_STORAGE (new, sizeof *new);
928 consing_since_gc
+= sizeof (struct string_block
);
929 current_string_block
->next
= new;
930 new->prev
= current_string_block
;
932 current_string_block
= new;
934 XSET (val
, Lisp_String
,
935 (struct Lisp_String
*) current_string_block
->chars
);
938 XSTRING (val
)->size
= length
;
939 XSTRING (val
)->data
[length
] = 0;
940 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
945 /* Return a newly created vector or string with specified arguments as
946 elements. If all the arguments are characters that can fit
947 in a string of events, make a string; otherwise, make a vector.
949 Any number of arguments, even zero arguments, are allowed. */
952 make_event_array (nargs
, args
)
958 for (i
= 0; i
< nargs
; i
++)
959 /* The things that fit in a string
960 are characters that are in 0...127 after discarding the meta bit. */
961 if (XTYPE (args
[i
]) != Lisp_Int
962 || (XUINT (args
[i
]) & ~CHAR_META
) >= 0200)
963 return Fvector (nargs
, args
);
965 /* Since the loop exited, we know that all the things in it are
966 characters, so we can make a string. */
968 Lisp_Object result
= Fmake_string (nargs
, make_number (0));
970 for (i
= 0; i
< nargs
; i
++)
972 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
973 /* Move the meta bit to the right place for a string char. */
974 if (XINT (args
[i
]) & CHAR_META
)
975 XSTRING (result
)->data
[i
] |= 0x80;
982 /* Pure storage management. */
984 /* Must get an error if pure storage is full,
985 since if it cannot hold a large string
986 it may be able to hold conses that point to that string;
987 then the string is not protected from gc. */
990 make_pure_string (data
, length
)
994 register Lisp_Object
new;
995 register int size
= sizeof (int) + INTERVAL_PTR_SIZE
+ length
+ 1;
997 if (pureptr
+ size
> PURESIZE
)
998 error ("Pure Lisp storage exhausted");
999 XSET (new, Lisp_String
, PUREBEG
+ pureptr
);
1000 XSTRING (new)->size
= length
;
1001 bcopy (data
, XSTRING (new)->data
, length
);
1002 XSTRING (new)->data
[length
] = 0;
1003 pureptr
+= (size
+ sizeof (int) - 1)
1004 / sizeof (int) * sizeof (int);
1009 pure_cons (car
, cdr
)
1010 Lisp_Object car
, cdr
;
1012 register Lisp_Object
new;
1014 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1015 error ("Pure Lisp storage exhausted");
1016 XSET (new, Lisp_Cons
, PUREBEG
+ pureptr
);
1017 pureptr
+= sizeof (struct Lisp_Cons
);
1018 XCONS (new)->car
= Fpurecopy (car
);
1019 XCONS (new)->cdr
= Fpurecopy (cdr
);
1023 #ifdef LISP_FLOAT_TYPE
1026 make_pure_float (num
)
1029 register Lisp_Object
new;
1031 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1032 (double) boundary. Some architectures (like the sparc) require
1033 this, and I suspect that floats are rare enough that it's no
1034 tragedy for those that do. */
1037 char *p
= PUREBEG
+ pureptr
;
1041 alignment
= __alignof (struct Lisp_Float
);
1043 alignment
= sizeof (struct Lisp_Float
);
1046 alignment
= sizeof (struct Lisp_Float
);
1048 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1049 pureptr
= p
- PUREBEG
;
1052 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1053 error ("Pure Lisp storage exhausted");
1054 XSET (new, Lisp_Float
, PUREBEG
+ pureptr
);
1055 pureptr
+= sizeof (struct Lisp_Float
);
1056 XFLOAT (new)->data
= num
;
1057 XFLOAT (new)->type
= 0; /* bug chasing -wsr */
1061 #endif /* LISP_FLOAT_TYPE */
1064 make_pure_vector (len
)
1067 register Lisp_Object
new;
1068 register int size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1070 if (pureptr
+ size
> PURESIZE
)
1071 error ("Pure Lisp storage exhausted");
1073 XSET (new, Lisp_Vector
, PUREBEG
+ pureptr
);
1075 XVECTOR (new)->size
= len
;
1079 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1080 "Make a copy of OBJECT in pure storage.\n\
1081 Recursively copies contents of vectors and cons cells.\n\
1082 Does not copy symbols.")
1084 register Lisp_Object obj
;
1086 register Lisp_Object
new, tem
;
1089 if (NILP (Vpurify_flag
))
1092 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1093 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1096 #ifdef SWITCH_ENUM_BUG
1097 switch ((int) XTYPE (obj
))
1099 switch (XTYPE (obj
))
1103 error ("Attempt to copy a marker to pure storage");
1106 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1108 #ifdef LISP_FLOAT_TYPE
1110 return make_pure_float (XFLOAT (obj
)->data
);
1111 #endif /* LISP_FLOAT_TYPE */
1114 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1118 new = make_pure_vector (XVECTOR (obj
)->size
);
1119 for (i
= 0; i
< XVECTOR (obj
)->size
; i
++)
1121 tem
= XVECTOR (obj
)->contents
[i
];
1122 XVECTOR (new)->contents
[i
] = Fpurecopy (tem
);
1124 XSETTYPE (new, XTYPE (obj
));
1132 /* Recording what needs to be marked for gc. */
1134 struct gcpro
*gcprolist
;
1136 #define NSTATICS 512
1138 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1142 /* Put an entry in staticvec, pointing at the variable whose address is given */
1145 staticpro (varaddress
)
1146 Lisp_Object
*varaddress
;
1148 staticvec
[staticidx
++] = varaddress
;
1149 if (staticidx
>= NSTATICS
)
1157 struct catchtag
*next
;
1158 /* jmp_buf jmp; /* We don't need this for GC purposes */
1163 struct backtrace
*next
;
1164 Lisp_Object
*function
;
1165 Lisp_Object
*args
; /* Points to vector of args. */
1166 int nargs
; /* length of vector */
1167 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1171 /* Two flags that are set during GC in the `size' component
1172 of a string or vector. On some machines, these flags
1173 are defined by the m- file to be different bits. */
1175 /* On vector, means it has been marked.
1176 On string size field or a reference to a string,
1177 means not the last reference in the chain. */
1179 #ifndef ARRAY_MARK_FLAG
1180 #define ARRAY_MARK_FLAG ((MARKBIT >> 1) & ~MARKBIT)
1181 #endif /* no ARRAY_MARK_FLAG */
1183 /* Any slot that is a Lisp_Object can point to a string
1184 and thus can be put on a string's reference-chain
1185 and thus may need to have its ARRAY_MARK_FLAG set.
1186 This includes the slots whose markbits are used to mark
1187 the containing objects. */
1189 #if ARRAY_MARK_FLAG == MARKBIT
1193 /* Garbage collection! */
1195 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1196 int total_free_conses
, total_free_markers
, total_free_symbols
;
1197 #ifdef LISP_FLOAT_TYPE
1198 int total_free_floats
, total_floats
;
1199 #endif /* LISP_FLOAT_TYPE */
1201 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1202 "Reclaim storage for Lisp objects no longer needed.\n\
1203 Returns info on amount of space in use:\n\
1204 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1205 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1206 (USED-FLOATS . FREE-FLOATS))\n\
1207 Garbage collection happens automatically if you cons more than\n\
1208 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1211 register struct gcpro
*tail
;
1212 register struct specbinding
*bind
;
1213 struct catchtag
*catch;
1214 struct handler
*handler
;
1215 register struct backtrace
*backlist
;
1216 register Lisp_Object tem
;
1217 char *omessage
= echo_area_glyphs
;
1218 char stack_top_variable
;
1221 /* Save a copy of the contents of the stack, for debugging. */
1222 #if MAX_SAVE_STACK > 0
1223 if (NILP (Vpurify_flag
))
1225 i
= &stack_top_variable
- stack_bottom
;
1227 if (i
< MAX_SAVE_STACK
)
1229 if (stack_copy
== 0)
1230 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1231 else if (stack_copy_size
< i
)
1232 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1235 if ((int) (&stack_top_variable
- stack_bottom
) > 0)
1236 bcopy (stack_bottom
, stack_copy
, i
);
1238 bcopy (&stack_top_variable
, stack_copy
, i
);
1242 #endif /* MAX_SAVE_STACK > 0 */
1244 if (!noninteractive
)
1245 message1 ("Garbage collecting...");
1247 /* Don't keep command history around forever */
1248 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1250 XCONS (tem
)->cdr
= Qnil
;
1252 /* Likewise for undo information. */
1254 register struct buffer
*nextb
= all_buffers
;
1258 /* If a buffer's undo list is Qt, that means that undo is
1259 turned off in that buffer. Calling truncate_undo_list on
1260 Qt tends to return NULL, which effectively turns undo back on.
1261 So don't call truncate_undo_list if undo_list is Qt. */
1262 if (! EQ (nextb
->undo_list
, Qt
))
1264 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1266 nextb
= nextb
->next
;
1272 /* clear_marks (); */
1274 /* In each "large string", set the MARKBIT of the size field.
1275 That enables mark_object to recognize them. */
1277 register struct string_block
*b
;
1278 for (b
= large_string_blocks
; b
; b
= b
->next
)
1279 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1282 /* Mark all the special slots that serve as the roots of accessibility.
1284 Usually the special slots to mark are contained in particular structures.
1285 Then we know no slot is marked twice because the structures don't overlap.
1286 In some cases, the structures point to the slots to be marked.
1287 For these, we use MARKBIT to avoid double marking of the slot. */
1289 for (i
= 0; i
< staticidx
; i
++)
1290 mark_object (staticvec
[i
]);
1291 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1292 for (i
= 0; i
< tail
->nvars
; i
++)
1293 if (!XMARKBIT (tail
->var
[i
]))
1295 mark_object (&tail
->var
[i
]);
1296 XMARK (tail
->var
[i
]);
1298 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1300 mark_object (&bind
->symbol
);
1301 mark_object (&bind
->old_value
);
1303 for (catch = catchlist
; catch; catch = catch->next
)
1305 mark_object (&catch->tag
);
1306 mark_object (&catch->val
);
1308 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1310 mark_object (&handler
->handler
);
1311 mark_object (&handler
->var
);
1313 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1315 if (!XMARKBIT (*backlist
->function
))
1317 mark_object (backlist
->function
);
1318 XMARK (*backlist
->function
);
1320 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1323 i
= backlist
->nargs
- 1;
1325 if (!XMARKBIT (backlist
->args
[i
]))
1327 mark_object (&backlist
->args
[i
]);
1328 XMARK (backlist
->args
[i
]);
1334 /* Clear the mark bits that we set in certain root slots. */
1336 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1337 for (i
= 0; i
< tail
->nvars
; i
++)
1338 XUNMARK (tail
->var
[i
]);
1339 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1341 XUNMARK (*backlist
->function
);
1342 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1345 i
= backlist
->nargs
- 1;
1347 XUNMARK (backlist
->args
[i
]);
1349 XUNMARK (buffer_defaults
.name
);
1350 XUNMARK (buffer_local_symbols
.name
);
1352 /* clear_marks (); */
1355 consing_since_gc
= 0;
1356 if (gc_cons_threshold
< 10000)
1357 gc_cons_threshold
= 10000;
1360 message1 (omessage
);
1361 else if (!noninteractive
)
1362 message1 ("Garbage collecting...done");
1364 return Fcons (Fcons (make_number (total_conses
),
1365 make_number (total_free_conses
)),
1366 Fcons (Fcons (make_number (total_symbols
),
1367 make_number (total_free_symbols
)),
1368 Fcons (Fcons (make_number (total_markers
),
1369 make_number (total_free_markers
)),
1370 Fcons (make_number (total_string_size
),
1371 Fcons (make_number (total_vector_size
),
1373 #ifdef LISP_FLOAT_TYPE
1374 Fcons (Fcons (make_number (total_floats
),
1375 make_number (total_free_floats
)),
1377 #else /* not LISP_FLOAT_TYPE */
1379 #endif /* not LISP_FLOAT_TYPE */
1387 /* Clear marks on all conses */
1389 register struct cons_block
*cblk
;
1390 register int lim
= cons_block_index
;
1392 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1395 for (i
= 0; i
< lim
; i
++)
1396 XUNMARK (cblk
->conses
[i
].car
);
1397 lim
= CONS_BLOCK_SIZE
;
1400 /* Clear marks on all symbols */
1402 register struct symbol_block
*sblk
;
1403 register int lim
= symbol_block_index
;
1405 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1408 for (i
= 0; i
< lim
; i
++)
1410 XUNMARK (sblk
->symbols
[i
].plist
);
1412 lim
= SYMBOL_BLOCK_SIZE
;
1415 /* Clear marks on all markers */
1417 register struct marker_block
*sblk
;
1418 register int lim
= marker_block_index
;
1420 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1423 for (i
= 0; i
< lim
; i
++)
1424 XUNMARK (sblk
->markers
[i
].chain
);
1425 lim
= MARKER_BLOCK_SIZE
;
1428 /* Clear mark bits on all buffers */
1430 register struct buffer
*nextb
= all_buffers
;
1434 XUNMARK (nextb
->name
);
1435 nextb
= nextb
->next
;
1441 /* Mark reference to a Lisp_Object.
1442 If the object referred to has not been seen yet, recursively mark
1443 all the references contained in it.
1445 If the object referenced is a short string, the referrencing slot
1446 is threaded into a chain of such slots, pointed to from
1447 the `size' field of the string. The actual string size
1448 lives in the last slot in the chain. We recognize the end
1449 because it is < (unsigned) STRING_BLOCK_SIZE. */
1451 #define LAST_MARKED_SIZE 500
1452 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1453 int last_marked_index
;
1456 mark_object (objptr
)
1457 Lisp_Object
*objptr
;
1459 register Lisp_Object obj
;
1466 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1467 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1470 last_marked
[last_marked_index
++] = objptr
;
1471 if (last_marked_index
== LAST_MARKED_SIZE
)
1472 last_marked_index
= 0;
1474 #ifdef SWITCH_ENUM_BUG
1475 switch ((int) XGCTYPE (obj
))
1477 switch (XGCTYPE (obj
))
1482 register struct Lisp_String
*ptr
= XSTRING (obj
);
1484 MARK_INTERVAL_TREE (ptr
->intervals
);
1485 if (ptr
->size
& MARKBIT
)
1486 /* A large string. Just set ARRAY_MARK_FLAG. */
1487 ptr
->size
|= ARRAY_MARK_FLAG
;
1490 /* A small string. Put this reference
1491 into the chain of references to it.
1492 The address OBJPTR is even, so if the address
1493 includes MARKBIT, put it in the low bit
1494 when we store OBJPTR into the size field. */
1496 if (XMARKBIT (*objptr
))
1498 XFASTINT (*objptr
) = ptr
->size
;
1502 XFASTINT (*objptr
) = ptr
->size
;
1503 if ((int)objptr
& 1) abort ();
1504 ptr
->size
= (int) objptr
& ~MARKBIT
;
1505 if ((int) objptr
& MARKBIT
)
1514 case Lisp_Window_Configuration
:
1516 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1517 register int size
= ptr
->size
;
1518 struct Lisp_Vector
*volatile ptr1
= ptr
;
1521 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1522 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1523 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1527 mark_object (&ptr
->contents
[i
]);
1533 /* We could treat this just like a vector, but it is better
1534 to save the COMPILED_CONSTANTS element for last and avoid recursion
1537 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1538 register int size
= ptr
->size
;
1539 struct Lisp_Vector
*volatile ptr1
= ptr
;
1542 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1543 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1544 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1548 if (i
!= COMPILED_CONSTANTS
)
1549 mark_object (&ptr
->contents
[i
]);
1551 objptr
= &ptr
->contents
[COMPILED_CONSTANTS
];
1559 register struct frame
*ptr
= XFRAME (obj
);
1560 register int size
= ptr
->size
;
1562 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1563 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1565 mark_object (&ptr
->name
);
1566 mark_object (&ptr
->focus_frame
);
1567 mark_object (&ptr
->width
);
1568 mark_object (&ptr
->height
);
1569 mark_object (&ptr
->selected_window
);
1570 mark_object (&ptr
->minibuffer_window
);
1571 mark_object (&ptr
->param_alist
);
1572 mark_object (&ptr
->scroll_bars
);
1573 mark_object (&ptr
->condemned_scroll_bars
);
1574 mark_object (&ptr
->menu_bar_items
);
1575 mark_object (&ptr
->face_alist
);
1578 #endif /* MULTI_FRAME */
1582 register struct Lisp_Symbol
*ptr
= XSYMBOL (obj
);
1583 struct Lisp_Symbol
*ptrx
;
1585 if (XMARKBIT (ptr
->plist
)) break;
1587 mark_object ((Lisp_Object
*) &ptr
->value
);
1588 mark_object (&ptr
->function
);
1589 mark_object (&ptr
->plist
);
1590 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1591 mark_object (&ptr
->name
);
1595 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1596 XSETSYMBOL (obj
, ptrx
);
1603 XMARK (XMARKER (obj
)->chain
);
1604 /* DO NOT mark thru the marker's chain.
1605 The buffer's markers chain does not preserve markers from gc;
1606 instead, markers are removed from the chain when freed by gc. */
1610 case Lisp_Buffer_Local_Value
:
1611 case Lisp_Some_Buffer_Local_Value
:
1613 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1614 if (XMARKBIT (ptr
->car
)) break;
1616 /* If the cdr is nil, avoid recursion for the car. */
1617 if (EQ (ptr
->cdr
, Qnil
))
1624 mark_object (&ptr
->car
);
1630 #ifdef LISP_FLOAT_TYPE
1632 XMARK (XFLOAT (obj
)->type
);
1634 #endif /* LISP_FLOAT_TYPE */
1637 if (!XMARKBIT (XBUFFER (obj
)->name
))
1647 case Lisp_Buffer_Objfwd
:
1648 case Lisp_Internal_Stream
:
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. */
1660 /* Mark the pointers in a buffer structure. */
1666 register struct buffer
*buffer
= XBUFFER (buf
);
1667 register Lisp_Object
*ptr
;
1669 /* This is the buffer's markbit */
1670 mark_object (&buffer
->name
);
1671 XMARK (buffer
->name
);
1673 MARK_INTERVAL_TREE (buffer
->intervals
);
1676 mark_object (buffer
->syntax_table
);
1678 /* Mark the various string-pointers in the buffer object.
1679 Since the strings may be relocated, we must mark them
1680 in their actual slots. So gc_sweep must convert each slot
1681 back to an ordinary C pointer. */
1682 XSET (*(Lisp_Object
*)&buffer
->upcase_table
,
1683 Lisp_String
, buffer
->upcase_table
);
1684 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1685 XSET (*(Lisp_Object
*)&buffer
->downcase_table
,
1686 Lisp_String
, buffer
->downcase_table
);
1687 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1689 XSET (*(Lisp_Object
*)&buffer
->sort_table
,
1690 Lisp_String
, buffer
->sort_table
);
1691 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1692 XSET (*(Lisp_Object
*)&buffer
->folding_sort_table
,
1693 Lisp_String
, buffer
->folding_sort_table
);
1694 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1697 for (ptr
= &buffer
->name
+ 1;
1698 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1703 /* Sweep: find all structures not marked, and free them. */
1708 total_string_size
= 0;
1711 /* Put all unmarked conses on free list */
1713 register struct cons_block
*cblk
;
1714 register int lim
= cons_block_index
;
1715 register int num_free
= 0, num_used
= 0;
1719 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1722 for (i
= 0; i
< lim
; i
++)
1723 if (!XMARKBIT (cblk
->conses
[i
].car
))
1725 XFASTINT (cblk
->conses
[i
].car
) = (int) cons_free_list
;
1727 cons_free_list
= &cblk
->conses
[i
];
1732 XUNMARK (cblk
->conses
[i
].car
);
1734 lim
= CONS_BLOCK_SIZE
;
1736 total_conses
= num_used
;
1737 total_free_conses
= num_free
;
1740 #ifdef LISP_FLOAT_TYPE
1741 /* Put all unmarked floats on free list */
1743 register struct float_block
*fblk
;
1744 register int lim
= float_block_index
;
1745 register int num_free
= 0, num_used
= 0;
1747 float_free_list
= 0;
1749 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1752 for (i
= 0; i
< lim
; i
++)
1753 if (!XMARKBIT (fblk
->floats
[i
].type
))
1755 XFASTINT (fblk
->floats
[i
].type
) = (int) float_free_list
;
1757 float_free_list
= &fblk
->floats
[i
];
1762 XUNMARK (fblk
->floats
[i
].type
);
1764 lim
= FLOAT_BLOCK_SIZE
;
1766 total_floats
= num_used
;
1767 total_free_floats
= num_free
;
1769 #endif /* LISP_FLOAT_TYPE */
1771 #ifdef USE_TEXT_PROPERTIES
1772 /* Put all unmarked intervals on free list */
1774 register struct interval_block
*iblk
;
1775 register int lim
= interval_block_index
;
1776 register int num_free
= 0, num_used
= 0;
1778 interval_free_list
= 0;
1780 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1784 for (i
= 0; i
< lim
; i
++)
1786 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1788 iblk
->intervals
[i
].parent
= interval_free_list
;
1789 interval_free_list
= &iblk
->intervals
[i
];
1795 XUNMARK (iblk
->intervals
[i
].plist
);
1798 lim
= INTERVAL_BLOCK_SIZE
;
1800 total_intervals
= num_used
;
1801 total_free_intervals
= num_free
;
1803 #endif /* USE_TEXT_PROPERTIES */
1805 /* Put all unmarked symbols on free list */
1807 register struct symbol_block
*sblk
;
1808 register int lim
= symbol_block_index
;
1809 register int num_free
= 0, num_used
= 0;
1811 symbol_free_list
= 0;
1813 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1816 for (i
= 0; i
< lim
; i
++)
1817 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
1819 XFASTINT (sblk
->symbols
[i
].value
) = (int) symbol_free_list
;
1820 symbol_free_list
= &sblk
->symbols
[i
];
1826 sblk
->symbols
[i
].name
1827 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
1828 XUNMARK (sblk
->symbols
[i
].plist
);
1830 lim
= SYMBOL_BLOCK_SIZE
;
1832 total_symbols
= num_used
;
1833 total_free_symbols
= num_free
;
1837 /* Put all unmarked markers on free list.
1838 Dechain each one first from the buffer it points into. */
1840 register struct marker_block
*mblk
;
1841 struct Lisp_Marker
*tem1
;
1842 register int lim
= marker_block_index
;
1843 register int num_free
= 0, num_used
= 0;
1845 marker_free_list
= 0;
1847 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
1850 for (i
= 0; i
< lim
; i
++)
1851 if (!XMARKBIT (mblk
->markers
[i
].chain
))
1854 tem1
= &mblk
->markers
[i
]; /* tem1 avoids Sun compiler bug */
1855 XSET (tem
, Lisp_Marker
, tem1
);
1856 unchain_marker (tem
);
1857 XFASTINT (mblk
->markers
[i
].chain
) = (int) marker_free_list
;
1858 marker_free_list
= &mblk
->markers
[i
];
1864 XUNMARK (mblk
->markers
[i
].chain
);
1866 lim
= MARKER_BLOCK_SIZE
;
1869 total_markers
= num_used
;
1870 total_free_markers
= num_free
;
1873 /* Free all unmarked buffers */
1875 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
1878 if (!XMARKBIT (buffer
->name
))
1881 prev
->next
= buffer
->next
;
1883 all_buffers
= buffer
->next
;
1884 next
= buffer
->next
;
1890 XUNMARK (buffer
->name
);
1891 UNMARK_BALANCE_INTERVALS (buffer
->intervals
);
1894 /* Each `struct Lisp_String *' was turned into a Lisp_Object
1895 for purposes of marking and relocation.
1896 Turn them back into C pointers now. */
1897 buffer
->upcase_table
1898 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
1899 buffer
->downcase_table
1900 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
1902 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
1903 buffer
->folding_sort_table
1904 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
1907 prev
= buffer
, buffer
= buffer
->next
;
1911 #endif /* standalone */
1913 /* Free all unmarked vectors */
1915 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
1916 total_vector_size
= 0;
1919 if (!(vector
->size
& ARRAY_MARK_FLAG
))
1922 prev
->next
= vector
->next
;
1924 all_vectors
= vector
->next
;
1925 next
= vector
->next
;
1931 vector
->size
&= ~ARRAY_MARK_FLAG
;
1932 total_vector_size
+= vector
->size
;
1933 prev
= vector
, vector
= vector
->next
;
1937 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
1939 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
1942 if (!(((struct Lisp_String
*)(&sb
->chars
[0]))->size
& ARRAY_MARK_FLAG
))
1945 prev
->next
= sb
->next
;
1947 large_string_blocks
= sb
->next
;
1954 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
1955 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
1956 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
1957 prev
= sb
, sb
= sb
->next
;
1962 /* Compactify strings, relocate references, and free empty string blocks. */
1967 /* String block of old strings we are scanning. */
1968 register struct string_block
*from_sb
;
1969 /* A preceding string block (or maybe the same one)
1970 where we are copying the still-live strings to. */
1971 register struct string_block
*to_sb
;
1975 to_sb
= first_string_block
;
1978 /* Scan each existing string block sequentially, string by string. */
1979 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
1982 /* POS is the index of the next string in the block. */
1983 while (pos
< from_sb
->pos
)
1985 register struct Lisp_String
*nextstr
1986 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
1988 register struct Lisp_String
*newaddr
;
1989 register int size
= nextstr
->size
;
1991 /* NEXTSTR is the old address of the next string.
1992 Just skip it if it isn't marked. */
1993 if ((unsigned) size
> STRING_BLOCK_SIZE
)
1995 /* It is marked, so its size field is really a chain of refs.
1996 Find the end of the chain, where the actual size lives. */
1997 while ((unsigned) size
> STRING_BLOCK_SIZE
)
1999 if (size
& 1) size
^= MARKBIT
| 1;
2000 size
= *(int *)size
& ~MARKBIT
;
2003 total_string_size
+= size
;
2005 /* If it won't fit in TO_SB, close it out,
2006 and move to the next sb. Keep doing so until
2007 TO_SB reaches a large enough, empty enough string block.
2008 We know that TO_SB cannot advance past FROM_SB here
2009 since FROM_SB is large enough to contain this string.
2010 Any string blocks skipped here
2011 will be patched out and freed later. */
2012 while (to_pos
+ STRING_FULLSIZE (size
)
2013 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2015 to_sb
->pos
= to_pos
;
2016 to_sb
= to_sb
->next
;
2019 /* Compute new address of this string
2020 and update TO_POS for the space being used. */
2021 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2022 to_pos
+= STRING_FULLSIZE (size
);
2024 /* Copy the string itself to the new place. */
2025 if (nextstr
!= newaddr
)
2026 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (int)
2027 + INTERVAL_PTR_SIZE
);
2029 /* Go through NEXTSTR's chain of references
2030 and make each slot in the chain point to
2031 the new address of this string. */
2032 size
= newaddr
->size
;
2033 while ((unsigned) size
> STRING_BLOCK_SIZE
)
2035 register Lisp_Object
*objptr
;
2036 if (size
& 1) size
^= MARKBIT
| 1;
2037 objptr
= (Lisp_Object
*)size
;
2039 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2040 if (XMARKBIT (*objptr
))
2042 XSET (*objptr
, Lisp_String
, newaddr
);
2046 XSET (*objptr
, Lisp_String
, newaddr
);
2048 /* Store the actual size in the size field. */
2049 newaddr
->size
= size
;
2051 pos
+= STRING_FULLSIZE (size
);
2055 /* Close out the last string block still used and free any that follow. */
2056 to_sb
->pos
= to_pos
;
2057 current_string_block
= to_sb
;
2059 from_sb
= to_sb
->next
;
2063 to_sb
= from_sb
->next
;
2068 /* Free any empty string blocks further back in the chain.
2069 This loop will never free first_string_block, but it is very
2070 unlikely that that one will become empty, so why bother checking? */
2072 from_sb
= first_string_block
;
2073 while (to_sb
= from_sb
->next
)
2075 if (to_sb
->pos
== 0)
2077 if (from_sb
->next
= to_sb
->next
)
2078 from_sb
->next
->prev
= from_sb
;
2086 /* Debugging aids. */
2088 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, "",
2089 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2090 This may be helpful in debugging Emacs's memory usage.\n\
2091 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2096 XSET (end
, Lisp_Int
, (int) sbrk (0) / 1024);
2102 /* Initialization */
2106 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2109 pure_size
= PURESIZE
;
2112 ignore_warnings
= 1;
2117 #ifdef LISP_FLOAT_TYPE
2119 #endif /* LISP_FLOAT_TYPE */
2122 ignore_warnings
= 0;
2125 consing_since_gc
= 0;
2126 gc_cons_threshold
= 100000;
2127 #ifdef VIRT_ADDR_VARIES
2128 malloc_sbrk_unused
= 1<<22; /* A large number */
2129 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2130 #endif /* VIRT_ADDR_VARIES */
2141 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2142 "*Number of bytes of consing between garbage collections.\n\
2143 Garbage collection can happen automatically once this many bytes have been\n\
2144 allocated since the last garbage collection. All data types count.\n\n\
2145 Garbage collection happens automatically only when `eval' is called.\n\n\
2146 By binding this temporarily to a large number, you can effectively\n\
2147 prevent garbage collection during a part of the program.");
2149 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2150 "Number of bytes of sharable Lisp data allocated so far.");
2153 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2154 "Number of bytes of unshared memory allocated in this session.");
2156 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2157 "Number of bytes of unshared memory remaining available in this session.");
2160 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2161 "Non-nil means loading Lisp code in order to dump an executable.\n\
2162 This means that certain objects should be allocated in shared (pure) space.");
2164 DEFVAR_INT ("undo-limit", &undo_limit
,
2165 "Keep no more undo information once it exceeds this size.\n\
2166 This limit is applied when garbage collection happens.\n\
2167 The size is counted as the number of bytes occupied,\n\
2168 which includes both saved text and other data.");
2171 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2172 "Don't keep more than this much size of undo information.\n\
2173 A command which pushes past this size is itself forgotten.\n\
2174 This limit is applied when garbage collection happens.\n\
2175 The size is counted as the number of bytes occupied,\n\
2176 which includes both saved text and other data.");
2177 undo_strong_limit
= 30000;
2182 defsubr (&Smake_byte_code
);
2183 defsubr (&Smake_list
);
2184 defsubr (&Smake_vector
);
2185 defsubr (&Smake_string
);
2186 defsubr (&Smake_symbol
);
2187 defsubr (&Smake_marker
);
2188 defsubr (&Spurecopy
);
2189 defsubr (&Sgarbage_collect
);
2190 defsubr (&Smemory_limit
);