1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 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 /* The following come from gmalloc.c. */
37 #if defined (__STDC__) && __STDC__
39 #define __malloc_size_t size_t
41 #define __malloc_size_t unsigned int
43 extern __malloc_size_t _bytes_used
;
44 extern int __malloc_extra_blocks
;
46 #define max(A,B) ((A) > (B) ? (A) : (B))
48 /* Macro to verify that storage intended for Lisp objects is not
49 out of range to fit in the space for a pointer.
50 ADDRESS is the start of the block, and SIZE
51 is the amount of space within which objects can start. */
52 #define VALIDATE_LISP_STORAGE(address, size) \
56 XSETCONS (val, (char *) address + size); \
57 if ((char *) XCONS (val) != (char *) address + size) \
64 /* Value of _bytes_used, when spare_memory was freed. */
65 static __malloc_size_t bytes_used_when_full
;
67 /* Number of bytes of consing done since the last gc */
70 /* Number of bytes of consing since gc before another gc should be done. */
71 int gc_cons_threshold
;
73 /* Nonzero during gc */
76 #ifndef VIRT_ADDR_VARIES
78 #endif /* VIRT_ADDR_VARIES */
81 #ifndef VIRT_ADDR_VARIES
83 #endif /* VIRT_ADDR_VARIES */
84 int malloc_sbrk_unused
;
86 /* Two limits controlling how much undo information to keep. */
88 int undo_strong_limit
;
90 /* Points to memory space allocated as "spare",
91 to be freed if we run out of memory. */
92 static char *spare_memory
;
94 /* Amount of spare memory to keep in reserve. */
95 #define SPARE_MEMORY (1 << 14)
97 /* Number of extra blocks malloc should get when it needs more core. */
98 static int malloc_hysteresis
;
100 /* Non-nil means defun should do purecopy on the function definition */
101 Lisp_Object Vpurify_flag
;
104 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
105 #define PUREBEG (char *) pure
107 #define pure PURE_SEG_BITS /* Use shared memory segment */
108 #define PUREBEG (char *)PURE_SEG_BITS
110 /* This variable is used only by the XPNTR macro when HAVE_SHM is
111 defined. If we used the PURESIZE macro directly there, that would
112 make most of emacs dependent on puresize.h, which we don't want -
113 you should be able to change that without too much recompilation.
114 So map_in_data initializes pure_size, and the dependencies work
117 #endif /* not HAVE_SHM */
119 /* Index in pure at which next pure object will be allocated. */
122 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
123 char *pending_malloc_warning
;
125 /* Pre-computed signal argument for use when memory is exhausted. */
126 Lisp_Object memory_signal_data
;
128 /* Maximum amount of C stack to save when a GC happens. */
130 #ifndef MAX_SAVE_STACK
131 #define MAX_SAVE_STACK 16000
134 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
135 pointer to a Lisp_Object, when that pointer is viewed as an integer.
136 (On most machines, pointers are even, so we can use the low bit.
137 Word-addressible architectures may need to override this in the m-file.)
138 When linking references to small strings through the size field, we
139 use this slot to hold the bit that would otherwise be interpreted as
141 #ifndef DONT_COPY_FLAG
142 #define DONT_COPY_FLAG 1
143 #endif /* no DONT_COPY_FLAG */
145 #if DONT_COPY_FLAG == MARKBIT
149 /* Buffer in which we save a copy of the C stack at each GC. */
154 /* Non-zero means ignore malloc warnings. Set during initialization. */
157 static void mark_object (), mark_buffer (), mark_perdisplays ();
158 static void clear_marks (), gc_sweep ();
159 static void compact_strings ();
161 /* Versions of malloc and realloc that print warnings as memory gets full. */
164 malloc_warning_1 (str
)
167 Fprinc (str
, Vstandard_output
);
168 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
169 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
170 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
174 /* malloc calls this if it finds we are near exhausting storage */
178 pending_malloc_warning
= str
;
181 display_malloc_warning ()
183 register Lisp_Object val
;
185 val
= build_string (pending_malloc_warning
);
186 pending_malloc_warning
= 0;
187 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
190 /* Called if malloc returns zero */
194 #ifndef SYSTEM_MALLOC
195 bytes_used_when_full
= _bytes_used
;
198 /* The first time we get here, free the spare memory. */
205 /* This used to call error, but if we've run out of memory, we could get
206 infinite recursion trying to build the string. */
208 Fsignal (Qerror
, memory_signal_data
);
211 /* Called if we can't allocate relocatable space for a buffer. */
214 buffer_memory_full ()
216 /* If buffers use the relocating allocator,
217 no need to free spare_memory, because we may have plenty of malloc
218 space left that we could get, and if we don't, the malloc that fails
219 will itself cause spare_memory to be freed.
220 If buffers don't use the relocating allocator,
221 treat this like any other failing malloc. */
227 /* This used to call error, but if we've run out of memory, we could get
228 infinite recursion trying to build the string. */
230 Fsignal (Qerror
, memory_signal_data
);
233 /* like malloc routines but check for no memory and block interrupt input. */
242 val
= (long *) malloc (size
);
245 if (!val
&& size
) memory_full ();
250 xrealloc (block
, size
)
257 /* We must call malloc explicitly when BLOCK is 0, since some
258 reallocs don't do this. */
260 val
= (long *) malloc (size
);
262 val
= (long *) realloc (block
, size
);
265 if (!val
&& size
) memory_full ();
279 /* Arranging to disable input signals while we're in malloc.
281 This only works with GNU malloc. To help out systems which can't
282 use GNU malloc, all the calls to malloc, realloc, and free
283 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
284 pairs; unfortunately, we have no idea what C library functions
285 might call malloc, so we can't really protect them unless you're
286 using GNU malloc. Fortunately, most of the major operating can use
289 #ifndef SYSTEM_MALLOC
290 extern void * (*__malloc_hook
) ();
291 static void * (*old_malloc_hook
) ();
292 extern void * (*__realloc_hook
) ();
293 static void * (*old_realloc_hook
) ();
294 extern void (*__free_hook
) ();
295 static void (*old_free_hook
) ();
297 /* This function is used as the hook for free to call. */
300 emacs_blocked_free (ptr
)
304 __free_hook
= old_free_hook
;
306 /* If we released our reserve (due to running out of memory),
307 and we have a fair amount free once again,
308 try to set aside another reserve in case we run out once more. */
309 if (spare_memory
== 0
310 /* Verify there is enough space that even with the malloc
311 hysteresis this call won't run out again.
312 The code here is correct as long as SPARE_MEMORY
313 is substantially larger than the block size malloc uses. */
314 && (bytes_used_when_full
315 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
316 spare_memory
= (char *) malloc (SPARE_MEMORY
);
318 __free_hook
= emacs_blocked_free
;
322 /* If we released our reserve (due to running out of memory),
323 and we have a fair amount free once again,
324 try to set aside another reserve in case we run out once more.
326 This is called when a relocatable block is freed in ralloc.c. */
329 refill_memory_reserve ()
331 if (spare_memory
== 0)
332 spare_memory
= (char *) malloc (SPARE_MEMORY
);
335 /* This function is the malloc hook that Emacs uses. */
338 emacs_blocked_malloc (size
)
344 __malloc_hook
= old_malloc_hook
;
345 __malloc_extra_blocks
= malloc_hysteresis
;
346 value
= (void *) malloc (size
);
347 __malloc_hook
= emacs_blocked_malloc
;
354 emacs_blocked_realloc (ptr
, size
)
361 __realloc_hook
= old_realloc_hook
;
362 value
= (void *) realloc (ptr
, size
);
363 __realloc_hook
= emacs_blocked_realloc
;
370 uninterrupt_malloc ()
372 old_free_hook
= __free_hook
;
373 __free_hook
= emacs_blocked_free
;
375 old_malloc_hook
= __malloc_hook
;
376 __malloc_hook
= emacs_blocked_malloc
;
378 old_realloc_hook
= __realloc_hook
;
379 __realloc_hook
= emacs_blocked_realloc
;
383 /* Interval allocation. */
385 #ifdef USE_TEXT_PROPERTIES
386 #define INTERVAL_BLOCK_SIZE \
387 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
389 struct interval_block
391 struct interval_block
*next
;
392 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
395 struct interval_block
*interval_block
;
396 static int interval_block_index
;
398 INTERVAL interval_free_list
;
404 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
405 interval_block
->next
= 0;
406 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
407 interval_block_index
= 0;
408 interval_free_list
= 0;
411 #define INIT_INTERVALS init_intervals ()
418 if (interval_free_list
)
420 val
= interval_free_list
;
421 interval_free_list
= interval_free_list
->parent
;
425 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
427 register struct interval_block
*newi
428 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
430 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
431 newi
->next
= interval_block
;
432 interval_block
= newi
;
433 interval_block_index
= 0;
435 val
= &interval_block
->intervals
[interval_block_index
++];
437 consing_since_gc
+= sizeof (struct interval
);
438 RESET_INTERVAL (val
);
442 static int total_free_intervals
, total_intervals
;
444 /* Mark the pointers of one interval. */
447 mark_interval (i
, dummy
)
451 if (XMARKBIT (i
->plist
))
453 mark_object (&i
->plist
);
458 mark_interval_tree (tree
)
459 register INTERVAL tree
;
461 /* No need to test if this tree has been marked already; this
462 function is always called through the MARK_INTERVAL_TREE macro,
463 which takes care of that. */
465 /* XMARK expands to an assignment; the LHS of an assignment can't be
467 XMARK (* (Lisp_Object
*) &tree
->parent
);
469 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
472 #define MARK_INTERVAL_TREE(i) \
474 if (!NULL_INTERVAL_P (i) \
475 && ! XMARKBIT ((Lisp_Object) i->parent)) \
476 mark_interval_tree (i); \
479 /* The oddity in the call to XUNMARK is necessary because XUNMARK
480 expands to an assignment to its argument, and most C compilers don't
481 support casts on the left operand of `='. */
482 #define UNMARK_BALANCE_INTERVALS(i) \
484 if (! NULL_INTERVAL_P (i)) \
486 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
487 (i) = balance_intervals (i); \
491 #else /* no interval use */
493 #define INIT_INTERVALS
495 #define UNMARK_BALANCE_INTERVALS(i)
496 #define MARK_INTERVAL_TREE(i)
498 #endif /* no interval use */
500 /* Floating point allocation. */
502 #ifdef LISP_FLOAT_TYPE
503 /* Allocation of float cells, just like conses */
504 /* We store float cells inside of float_blocks, allocating a new
505 float_block with malloc whenever necessary. Float cells reclaimed by
506 GC are put on a free list to be reallocated before allocating
507 any new float cells from the latest float_block.
509 Each float_block is just under 1020 bytes long,
510 since malloc really allocates in units of powers of two
511 and uses 4 bytes for its own overhead. */
513 #define FLOAT_BLOCK_SIZE \
514 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
518 struct float_block
*next
;
519 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
522 struct float_block
*float_block
;
523 int float_block_index
;
525 struct Lisp_Float
*float_free_list
;
530 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
531 float_block
->next
= 0;
532 bzero (float_block
->floats
, sizeof float_block
->floats
);
533 float_block_index
= 0;
537 /* Explicitly free a float cell. */
539 struct Lisp_Float
*ptr
;
541 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
542 float_free_list
= ptr
;
546 make_float (float_value
)
549 register Lisp_Object val
;
553 XSETFLOAT (val
, float_free_list
);
554 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
558 if (float_block_index
== FLOAT_BLOCK_SIZE
)
560 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
561 VALIDATE_LISP_STORAGE (new, sizeof *new);
562 new->next
= float_block
;
564 float_block_index
= 0;
566 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
568 XFLOAT (val
)->data
= float_value
;
569 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
570 consing_since_gc
+= sizeof (struct Lisp_Float
);
574 #endif /* LISP_FLOAT_TYPE */
576 /* Allocation of cons cells */
577 /* We store cons cells inside of cons_blocks, allocating a new
578 cons_block with malloc whenever necessary. Cons cells reclaimed by
579 GC are put on a free list to be reallocated before allocating
580 any new cons cells from the latest cons_block.
582 Each cons_block is just under 1020 bytes long,
583 since malloc really allocates in units of powers of two
584 and uses 4 bytes for its own overhead. */
586 #define CONS_BLOCK_SIZE \
587 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
591 struct cons_block
*next
;
592 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
595 struct cons_block
*cons_block
;
596 int cons_block_index
;
598 struct Lisp_Cons
*cons_free_list
;
603 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
604 cons_block
->next
= 0;
605 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
606 cons_block_index
= 0;
610 /* Explicitly free a cons cell. */
612 struct Lisp_Cons
*ptr
;
614 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
615 cons_free_list
= ptr
;
618 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
619 "Create a new cons, give it CAR and CDR as components, and return it.")
621 Lisp_Object car
, cdr
;
623 register Lisp_Object val
;
627 XSETCONS (val
, cons_free_list
);
628 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
632 if (cons_block_index
== CONS_BLOCK_SIZE
)
634 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
635 VALIDATE_LISP_STORAGE (new, sizeof *new);
636 new->next
= cons_block
;
638 cons_block_index
= 0;
640 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
642 XCONS (val
)->car
= car
;
643 XCONS (val
)->cdr
= cdr
;
644 consing_since_gc
+= sizeof (struct Lisp_Cons
);
648 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
649 "Return a newly created list with specified arguments as elements.\n\
650 Any number of arguments, even zero arguments, are allowed.")
653 register Lisp_Object
*args
;
655 register Lisp_Object len
, val
, val_tail
;
657 XSETFASTINT (len
, nargs
);
658 val
= Fmake_list (len
, Qnil
);
660 while (!NILP (val_tail
))
662 XCONS (val_tail
)->car
= *args
++;
663 val_tail
= XCONS (val_tail
)->cdr
;
668 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
669 "Return a newly created list of length LENGTH, with each element being INIT.")
671 register Lisp_Object length
, init
;
673 register Lisp_Object val
;
676 CHECK_NATNUM (length
, 0);
677 size
= XFASTINT (length
);
681 val
= Fcons (init
, val
);
685 /* Allocation of vectors */
687 struct Lisp_Vector
*all_vectors
;
690 allocate_vectorlike (len
)
693 struct Lisp_Vector
*p
;
695 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
696 + (len
- 1) * sizeof (Lisp_Object
));
697 VALIDATE_LISP_STORAGE (p
, 0);
698 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
699 + (len
- 1) * sizeof (Lisp_Object
));
701 p
->next
= all_vectors
;
706 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
707 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
708 See also the function `vector'.")
710 register Lisp_Object length
, init
;
713 register EMACS_INT sizei
;
715 register struct Lisp_Vector
*p
;
717 CHECK_NATNUM (length
, 0);
718 sizei
= XFASTINT (length
);
720 p
= allocate_vectorlike (sizei
);
722 for (index
= 0; index
< sizei
; index
++)
723 p
->contents
[index
] = init
;
725 XSETVECTOR (vector
, p
);
729 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
730 "Return a newly created vector with specified arguments as elements.\n\
731 Any number of arguments, even zero arguments, are allowed.")
736 register Lisp_Object len
, val
;
738 register struct Lisp_Vector
*p
;
740 XSETFASTINT (len
, nargs
);
741 val
= Fmake_vector (len
, Qnil
);
743 for (index
= 0; index
< nargs
; index
++)
744 p
->contents
[index
] = args
[index
];
748 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
749 "Create a byte-code object with specified arguments as elements.\n\
750 The arguments should be the arglist, bytecode-string, constant vector,\n\
751 stack size, (optional) doc string, and (optional) interactive spec.\n\
752 The first four arguments are required; at most six have any\n\
758 register Lisp_Object len
, val
;
760 register struct Lisp_Vector
*p
;
762 XSETFASTINT (len
, nargs
);
763 if (!NILP (Vpurify_flag
))
764 val
= make_pure_vector (len
);
766 val
= Fmake_vector (len
, Qnil
);
768 for (index
= 0; index
< nargs
; index
++)
770 if (!NILP (Vpurify_flag
))
771 args
[index
] = Fpurecopy (args
[index
]);
772 p
->contents
[index
] = args
[index
];
774 XSETCOMPILED (val
, val
);
778 /* Allocation of symbols.
779 Just like allocation of conses!
781 Each symbol_block is just under 1020 bytes long,
782 since malloc really allocates in units of powers of two
783 and uses 4 bytes for its own overhead. */
785 #define SYMBOL_BLOCK_SIZE \
786 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
790 struct symbol_block
*next
;
791 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
794 struct symbol_block
*symbol_block
;
795 int symbol_block_index
;
797 struct Lisp_Symbol
*symbol_free_list
;
802 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
803 symbol_block
->next
= 0;
804 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
805 symbol_block_index
= 0;
806 symbol_free_list
= 0;
809 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
810 "Return a newly allocated uninterned symbol whose name is NAME.\n\
811 Its value and function definition are void, and its property list is nil.")
815 register Lisp_Object val
;
816 register struct Lisp_Symbol
*p
;
818 CHECK_STRING (str
, 0);
820 if (symbol_free_list
)
822 XSETSYMBOL (val
, symbol_free_list
);
823 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
827 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
829 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
830 VALIDATE_LISP_STORAGE (new, sizeof *new);
831 new->next
= symbol_block
;
833 symbol_block_index
= 0;
835 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
838 p
->name
= XSTRING (str
);
841 p
->function
= Qunbound
;
843 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
847 /* Allocation of markers and other objects that share that structure.
848 Works like allocation of conses. */
850 #define MARKER_BLOCK_SIZE \
851 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
855 struct marker_block
*next
;
856 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
859 struct marker_block
*marker_block
;
860 int marker_block_index
;
862 union Lisp_Misc
*marker_free_list
;
867 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
868 marker_block
->next
= 0;
869 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
870 marker_block_index
= 0;
871 marker_free_list
= 0;
874 /* Return a newly allocated Lisp_Misc object, with no substructure. */
880 if (marker_free_list
)
882 XSETMISC (val
, marker_free_list
);
883 marker_free_list
= marker_free_list
->u_free
.chain
;
887 if (marker_block_index
== MARKER_BLOCK_SIZE
)
889 struct marker_block
*new
890 = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
891 VALIDATE_LISP_STORAGE (new, sizeof *new);
892 new->next
= marker_block
;
894 marker_block_index
= 0;
896 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
898 consing_since_gc
+= sizeof (union Lisp_Misc
);
902 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
903 "Return a newly allocated marker which does not point at any place.")
906 register Lisp_Object val
;
907 register struct Lisp_Marker
*p
;
909 val
= allocate_misc ();
910 XMISC (val
)->type
= Lisp_Misc_Marker
;
918 /* Allocation of strings */
920 /* Strings reside inside of string_blocks. The entire data of the string,
921 both the size and the contents, live in part of the `chars' component of a string_block.
922 The `pos' component is the index within `chars' of the first free byte.
924 first_string_block points to the first string_block ever allocated.
925 Each block points to the next one with its `next' field.
926 The `prev' fields chain in reverse order.
927 The last one allocated is the one currently being filled.
928 current_string_block points to it.
930 The string_blocks that hold individual large strings
931 go in a separate chain, started by large_string_blocks. */
934 /* String blocks contain this many useful bytes.
935 8188 is power of 2, minus 4 for malloc overhead. */
936 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
938 /* A string bigger than this gets its own specially-made string block
939 if it doesn't fit in the current one. */
940 #define STRING_BLOCK_OUTSIZE 1024
942 struct string_block_head
944 struct string_block
*next
, *prev
;
950 struct string_block
*next
, *prev
;
952 char chars
[STRING_BLOCK_SIZE
];
955 /* This points to the string block we are now allocating strings. */
957 struct string_block
*current_string_block
;
959 /* This points to the oldest string block, the one that starts the chain. */
961 struct string_block
*first_string_block
;
963 /* Last string block in chain of those made for individual large strings. */
965 struct string_block
*large_string_blocks
;
967 /* If SIZE is the length of a string, this returns how many bytes
968 the string occupies in a string_block (including padding). */
970 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
972 #define PAD (sizeof (EMACS_INT))
975 #define STRING_FULLSIZE(SIZE) \
976 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
982 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
983 first_string_block
= current_string_block
;
984 consing_since_gc
+= sizeof (struct string_block
);
985 current_string_block
->next
= 0;
986 current_string_block
->prev
= 0;
987 current_string_block
->pos
= 0;
988 large_string_blocks
= 0;
991 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
992 "Return a newly created string of length LENGTH, with each element being INIT.\n\
993 Both LENGTH and INIT must be numbers.")
995 Lisp_Object length
, init
;
997 register Lisp_Object val
;
998 register unsigned char *p
, *end
, c
;
1000 CHECK_NATNUM (length
, 0);
1001 CHECK_NUMBER (init
, 1);
1002 val
= make_uninit_string (XFASTINT (length
));
1004 p
= XSTRING (val
)->data
;
1005 end
= p
+ XSTRING (val
)->size
;
1013 make_string (contents
, length
)
1017 register Lisp_Object val
;
1018 val
= make_uninit_string (length
);
1019 bcopy (contents
, XSTRING (val
)->data
, length
);
1027 return make_string (str
, strlen (str
));
1031 make_uninit_string (length
)
1034 register Lisp_Object val
;
1035 register int fullsize
= STRING_FULLSIZE (length
);
1037 if (length
< 0) abort ();
1039 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1040 /* This string can fit in the current string block */
1043 ((struct Lisp_String
*)
1044 (current_string_block
->chars
+ current_string_block
->pos
)));
1045 current_string_block
->pos
+= fullsize
;
1047 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1048 /* This string gets its own string block */
1050 register struct string_block
*new
1051 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1052 VALIDATE_LISP_STORAGE (new, 0);
1053 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1054 new->pos
= fullsize
;
1055 new->next
= large_string_blocks
;
1056 large_string_blocks
= new;
1058 ((struct Lisp_String
*)
1059 ((struct string_block_head
*)new + 1)));
1062 /* Make a new current string block and start it off with this string */
1064 register struct string_block
*new
1065 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1066 VALIDATE_LISP_STORAGE (new, sizeof *new);
1067 consing_since_gc
+= sizeof (struct string_block
);
1068 current_string_block
->next
= new;
1069 new->prev
= current_string_block
;
1071 current_string_block
= new;
1072 new->pos
= fullsize
;
1074 (struct Lisp_String
*) current_string_block
->chars
);
1077 XSTRING (val
)->size
= length
;
1078 XSTRING (val
)->data
[length
] = 0;
1079 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1084 /* Return a newly created vector or string with specified arguments as
1085 elements. If all the arguments are characters that can fit
1086 in a string of events, make a string; otherwise, make a vector.
1088 Any number of arguments, even zero arguments, are allowed. */
1091 make_event_array (nargs
, args
)
1097 for (i
= 0; i
< nargs
; i
++)
1098 /* The things that fit in a string
1099 are characters that are in 0...127,
1100 after discarding the meta bit and all the bits above it. */
1101 if (!INTEGERP (args
[i
])
1102 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1103 return Fvector (nargs
, args
);
1105 /* Since the loop exited, we know that all the things in it are
1106 characters, so we can make a string. */
1110 result
= Fmake_string (nargs
, make_number (0));
1111 for (i
= 0; i
< nargs
; i
++)
1113 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1114 /* Move the meta bit to the right place for a string char. */
1115 if (XINT (args
[i
]) & CHAR_META
)
1116 XSTRING (result
)->data
[i
] |= 0x80;
1123 /* Pure storage management. */
1125 /* Must get an error if pure storage is full,
1126 since if it cannot hold a large string
1127 it may be able to hold conses that point to that string;
1128 then the string is not protected from gc. */
1131 make_pure_string (data
, length
)
1135 register Lisp_Object
new;
1136 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1138 if (pureptr
+ size
> PURESIZE
)
1139 error ("Pure Lisp storage exhausted");
1140 XSETSTRING (new, PUREBEG
+ pureptr
);
1141 XSTRING (new)->size
= length
;
1142 bcopy (data
, XSTRING (new)->data
, length
);
1143 XSTRING (new)->data
[length
] = 0;
1145 /* We must give strings in pure storage some kind of interval. So we
1146 give them a null one. */
1147 #if defined (USE_TEXT_PROPERTIES)
1148 XSTRING (new)->intervals
= NULL_INTERVAL
;
1150 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1151 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1156 pure_cons (car
, cdr
)
1157 Lisp_Object car
, cdr
;
1159 register Lisp_Object
new;
1161 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1162 error ("Pure Lisp storage exhausted");
1163 XSETCONS (new, PUREBEG
+ pureptr
);
1164 pureptr
+= sizeof (struct Lisp_Cons
);
1165 XCONS (new)->car
= Fpurecopy (car
);
1166 XCONS (new)->cdr
= Fpurecopy (cdr
);
1170 #ifdef LISP_FLOAT_TYPE
1173 make_pure_float (num
)
1176 register Lisp_Object
new;
1178 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1179 (double) boundary. Some architectures (like the sparc) require
1180 this, and I suspect that floats are rare enough that it's no
1181 tragedy for those that do. */
1184 char *p
= PUREBEG
+ pureptr
;
1188 alignment
= __alignof (struct Lisp_Float
);
1190 alignment
= sizeof (struct Lisp_Float
);
1193 alignment
= sizeof (struct Lisp_Float
);
1195 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1196 pureptr
= p
- PUREBEG
;
1199 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1200 error ("Pure Lisp storage exhausted");
1201 XSETFLOAT (new, PUREBEG
+ pureptr
);
1202 pureptr
+= sizeof (struct Lisp_Float
);
1203 XFLOAT (new)->data
= num
;
1204 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1208 #endif /* LISP_FLOAT_TYPE */
1211 make_pure_vector (len
)
1214 register Lisp_Object
new;
1215 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1217 if (pureptr
+ size
> PURESIZE
)
1218 error ("Pure Lisp storage exhausted");
1220 XSETVECTOR (new, PUREBEG
+ pureptr
);
1222 XVECTOR (new)->size
= len
;
1226 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1227 "Make a copy of OBJECT in pure storage.\n\
1228 Recursively copies contents of vectors and cons cells.\n\
1229 Does not copy symbols.")
1231 register Lisp_Object obj
;
1233 if (NILP (Vpurify_flag
))
1236 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1237 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1241 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1242 #ifdef LISP_FLOAT_TYPE
1243 else if (FLOATP (obj
))
1244 return make_pure_float (XFLOAT (obj
)->data
);
1245 #endif /* LISP_FLOAT_TYPE */
1246 else if (STRINGP (obj
))
1247 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1248 else if (COMPILEDP (obj
) || VECTORP (obj
))
1250 register struct Lisp_Vector
*vec
;
1251 register int i
, size
;
1253 size
= XVECTOR (obj
)->size
;
1254 if (size
& PSEUDOVECTOR_FLAG
)
1255 size
&= PSEUDOVECTOR_SIZE_MASK
;
1256 vec
= XVECTOR (make_pure_vector (size
));
1257 for (i
= 0; i
< size
; i
++)
1258 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1259 if (COMPILEDP (obj
))
1260 XSETCOMPILED (obj
, vec
);
1262 XSETVECTOR (obj
, vec
);
1265 else if (MARKERP (obj
))
1266 error ("Attempt to copy a marker to pure storage");
1271 /* Recording what needs to be marked for gc. */
1273 struct gcpro
*gcprolist
;
1275 #define NSTATICS 512
1277 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1281 /* Put an entry in staticvec, pointing at the variable whose address is given */
1284 staticpro (varaddress
)
1285 Lisp_Object
*varaddress
;
1287 staticvec
[staticidx
++] = varaddress
;
1288 if (staticidx
>= NSTATICS
)
1296 struct catchtag
*next
;
1297 /* jmp_buf jmp; /* We don't need this for GC purposes */
1302 struct backtrace
*next
;
1303 Lisp_Object
*function
;
1304 Lisp_Object
*args
; /* Points to vector of args. */
1305 int nargs
; /* length of vector */
1306 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1310 /* Garbage collection! */
1312 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1313 int total_free_conses
, total_free_markers
, total_free_symbols
;
1314 #ifdef LISP_FLOAT_TYPE
1315 int total_free_floats
, total_floats
;
1316 #endif /* LISP_FLOAT_TYPE */
1318 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1319 "Reclaim storage for Lisp objects no longer needed.\n\
1320 Returns info on amount of space in use:\n\
1321 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1322 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1323 (USED-FLOATS . FREE-FLOATS))\n\
1324 Garbage collection happens automatically if you cons more than\n\
1325 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1328 register struct gcpro
*tail
;
1329 register struct specbinding
*bind
;
1330 struct catchtag
*catch;
1331 struct handler
*handler
;
1332 register struct backtrace
*backlist
;
1333 register Lisp_Object tem
;
1334 char *omessage
= echo_area_glyphs
;
1335 int omessage_length
= echo_area_glyphs_length
;
1336 char stack_top_variable
;
1339 /* Save a copy of the contents of the stack, for debugging. */
1340 #if MAX_SAVE_STACK > 0
1341 if (NILP (Vpurify_flag
))
1343 i
= &stack_top_variable
- stack_bottom
;
1345 if (i
< MAX_SAVE_STACK
)
1347 if (stack_copy
== 0)
1348 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1349 else if (stack_copy_size
< i
)
1350 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1353 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1354 bcopy (stack_bottom
, stack_copy
, i
);
1356 bcopy (&stack_top_variable
, stack_copy
, i
);
1360 #endif /* MAX_SAVE_STACK > 0 */
1362 if (!noninteractive
)
1363 message1_nolog ("Garbage collecting...");
1365 /* Don't keep command history around forever */
1366 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1368 XCONS (tem
)->cdr
= Qnil
;
1370 /* Likewise for undo information. */
1372 register struct buffer
*nextb
= all_buffers
;
1376 /* If a buffer's undo list is Qt, that means that undo is
1377 turned off in that buffer. Calling truncate_undo_list on
1378 Qt tends to return NULL, which effectively turns undo back on.
1379 So don't call truncate_undo_list if undo_list is Qt. */
1380 if (! EQ (nextb
->undo_list
, Qt
))
1382 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1384 nextb
= nextb
->next
;
1390 /* clear_marks (); */
1392 /* In each "large string", set the MARKBIT of the size field.
1393 That enables mark_object to recognize them. */
1395 register struct string_block
*b
;
1396 for (b
= large_string_blocks
; b
; b
= b
->next
)
1397 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1400 /* Mark all the special slots that serve as the roots of accessibility.
1402 Usually the special slots to mark are contained in particular structures.
1403 Then we know no slot is marked twice because the structures don't overlap.
1404 In some cases, the structures point to the slots to be marked.
1405 For these, we use MARKBIT to avoid double marking of the slot. */
1407 for (i
= 0; i
< staticidx
; i
++)
1408 mark_object (staticvec
[i
]);
1409 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1410 for (i
= 0; i
< tail
->nvars
; i
++)
1411 if (!XMARKBIT (tail
->var
[i
]))
1413 mark_object (&tail
->var
[i
]);
1414 XMARK (tail
->var
[i
]);
1416 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1418 mark_object (&bind
->symbol
);
1419 mark_object (&bind
->old_value
);
1421 for (catch = catchlist
; catch; catch = catch->next
)
1423 mark_object (&catch->tag
);
1424 mark_object (&catch->val
);
1426 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1428 mark_object (&handler
->handler
);
1429 mark_object (&handler
->var
);
1431 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1433 if (!XMARKBIT (*backlist
->function
))
1435 mark_object (backlist
->function
);
1436 XMARK (*backlist
->function
);
1438 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1441 i
= backlist
->nargs
- 1;
1443 if (!XMARKBIT (backlist
->args
[i
]))
1445 mark_object (&backlist
->args
[i
]);
1446 XMARK (backlist
->args
[i
]);
1449 mark_perdisplays ();
1453 /* Clear the mark bits that we set in certain root slots. */
1455 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1456 for (i
= 0; i
< tail
->nvars
; i
++)
1457 XUNMARK (tail
->var
[i
]);
1458 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1460 XUNMARK (*backlist
->function
);
1461 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1464 i
= backlist
->nargs
- 1;
1466 XUNMARK (backlist
->args
[i
]);
1468 XUNMARK (buffer_defaults
.name
);
1469 XUNMARK (buffer_local_symbols
.name
);
1471 /* clear_marks (); */
1474 consing_since_gc
= 0;
1475 if (gc_cons_threshold
< 10000)
1476 gc_cons_threshold
= 10000;
1478 if (omessage
|| minibuf_level
> 0)
1479 message2_nolog (omessage
, omessage_length
);
1480 else if (!noninteractive
)
1481 message1_nolog ("Garbage collecting...done");
1483 return Fcons (Fcons (make_number (total_conses
),
1484 make_number (total_free_conses
)),
1485 Fcons (Fcons (make_number (total_symbols
),
1486 make_number (total_free_symbols
)),
1487 Fcons (Fcons (make_number (total_markers
),
1488 make_number (total_free_markers
)),
1489 Fcons (make_number (total_string_size
),
1490 Fcons (make_number (total_vector_size
),
1492 #ifdef LISP_FLOAT_TYPE
1493 Fcons (Fcons (make_number (total_floats
),
1494 make_number (total_free_floats
)),
1496 #else /* not LISP_FLOAT_TYPE */
1498 #endif /* not LISP_FLOAT_TYPE */
1506 /* Clear marks on all conses */
1508 register struct cons_block
*cblk
;
1509 register int lim
= cons_block_index
;
1511 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1514 for (i
= 0; i
< lim
; i
++)
1515 XUNMARK (cblk
->conses
[i
].car
);
1516 lim
= CONS_BLOCK_SIZE
;
1519 /* Clear marks on all symbols */
1521 register struct symbol_block
*sblk
;
1522 register int lim
= symbol_block_index
;
1524 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1527 for (i
= 0; i
< lim
; i
++)
1529 XUNMARK (sblk
->symbols
[i
].plist
);
1531 lim
= SYMBOL_BLOCK_SIZE
;
1534 /* Clear marks on all markers */
1536 register struct marker_block
*sblk
;
1537 register int lim
= marker_block_index
;
1539 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1542 for (i
= 0; i
< lim
; i
++)
1543 if (sblk
->markers
[i
].type
== Lisp_Misc_Marker
)
1544 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1545 lim
= MARKER_BLOCK_SIZE
;
1548 /* Clear mark bits on all buffers */
1550 register struct buffer
*nextb
= all_buffers
;
1554 XUNMARK (nextb
->name
);
1555 nextb
= nextb
->next
;
1561 /* Mark reference to a Lisp_Object.
1562 If the object referred to has not been seen yet, recursively mark
1563 all the references contained in it.
1565 If the object referenced is a short string, the referencing slot
1566 is threaded into a chain of such slots, pointed to from
1567 the `size' field of the string. The actual string size
1568 lives in the last slot in the chain. We recognize the end
1569 because it is < (unsigned) STRING_BLOCK_SIZE. */
1571 #define LAST_MARKED_SIZE 500
1572 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1573 int last_marked_index
;
1576 mark_object (objptr
)
1577 Lisp_Object
*objptr
;
1579 register Lisp_Object obj
;
1586 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1587 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1590 last_marked
[last_marked_index
++] = objptr
;
1591 if (last_marked_index
== LAST_MARKED_SIZE
)
1592 last_marked_index
= 0;
1594 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1598 register struct Lisp_String
*ptr
= XSTRING (obj
);
1600 MARK_INTERVAL_TREE (ptr
->intervals
);
1601 if (ptr
->size
& MARKBIT
)
1602 /* A large string. Just set ARRAY_MARK_FLAG. */
1603 ptr
->size
|= ARRAY_MARK_FLAG
;
1606 /* A small string. Put this reference
1607 into the chain of references to it.
1608 If the address includes MARKBIT, put that bit elsewhere
1609 when we store OBJPTR into the size field. */
1611 if (XMARKBIT (*objptr
))
1613 XSETFASTINT (*objptr
, ptr
->size
);
1617 XSETFASTINT (*objptr
, ptr
->size
);
1619 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1621 ptr
->size
= (EMACS_INT
) objptr
;
1622 if (ptr
->size
& MARKBIT
)
1623 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1628 case Lisp_Vectorlike
:
1629 if (GC_BUFFERP (obj
))
1631 if (!XMARKBIT (XBUFFER (obj
)->name
))
1634 else if (GC_SUBRP (obj
))
1636 else if (GC_COMPILEDP (obj
))
1637 /* We could treat this just like a vector, but it is better
1638 to save the COMPILED_CONSTANTS element for last and avoid recursion
1641 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1642 register EMACS_INT size
= ptr
->size
;
1643 /* See comment above under Lisp_Vector. */
1644 struct Lisp_Vector
*volatile ptr1
= ptr
;
1647 if (size
& ARRAY_MARK_FLAG
)
1648 break; /* Already marked */
1649 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1650 size
&= PSEUDOVECTOR_SIZE_MASK
;
1651 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1653 if (i
!= COMPILED_CONSTANTS
)
1654 mark_object (&ptr1
->contents
[i
]);
1656 /* This cast should be unnecessary, but some Mips compiler complains
1657 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1658 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1662 else if (GC_FRAMEP (obj
))
1664 /* See comment above under Lisp_Vector for why this is volatile. */
1665 register struct frame
*volatile ptr
= XFRAME (obj
);
1666 register EMACS_INT size
= ptr
->size
;
1668 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1669 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1671 mark_object (&ptr
->name
);
1672 mark_object (&ptr
->focus_frame
);
1673 mark_object (&ptr
->selected_window
);
1674 mark_object (&ptr
->minibuffer_window
);
1675 mark_object (&ptr
->param_alist
);
1676 mark_object (&ptr
->scroll_bars
);
1677 mark_object (&ptr
->condemned_scroll_bars
);
1678 mark_object (&ptr
->menu_bar_items
);
1679 mark_object (&ptr
->face_alist
);
1680 mark_object (&ptr
->menu_bar_vector
);
1681 mark_object (&ptr
->buffer_predicate
);
1683 #endif /* MULTI_FRAME */
1686 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1687 register EMACS_INT size
= ptr
->size
;
1688 /* The reason we use ptr1 is to avoid an apparent hardware bug
1689 that happens occasionally on the FSF's HP 300s.
1690 The bug is that a2 gets clobbered by recursive calls to mark_object.
1691 The clobberage seems to happen during function entry,
1692 perhaps in the moveml instruction.
1693 Yes, this is a crock, but we have to do it. */
1694 struct Lisp_Vector
*volatile ptr1
= ptr
;
1697 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1698 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1699 if (size
& PSEUDOVECTOR_FLAG
)
1700 size
&= PSEUDOVECTOR_SIZE_MASK
;
1701 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1702 mark_object (&ptr1
->contents
[i
]);
1708 /* See comment above under Lisp_Vector for why this is volatile. */
1709 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1710 struct Lisp_Symbol
*ptrx
;
1712 if (XMARKBIT (ptr
->plist
)) break;
1714 mark_object ((Lisp_Object
*) &ptr
->value
);
1715 mark_object (&ptr
->function
);
1716 mark_object (&ptr
->plist
);
1717 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1718 mark_object (&ptr
->name
);
1722 /* For the benefit of the last_marked log. */
1723 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1724 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1725 XSETSYMBOL (obj
, ptrx
);
1726 /* We can't goto loop here because *objptr doesn't contain an
1727 actual Lisp_Object with valid datatype field. */
1734 switch (XMISC (obj
)->type
)
1736 case Lisp_Misc_Marker
:
1737 XMARK (XMARKER (obj
)->chain
);
1738 /* DO NOT mark thru the marker's chain.
1739 The buffer's markers chain does not preserve markers from gc;
1740 instead, markers are removed from the chain when freed by gc. */
1743 case Lisp_Misc_Buffer_Local_Value
:
1744 case Lisp_Misc_Some_Buffer_Local_Value
:
1746 register struct Lisp_Buffer_Local_Value
*ptr
1747 = XBUFFER_LOCAL_VALUE (obj
);
1748 if (XMARKBIT (ptr
->car
)) break;
1750 /* If the cdr is nil, avoid recursion for the car. */
1751 if (EQ (ptr
->cdr
, Qnil
))
1756 mark_object (&ptr
->car
);
1757 /* See comment above under Lisp_Vector for why not use ptr here. */
1758 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1762 case Lisp_Misc_Intfwd
:
1763 case Lisp_Misc_Boolfwd
:
1764 case Lisp_Misc_Objfwd
:
1765 case Lisp_Misc_Buffer_Objfwd
:
1766 case Lisp_Misc_Display_Objfwd
:
1767 /* Don't bother with Lisp_Buffer_Objfwd,
1768 since all markable slots in current buffer marked anyway. */
1769 /* Don't need to do Lisp_Objfwd, since the places they point
1770 are protected with staticpro. */
1773 case Lisp_Misc_Overlay
:
1775 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1776 if (!XMARKBIT (ptr
->plist
))
1779 mark_object (&ptr
->start
);
1780 mark_object (&ptr
->end
);
1781 objptr
= &ptr
->plist
;
1794 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1795 if (XMARKBIT (ptr
->car
)) break;
1797 /* If the cdr is nil, avoid recursion for the car. */
1798 if (EQ (ptr
->cdr
, Qnil
))
1803 mark_object (&ptr
->car
);
1804 /* See comment above under Lisp_Vector for why not use ptr here. */
1805 objptr
= &XCONS (obj
)->cdr
;
1809 #ifdef LISP_FLOAT_TYPE
1811 XMARK (XFLOAT (obj
)->type
);
1813 #endif /* LISP_FLOAT_TYPE */
1823 /* Mark the pointers in a buffer structure. */
1829 register struct buffer
*buffer
= XBUFFER (buf
);
1830 register Lisp_Object
*ptr
;
1831 Lisp_Object base_buffer
;
1833 /* This is the buffer's markbit */
1834 mark_object (&buffer
->name
);
1835 XMARK (buffer
->name
);
1837 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1840 mark_object (buffer
->syntax_table
);
1842 /* Mark the various string-pointers in the buffer object.
1843 Since the strings may be relocated, we must mark them
1844 in their actual slots. So gc_sweep must convert each slot
1845 back to an ordinary C pointer. */
1846 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1847 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1848 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1849 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1851 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1852 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1853 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1854 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1857 for (ptr
= &buffer
->name
+ 1;
1858 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1862 /* If this is an indirect buffer, mark its base buffer. */
1863 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1865 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1866 mark_buffer (base_buffer
);
1871 /* Mark the pointers in the perdisplay objects. */
1877 for (perd
= all_perdisplays
; perd
; perd
= perd
->next_perdisplay
)
1879 mark_object (&perd
->Vprefix_arg
);
1880 mark_object (&perd
->Vcurrent_prefix_arg
);
1881 mark_object (&perd
->kbd_buffer_frame_or_window
);
1885 /* Sweep: find all structures not marked, and free them. */
1890 total_string_size
= 0;
1893 /* Put all unmarked conses on free list */
1895 register struct cons_block
*cblk
;
1896 register int lim
= cons_block_index
;
1897 register int num_free
= 0, num_used
= 0;
1901 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1904 for (i
= 0; i
< lim
; i
++)
1905 if (!XMARKBIT (cblk
->conses
[i
].car
))
1908 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1909 cons_free_list
= &cblk
->conses
[i
];
1914 XUNMARK (cblk
->conses
[i
].car
);
1916 lim
= CONS_BLOCK_SIZE
;
1918 total_conses
= num_used
;
1919 total_free_conses
= num_free
;
1922 #ifdef LISP_FLOAT_TYPE
1923 /* Put all unmarked floats on free list */
1925 register struct float_block
*fblk
;
1926 register int lim
= float_block_index
;
1927 register int num_free
= 0, num_used
= 0;
1929 float_free_list
= 0;
1931 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1934 for (i
= 0; i
< lim
; i
++)
1935 if (!XMARKBIT (fblk
->floats
[i
].type
))
1938 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1939 float_free_list
= &fblk
->floats
[i
];
1944 XUNMARK (fblk
->floats
[i
].type
);
1946 lim
= FLOAT_BLOCK_SIZE
;
1948 total_floats
= num_used
;
1949 total_free_floats
= num_free
;
1951 #endif /* LISP_FLOAT_TYPE */
1953 #ifdef USE_TEXT_PROPERTIES
1954 /* Put all unmarked intervals on free list */
1956 register struct interval_block
*iblk
;
1957 register int lim
= interval_block_index
;
1958 register int num_free
= 0, num_used
= 0;
1960 interval_free_list
= 0;
1962 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1966 for (i
= 0; i
< lim
; i
++)
1968 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1970 iblk
->intervals
[i
].parent
= interval_free_list
;
1971 interval_free_list
= &iblk
->intervals
[i
];
1977 XUNMARK (iblk
->intervals
[i
].plist
);
1980 lim
= INTERVAL_BLOCK_SIZE
;
1982 total_intervals
= num_used
;
1983 total_free_intervals
= num_free
;
1985 #endif /* USE_TEXT_PROPERTIES */
1987 /* Put all unmarked symbols on free list */
1989 register struct symbol_block
*sblk
;
1990 register int lim
= symbol_block_index
;
1991 register int num_free
= 0, num_used
= 0;
1993 symbol_free_list
= 0;
1995 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1998 for (i
= 0; i
< lim
; i
++)
1999 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2001 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2002 symbol_free_list
= &sblk
->symbols
[i
];
2008 sblk
->symbols
[i
].name
2009 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2010 XUNMARK (sblk
->symbols
[i
].plist
);
2012 lim
= SYMBOL_BLOCK_SIZE
;
2014 total_symbols
= num_used
;
2015 total_free_symbols
= num_free
;
2019 /* Put all unmarked markers on free list.
2020 Dechain each one first from the buffer it points into,
2021 but only if it's a real marker. */
2023 register struct marker_block
*mblk
;
2024 register int lim
= marker_block_index
;
2025 register int num_free
= 0, num_used
= 0;
2027 marker_free_list
= 0;
2029 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2032 for (i
= 0; i
< lim
; i
++)
2034 Lisp_Object
*markword
;
2035 switch (mblk
->markers
[i
].type
)
2037 case Lisp_Misc_Marker
:
2038 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2040 case Lisp_Misc_Buffer_Local_Value
:
2041 case Lisp_Misc_Some_Buffer_Local_Value
:
2042 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2044 case Lisp_Misc_Overlay
:
2045 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2051 if (markword
&& !XMARKBIT (*markword
))
2054 if (mblk
->markers
[i
].type
== Lisp_Misc_Marker
)
2056 /* tem1 avoids Sun compiler bug */
2057 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2058 XSETMARKER (tem
, tem1
);
2059 unchain_marker (tem
);
2061 /* We could leave the type alone, since nobody checks it,
2062 but this might catch bugs faster. */
2063 mblk
->markers
[i
].type
= Lisp_Misc_Free
;
2064 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2065 marker_free_list
= &mblk
->markers
[i
];
2072 XUNMARK (*markword
);
2075 lim
= MARKER_BLOCK_SIZE
;
2078 total_markers
= num_used
;
2079 total_free_markers
= num_free
;
2082 /* Free all unmarked buffers */
2084 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2087 if (!XMARKBIT (buffer
->name
))
2090 prev
->next
= buffer
->next
;
2092 all_buffers
= buffer
->next
;
2093 next
= buffer
->next
;
2099 XUNMARK (buffer
->name
);
2100 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2103 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2104 for purposes of marking and relocation.
2105 Turn them back into C pointers now. */
2106 buffer
->upcase_table
2107 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2108 buffer
->downcase_table
2109 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2111 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2112 buffer
->folding_sort_table
2113 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2116 prev
= buffer
, buffer
= buffer
->next
;
2120 #endif /* standalone */
2122 /* Free all unmarked vectors */
2124 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2125 total_vector_size
= 0;
2128 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2131 prev
->next
= vector
->next
;
2133 all_vectors
= vector
->next
;
2134 next
= vector
->next
;
2140 vector
->size
&= ~ARRAY_MARK_FLAG
;
2141 total_vector_size
+= vector
->size
;
2142 prev
= vector
, vector
= vector
->next
;
2146 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2148 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2149 struct Lisp_String
*s
;
2153 s
= (struct Lisp_String
*) &sb
->chars
[0];
2154 if (s
->size
& ARRAY_MARK_FLAG
)
2156 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2157 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2158 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2159 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2160 prev
= sb
, sb
= sb
->next
;
2165 prev
->next
= sb
->next
;
2167 large_string_blocks
= sb
->next
;
2176 /* Compactify strings, relocate references, and free empty string blocks. */
2181 /* String block of old strings we are scanning. */
2182 register struct string_block
*from_sb
;
2183 /* A preceding string block (or maybe the same one)
2184 where we are copying the still-live strings to. */
2185 register struct string_block
*to_sb
;
2189 to_sb
= first_string_block
;
2192 /* Scan each existing string block sequentially, string by string. */
2193 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2196 /* POS is the index of the next string in the block. */
2197 while (pos
< from_sb
->pos
)
2199 register struct Lisp_String
*nextstr
2200 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2202 register struct Lisp_String
*newaddr
;
2203 register EMACS_INT size
= nextstr
->size
;
2205 /* NEXTSTR is the old address of the next string.
2206 Just skip it if it isn't marked. */
2207 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2209 /* It is marked, so its size field is really a chain of refs.
2210 Find the end of the chain, where the actual size lives. */
2211 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2213 if (size
& DONT_COPY_FLAG
)
2214 size
^= MARKBIT
| DONT_COPY_FLAG
;
2215 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2218 total_string_size
+= size
;
2220 /* If it won't fit in TO_SB, close it out,
2221 and move to the next sb. Keep doing so until
2222 TO_SB reaches a large enough, empty enough string block.
2223 We know that TO_SB cannot advance past FROM_SB here
2224 since FROM_SB is large enough to contain this string.
2225 Any string blocks skipped here
2226 will be patched out and freed later. */
2227 while (to_pos
+ STRING_FULLSIZE (size
)
2228 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2230 to_sb
->pos
= to_pos
;
2231 to_sb
= to_sb
->next
;
2234 /* Compute new address of this string
2235 and update TO_POS for the space being used. */
2236 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2237 to_pos
+= STRING_FULLSIZE (size
);
2239 /* Copy the string itself to the new place. */
2240 if (nextstr
!= newaddr
)
2241 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2242 + INTERVAL_PTR_SIZE
);
2244 /* Go through NEXTSTR's chain of references
2245 and make each slot in the chain point to
2246 the new address of this string. */
2247 size
= newaddr
->size
;
2248 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2250 register Lisp_Object
*objptr
;
2251 if (size
& DONT_COPY_FLAG
)
2252 size
^= MARKBIT
| DONT_COPY_FLAG
;
2253 objptr
= (Lisp_Object
*)size
;
2255 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2256 if (XMARKBIT (*objptr
))
2258 XSETSTRING (*objptr
, newaddr
);
2262 XSETSTRING (*objptr
, newaddr
);
2264 /* Store the actual size in the size field. */
2265 newaddr
->size
= size
;
2267 #ifdef USE_TEXT_PROPERTIES
2268 /* Now that the string has been relocated, rebalance its
2269 interval tree, and update the tree's parent pointer. */
2270 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2272 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2273 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2276 #endif /* USE_TEXT_PROPERTIES */
2278 pos
+= STRING_FULLSIZE (size
);
2282 /* Close out the last string block still used and free any that follow. */
2283 to_sb
->pos
= to_pos
;
2284 current_string_block
= to_sb
;
2286 from_sb
= to_sb
->next
;
2290 to_sb
= from_sb
->next
;
2295 /* Free any empty string blocks further back in the chain.
2296 This loop will never free first_string_block, but it is very
2297 unlikely that that one will become empty, so why bother checking? */
2299 from_sb
= first_string_block
;
2300 while (to_sb
= from_sb
->next
)
2302 if (to_sb
->pos
== 0)
2304 if (from_sb
->next
= to_sb
->next
)
2305 from_sb
->next
->prev
= from_sb
;
2313 /* Debugging aids. */
2315 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2316 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2317 This may be helpful in debugging Emacs's memory usage.\n\
2318 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2323 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2329 /* Initialization */
2333 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2336 pure_size
= PURESIZE
;
2339 ignore_warnings
= 1;
2344 #ifdef LISP_FLOAT_TYPE
2346 #endif /* LISP_FLOAT_TYPE */
2350 malloc_hysteresis
= 32;
2352 malloc_hysteresis
= 0;
2355 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2357 ignore_warnings
= 0;
2360 consing_since_gc
= 0;
2361 gc_cons_threshold
= 100000;
2362 #ifdef VIRT_ADDR_VARIES
2363 malloc_sbrk_unused
= 1<<22; /* A large number */
2364 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2365 #endif /* VIRT_ADDR_VARIES */
2376 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2377 "*Number of bytes of consing between garbage collections.\n\
2378 Garbage collection can happen automatically once this many bytes have been\n\
2379 allocated since the last garbage collection. All data types count.\n\n\
2380 Garbage collection happens automatically only when `eval' is called.\n\n\
2381 By binding this temporarily to a large number, you can effectively\n\
2382 prevent garbage collection during a part of the program.");
2384 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2385 "Number of bytes of sharable Lisp data allocated so far.");
2388 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2389 "Number of bytes of unshared memory allocated in this session.");
2391 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2392 "Number of bytes of unshared memory remaining available in this session.");
2395 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2396 "Non-nil means loading Lisp code in order to dump an executable.\n\
2397 This means that certain objects should be allocated in shared (pure) space.");
2399 DEFVAR_INT ("undo-limit", &undo_limit
,
2400 "Keep no more undo information once it exceeds this size.\n\
2401 This limit is applied when garbage collection happens.\n\
2402 The size is counted as the number of bytes occupied,\n\
2403 which includes both saved text and other data.");
2406 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2407 "Don't keep more than this much size of undo information.\n\
2408 A command which pushes past this size is itself forgotten.\n\
2409 This limit is applied when garbage collection happens.\n\
2410 The size is counted as the number of bytes occupied,\n\
2411 which includes both saved text and other data.");
2412 undo_strong_limit
= 30000;
2414 /* We build this in advance because if we wait until we need it, we might
2415 not be able to allocate the memory to hold it. */
2417 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2418 staticpro (&memory_signal_data
);
2423 defsubr (&Smake_byte_code
);
2424 defsubr (&Smake_list
);
2425 defsubr (&Smake_vector
);
2426 defsubr (&Smake_string
);
2427 defsubr (&Smake_symbol
);
2428 defsubr (&Smake_marker
);
2429 defsubr (&Spurecopy
);
2430 defsubr (&Sgarbage_collect
);
2431 defsubr (&Smemory_limit
);