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"
34 #include "syssignal.h"
36 /* The following come from gmalloc.c. */
38 #if defined (__STDC__) && __STDC__
40 #define __malloc_size_t size_t
42 #define __malloc_size_t unsigned int
44 extern __malloc_size_t _bytes_used
;
45 extern int __malloc_extra_blocks
;
47 #define max(A,B) ((A) > (B) ? (A) : (B))
48 #define min(A,B) ((A) < (B) ? (A) : (B))
50 /* Macro to verify that storage intended for Lisp objects is not
51 out of range to fit in the space for a pointer.
52 ADDRESS is the start of the block, and SIZE
53 is the amount of space within which objects can start. */
54 #define VALIDATE_LISP_STORAGE(address, size) \
58 XSETCONS (val, (char *) address + size); \
59 if ((char *) XCONS (val) != (char *) address + size) \
66 /* Value of _bytes_used, when spare_memory was freed. */
67 static __malloc_size_t bytes_used_when_full
;
69 /* Number of bytes of consing done since the last gc */
72 /* Number of bytes of consing since gc before another gc should be done. */
73 int gc_cons_threshold
;
75 /* Nonzero during gc */
78 #ifndef VIRT_ADDR_VARIES
80 #endif /* VIRT_ADDR_VARIES */
83 #ifndef VIRT_ADDR_VARIES
85 #endif /* VIRT_ADDR_VARIES */
86 int malloc_sbrk_unused
;
88 /* Two limits controlling how much undo information to keep. */
90 int undo_strong_limit
;
92 /* Points to memory space allocated as "spare",
93 to be freed if we run out of memory. */
94 static char *spare_memory
;
96 /* Amount of spare memory to keep in reserve. */
97 #define SPARE_MEMORY (1 << 14)
99 /* Number of extra blocks malloc should get when it needs more core. */
100 static int malloc_hysteresis
;
102 /* Non-nil means defun should do purecopy on the function definition */
103 Lisp_Object Vpurify_flag
;
106 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
107 #define PUREBEG (char *) pure
109 #define pure PURE_SEG_BITS /* Use shared memory segment */
110 #define PUREBEG (char *)PURE_SEG_BITS
112 /* This variable is used only by the XPNTR macro when HAVE_SHM is
113 defined. If we used the PURESIZE macro directly there, that would
114 make most of emacs dependent on puresize.h, which we don't want -
115 you should be able to change that without too much recompilation.
116 So map_in_data initializes pure_size, and the dependencies work
119 #endif /* not HAVE_SHM */
121 /* Index in pure at which next pure object will be allocated. */
124 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
125 char *pending_malloc_warning
;
127 /* Pre-computed signal argument for use when memory is exhausted. */
128 Lisp_Object memory_signal_data
;
130 /* Maximum amount of C stack to save when a GC happens. */
132 #ifndef MAX_SAVE_STACK
133 #define MAX_SAVE_STACK 16000
136 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
137 pointer to a Lisp_Object, when that pointer is viewed as an integer.
138 (On most machines, pointers are even, so we can use the low bit.
139 Word-addressible architectures may need to override this in the m-file.)
140 When linking references to small strings through the size field, we
141 use this slot to hold the bit that would otherwise be interpreted as
143 #ifndef DONT_COPY_FLAG
144 #define DONT_COPY_FLAG 1
145 #endif /* no DONT_COPY_FLAG */
147 /* Buffer in which we save a copy of the C stack at each GC. */
152 /* Non-zero means ignore malloc warnings. Set during initialization. */
155 Lisp_Object Qgc_cons_threshold
;
157 static void mark_object (), mark_buffer (), mark_kboards ();
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 XMISCTYPE (val
) = 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 768
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 /* Temporarily prevent garbage collection. */
1321 inhibit_garbage_collection ()
1323 int count
= specpdl_ptr
- specpdl
;
1325 int nbits
= min (VALBITS
, INTBITS
);
1327 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1329 specbind (Qgc_cons_threshold
, number
);
1334 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1335 "Reclaim storage for Lisp objects no longer needed.\n\
1336 Returns info on amount of space in use:\n\
1337 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1338 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1339 (USED-FLOATS . FREE-FLOATS))\n\
1340 Garbage collection happens automatically if you cons more than\n\
1341 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1344 register struct gcpro
*tail
;
1345 register struct specbinding
*bind
;
1346 struct catchtag
*catch;
1347 struct handler
*handler
;
1348 register struct backtrace
*backlist
;
1349 register Lisp_Object tem
;
1350 char *omessage
= echo_area_glyphs
;
1351 int omessage_length
= echo_area_glyphs_length
;
1352 char stack_top_variable
;
1355 /* In case user calls debug_print during GC,
1356 don't let that cause a recursive GC. */
1357 consing_since_gc
= 0;
1359 /* Save a copy of the contents of the stack, for debugging. */
1360 #if MAX_SAVE_STACK > 0
1361 if (NILP (Vpurify_flag
))
1363 i
= &stack_top_variable
- stack_bottom
;
1365 if (i
< MAX_SAVE_STACK
)
1367 if (stack_copy
== 0)
1368 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1369 else if (stack_copy_size
< i
)
1370 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1373 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1374 bcopy (stack_bottom
, stack_copy
, i
);
1376 bcopy (&stack_top_variable
, stack_copy
, i
);
1380 #endif /* MAX_SAVE_STACK > 0 */
1382 if (!noninteractive
)
1383 message1_nolog ("Garbage collecting...");
1385 /* Don't keep command history around forever */
1386 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1388 XCONS (tem
)->cdr
= Qnil
;
1390 /* Likewise for undo information. */
1392 register struct buffer
*nextb
= all_buffers
;
1396 /* If a buffer's undo list is Qt, that means that undo is
1397 turned off in that buffer. Calling truncate_undo_list on
1398 Qt tends to return NULL, which effectively turns undo back on.
1399 So don't call truncate_undo_list if undo_list is Qt. */
1400 if (! EQ (nextb
->undo_list
, Qt
))
1402 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1404 nextb
= nextb
->next
;
1410 /* clear_marks (); */
1412 /* In each "large string", set the MARKBIT of the size field.
1413 That enables mark_object to recognize them. */
1415 register struct string_block
*b
;
1416 for (b
= large_string_blocks
; b
; b
= b
->next
)
1417 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1420 /* Mark all the special slots that serve as the roots of accessibility.
1422 Usually the special slots to mark are contained in particular structures.
1423 Then we know no slot is marked twice because the structures don't overlap.
1424 In some cases, the structures point to the slots to be marked.
1425 For these, we use MARKBIT to avoid double marking of the slot. */
1427 for (i
= 0; i
< staticidx
; i
++)
1428 mark_object (staticvec
[i
]);
1429 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1430 for (i
= 0; i
< tail
->nvars
; i
++)
1431 if (!XMARKBIT (tail
->var
[i
]))
1433 mark_object (&tail
->var
[i
]);
1434 XMARK (tail
->var
[i
]);
1436 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1438 mark_object (&bind
->symbol
);
1439 mark_object (&bind
->old_value
);
1441 for (catch = catchlist
; catch; catch = catch->next
)
1443 mark_object (&catch->tag
);
1444 mark_object (&catch->val
);
1446 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1448 mark_object (&handler
->handler
);
1449 mark_object (&handler
->var
);
1451 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1453 if (!XMARKBIT (*backlist
->function
))
1455 mark_object (backlist
->function
);
1456 XMARK (*backlist
->function
);
1458 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1461 i
= backlist
->nargs
- 1;
1463 if (!XMARKBIT (backlist
->args
[i
]))
1465 mark_object (&backlist
->args
[i
]);
1466 XMARK (backlist
->args
[i
]);
1473 /* Clear the mark bits that we set in certain root slots. */
1475 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1476 for (i
= 0; i
< tail
->nvars
; i
++)
1477 XUNMARK (tail
->var
[i
]);
1478 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1480 XUNMARK (*backlist
->function
);
1481 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1484 i
= backlist
->nargs
- 1;
1486 XUNMARK (backlist
->args
[i
]);
1488 XUNMARK (buffer_defaults
.name
);
1489 XUNMARK (buffer_local_symbols
.name
);
1491 /* clear_marks (); */
1494 consing_since_gc
= 0;
1495 if (gc_cons_threshold
< 10000)
1496 gc_cons_threshold
= 10000;
1498 if (omessage
|| minibuf_level
> 0)
1499 message2_nolog (omessage
, omessage_length
);
1500 else if (!noninteractive
)
1501 message1_nolog ("Garbage collecting...done");
1503 return Fcons (Fcons (make_number (total_conses
),
1504 make_number (total_free_conses
)),
1505 Fcons (Fcons (make_number (total_symbols
),
1506 make_number (total_free_symbols
)),
1507 Fcons (Fcons (make_number (total_markers
),
1508 make_number (total_free_markers
)),
1509 Fcons (make_number (total_string_size
),
1510 Fcons (make_number (total_vector_size
),
1512 #ifdef LISP_FLOAT_TYPE
1513 Fcons (Fcons (make_number (total_floats
),
1514 make_number (total_free_floats
)),
1516 #else /* not LISP_FLOAT_TYPE */
1518 #endif /* not LISP_FLOAT_TYPE */
1526 /* Clear marks on all conses */
1528 register struct cons_block
*cblk
;
1529 register int lim
= cons_block_index
;
1531 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1534 for (i
= 0; i
< lim
; i
++)
1535 XUNMARK (cblk
->conses
[i
].car
);
1536 lim
= CONS_BLOCK_SIZE
;
1539 /* Clear marks on all symbols */
1541 register struct symbol_block
*sblk
;
1542 register int lim
= symbol_block_index
;
1544 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1547 for (i
= 0; i
< lim
; i
++)
1549 XUNMARK (sblk
->symbols
[i
].plist
);
1551 lim
= SYMBOL_BLOCK_SIZE
;
1554 /* Clear marks on all markers */
1556 register struct marker_block
*sblk
;
1557 register int lim
= marker_block_index
;
1559 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1562 for (i
= 0; i
< lim
; i
++)
1563 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1564 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1565 lim
= MARKER_BLOCK_SIZE
;
1568 /* Clear mark bits on all buffers */
1570 register struct buffer
*nextb
= all_buffers
;
1574 XUNMARK (nextb
->name
);
1575 nextb
= nextb
->next
;
1581 /* Mark reference to a Lisp_Object.
1582 If the object referred to has not been seen yet, recursively mark
1583 all the references contained in it.
1585 If the object referenced is a short string, the referencing slot
1586 is threaded into a chain of such slots, pointed to from
1587 the `size' field of the string. The actual string size
1588 lives in the last slot in the chain. We recognize the end
1589 because it is < (unsigned) STRING_BLOCK_SIZE. */
1591 #define LAST_MARKED_SIZE 500
1592 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1593 int last_marked_index
;
1596 mark_object (objptr
)
1597 Lisp_Object
*objptr
;
1599 register Lisp_Object obj
;
1606 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1607 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1610 last_marked
[last_marked_index
++] = objptr
;
1611 if (last_marked_index
== LAST_MARKED_SIZE
)
1612 last_marked_index
= 0;
1614 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1618 register struct Lisp_String
*ptr
= XSTRING (obj
);
1620 MARK_INTERVAL_TREE (ptr
->intervals
);
1621 if (ptr
->size
& MARKBIT
)
1622 /* A large string. Just set ARRAY_MARK_FLAG. */
1623 ptr
->size
|= ARRAY_MARK_FLAG
;
1626 /* A small string. Put this reference
1627 into the chain of references to it.
1628 If the address includes MARKBIT, put that bit elsewhere
1629 when we store OBJPTR into the size field. */
1631 if (XMARKBIT (*objptr
))
1633 XSETFASTINT (*objptr
, ptr
->size
);
1637 XSETFASTINT (*objptr
, ptr
->size
);
1639 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1641 ptr
->size
= (EMACS_INT
) objptr
;
1642 if (ptr
->size
& MARKBIT
)
1643 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1648 case Lisp_Vectorlike
:
1649 if (GC_BUFFERP (obj
))
1651 if (!XMARKBIT (XBUFFER (obj
)->name
))
1654 else if (GC_SUBRP (obj
))
1656 else if (GC_COMPILEDP (obj
))
1657 /* We could treat this just like a vector, but it is better
1658 to save the COMPILED_CONSTANTS element for last and avoid recursion
1661 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1662 register EMACS_INT size
= ptr
->size
;
1663 /* See comment above under Lisp_Vector. */
1664 struct Lisp_Vector
*volatile ptr1
= ptr
;
1667 if (size
& ARRAY_MARK_FLAG
)
1668 break; /* Already marked */
1669 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1670 size
&= PSEUDOVECTOR_SIZE_MASK
;
1671 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1673 if (i
!= COMPILED_CONSTANTS
)
1674 mark_object (&ptr1
->contents
[i
]);
1676 /* This cast should be unnecessary, but some Mips compiler complains
1677 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1678 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1682 else if (GC_FRAMEP (obj
))
1684 /* See comment above under Lisp_Vector for why this is volatile. */
1685 register struct frame
*volatile ptr
= XFRAME (obj
);
1686 register EMACS_INT size
= ptr
->size
;
1688 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1689 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1691 mark_object (&ptr
->name
);
1692 mark_object (&ptr
->focus_frame
);
1693 mark_object (&ptr
->selected_window
);
1694 mark_object (&ptr
->minibuffer_window
);
1695 mark_object (&ptr
->param_alist
);
1696 mark_object (&ptr
->scroll_bars
);
1697 mark_object (&ptr
->condemned_scroll_bars
);
1698 mark_object (&ptr
->menu_bar_items
);
1699 mark_object (&ptr
->face_alist
);
1700 mark_object (&ptr
->menu_bar_vector
);
1701 mark_object (&ptr
->buffer_predicate
);
1703 #endif /* MULTI_FRAME */
1706 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1707 register EMACS_INT size
= ptr
->size
;
1708 /* The reason we use ptr1 is to avoid an apparent hardware bug
1709 that happens occasionally on the FSF's HP 300s.
1710 The bug is that a2 gets clobbered by recursive calls to mark_object.
1711 The clobberage seems to happen during function entry,
1712 perhaps in the moveml instruction.
1713 Yes, this is a crock, but we have to do it. */
1714 struct Lisp_Vector
*volatile ptr1
= ptr
;
1717 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1718 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1719 if (size
& PSEUDOVECTOR_FLAG
)
1720 size
&= PSEUDOVECTOR_SIZE_MASK
;
1721 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1722 mark_object (&ptr1
->contents
[i
]);
1728 /* See comment above under Lisp_Vector for why this is volatile. */
1729 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1730 struct Lisp_Symbol
*ptrx
;
1732 if (XMARKBIT (ptr
->plist
)) break;
1734 mark_object ((Lisp_Object
*) &ptr
->value
);
1735 mark_object (&ptr
->function
);
1736 mark_object (&ptr
->plist
);
1737 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1738 mark_object (&ptr
->name
);
1742 /* For the benefit of the last_marked log. */
1743 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1744 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1745 XSETSYMBOL (obj
, ptrx
);
1746 /* We can't goto loop here because *objptr doesn't contain an
1747 actual Lisp_Object with valid datatype field. */
1754 switch (XMISCTYPE (obj
))
1756 case Lisp_Misc_Marker
:
1757 XMARK (XMARKER (obj
)->chain
);
1758 /* DO NOT mark thru the marker's chain.
1759 The buffer's markers chain does not preserve markers from gc;
1760 instead, markers are removed from the chain when freed by gc. */
1763 case Lisp_Misc_Buffer_Local_Value
:
1764 case Lisp_Misc_Some_Buffer_Local_Value
:
1766 register struct Lisp_Buffer_Local_Value
*ptr
1767 = XBUFFER_LOCAL_VALUE (obj
);
1768 if (XMARKBIT (ptr
->car
)) break;
1770 /* If the cdr is nil, avoid recursion for the car. */
1771 if (EQ (ptr
->cdr
, Qnil
))
1776 mark_object (&ptr
->car
);
1777 /* See comment above under Lisp_Vector for why not use ptr here. */
1778 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1782 case Lisp_Misc_Intfwd
:
1783 case Lisp_Misc_Boolfwd
:
1784 case Lisp_Misc_Objfwd
:
1785 case Lisp_Misc_Buffer_Objfwd
:
1786 case Lisp_Misc_Kboard_Objfwd
:
1787 /* Don't bother with Lisp_Buffer_Objfwd,
1788 since all markable slots in current buffer marked anyway. */
1789 /* Don't need to do Lisp_Objfwd, since the places they point
1790 are protected with staticpro. */
1793 case Lisp_Misc_Overlay
:
1795 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1796 if (!XMARKBIT (ptr
->plist
))
1799 mark_object (&ptr
->start
);
1800 mark_object (&ptr
->end
);
1801 objptr
= &ptr
->plist
;
1814 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1815 if (XMARKBIT (ptr
->car
)) break;
1817 /* If the cdr is nil, avoid recursion for the car. */
1818 if (EQ (ptr
->cdr
, Qnil
))
1823 mark_object (&ptr
->car
);
1824 /* See comment above under Lisp_Vector for why not use ptr here. */
1825 objptr
= &XCONS (obj
)->cdr
;
1829 #ifdef LISP_FLOAT_TYPE
1831 XMARK (XFLOAT (obj
)->type
);
1833 #endif /* LISP_FLOAT_TYPE */
1843 /* Mark the pointers in a buffer structure. */
1849 register struct buffer
*buffer
= XBUFFER (buf
);
1850 register Lisp_Object
*ptr
;
1851 Lisp_Object base_buffer
;
1853 /* This is the buffer's markbit */
1854 mark_object (&buffer
->name
);
1855 XMARK (buffer
->name
);
1857 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1860 mark_object (buffer
->syntax_table
);
1862 /* Mark the various string-pointers in the buffer object.
1863 Since the strings may be relocated, we must mark them
1864 in their actual slots. So gc_sweep must convert each slot
1865 back to an ordinary C pointer. */
1866 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1867 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1868 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1869 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1871 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1872 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1873 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1874 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1877 for (ptr
= &buffer
->name
+ 1;
1878 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1882 /* If this is an indirect buffer, mark its base buffer. */
1883 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1885 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1886 mark_buffer (base_buffer
);
1891 /* Mark the pointers in the kboard objects. */
1898 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
1900 if (kb
->kbd_macro_buffer
)
1901 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
1903 mark_object (&kb
->prefix_factor
);
1904 mark_object (&kb
->prefix_value
);
1905 mark_object (&kb
->kbd_queue
);
1906 mark_object (&kb
->Vlast_kbd_macro
);
1907 mark_object (&kb
->Vsystem_key_alist
);
1911 /* Sweep: find all structures not marked, and free them. */
1916 total_string_size
= 0;
1919 /* Put all unmarked conses on free list */
1921 register struct cons_block
*cblk
;
1922 register int lim
= cons_block_index
;
1923 register int num_free
= 0, num_used
= 0;
1927 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1930 for (i
= 0; i
< lim
; i
++)
1931 if (!XMARKBIT (cblk
->conses
[i
].car
))
1934 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1935 cons_free_list
= &cblk
->conses
[i
];
1940 XUNMARK (cblk
->conses
[i
].car
);
1942 lim
= CONS_BLOCK_SIZE
;
1944 total_conses
= num_used
;
1945 total_free_conses
= num_free
;
1948 #ifdef LISP_FLOAT_TYPE
1949 /* Put all unmarked floats on free list */
1951 register struct float_block
*fblk
;
1952 register int lim
= float_block_index
;
1953 register int num_free
= 0, num_used
= 0;
1955 float_free_list
= 0;
1957 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1960 for (i
= 0; i
< lim
; i
++)
1961 if (!XMARKBIT (fblk
->floats
[i
].type
))
1964 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1965 float_free_list
= &fblk
->floats
[i
];
1970 XUNMARK (fblk
->floats
[i
].type
);
1972 lim
= FLOAT_BLOCK_SIZE
;
1974 total_floats
= num_used
;
1975 total_free_floats
= num_free
;
1977 #endif /* LISP_FLOAT_TYPE */
1979 #ifdef USE_TEXT_PROPERTIES
1980 /* Put all unmarked intervals on free list */
1982 register struct interval_block
*iblk
;
1983 register int lim
= interval_block_index
;
1984 register int num_free
= 0, num_used
= 0;
1986 interval_free_list
= 0;
1988 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1992 for (i
= 0; i
< lim
; i
++)
1994 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1996 iblk
->intervals
[i
].parent
= interval_free_list
;
1997 interval_free_list
= &iblk
->intervals
[i
];
2003 XUNMARK (iblk
->intervals
[i
].plist
);
2006 lim
= INTERVAL_BLOCK_SIZE
;
2008 total_intervals
= num_used
;
2009 total_free_intervals
= num_free
;
2011 #endif /* USE_TEXT_PROPERTIES */
2013 /* Put all unmarked symbols on free list */
2015 register struct symbol_block
*sblk
;
2016 register int lim
= symbol_block_index
;
2017 register int num_free
= 0, num_used
= 0;
2019 symbol_free_list
= 0;
2021 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2024 for (i
= 0; i
< lim
; i
++)
2025 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2027 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2028 symbol_free_list
= &sblk
->symbols
[i
];
2034 sblk
->symbols
[i
].name
2035 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2036 XUNMARK (sblk
->symbols
[i
].plist
);
2038 lim
= SYMBOL_BLOCK_SIZE
;
2040 total_symbols
= num_used
;
2041 total_free_symbols
= num_free
;
2045 /* Put all unmarked markers on free list.
2046 Dechain each one first from the buffer it points into,
2047 but only if it's a real marker. */
2049 register struct marker_block
*mblk
;
2050 register int lim
= marker_block_index
;
2051 register int num_free
= 0, num_used
= 0;
2053 marker_free_list
= 0;
2055 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2058 EMACS_INT already_free
= -1;
2060 for (i
= 0; i
< lim
; i
++)
2062 Lisp_Object
*markword
;
2063 switch (mblk
->markers
[i
].u_marker
.type
)
2065 case Lisp_Misc_Marker
:
2066 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2068 case Lisp_Misc_Buffer_Local_Value
:
2069 case Lisp_Misc_Some_Buffer_Local_Value
:
2070 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2072 case Lisp_Misc_Overlay
:
2073 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2075 case Lisp_Misc_Free
:
2076 /* If the object was already free, keep it
2077 on the free list. */
2078 markword
= &already_free
;
2084 if (markword
&& !XMARKBIT (*markword
))
2087 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2089 /* tem1 avoids Sun compiler bug */
2090 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2091 XSETMARKER (tem
, tem1
);
2092 unchain_marker (tem
);
2094 /* Set the type of the freed object to Lisp_Misc_Free.
2095 We could leave the type alone, since nobody checks it,
2096 but this might catch bugs faster. */
2097 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2098 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2099 marker_free_list
= &mblk
->markers
[i
];
2106 XUNMARK (*markword
);
2109 lim
= MARKER_BLOCK_SIZE
;
2112 total_markers
= num_used
;
2113 total_free_markers
= num_free
;
2116 /* Free all unmarked buffers */
2118 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2121 if (!XMARKBIT (buffer
->name
))
2124 prev
->next
= buffer
->next
;
2126 all_buffers
= buffer
->next
;
2127 next
= buffer
->next
;
2133 XUNMARK (buffer
->name
);
2134 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2137 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2138 for purposes of marking and relocation.
2139 Turn them back into C pointers now. */
2140 buffer
->upcase_table
2141 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2142 buffer
->downcase_table
2143 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2145 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2146 buffer
->folding_sort_table
2147 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2150 prev
= buffer
, buffer
= buffer
->next
;
2154 #endif /* standalone */
2156 /* Free all unmarked vectors */
2158 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2159 total_vector_size
= 0;
2162 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2165 prev
->next
= vector
->next
;
2167 all_vectors
= vector
->next
;
2168 next
= vector
->next
;
2174 vector
->size
&= ~ARRAY_MARK_FLAG
;
2175 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2176 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2178 total_vector_size
+= vector
->size
;
2179 prev
= vector
, vector
= vector
->next
;
2183 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2185 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2186 struct Lisp_String
*s
;
2190 s
= (struct Lisp_String
*) &sb
->chars
[0];
2191 if (s
->size
& ARRAY_MARK_FLAG
)
2193 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2194 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2195 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2196 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2197 prev
= sb
, sb
= sb
->next
;
2202 prev
->next
= sb
->next
;
2204 large_string_blocks
= sb
->next
;
2213 /* Compactify strings, relocate references, and free empty string blocks. */
2218 /* String block of old strings we are scanning. */
2219 register struct string_block
*from_sb
;
2220 /* A preceding string block (or maybe the same one)
2221 where we are copying the still-live strings to. */
2222 register struct string_block
*to_sb
;
2226 to_sb
= first_string_block
;
2229 /* Scan each existing string block sequentially, string by string. */
2230 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2233 /* POS is the index of the next string in the block. */
2234 while (pos
< from_sb
->pos
)
2236 register struct Lisp_String
*nextstr
2237 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2239 register struct Lisp_String
*newaddr
;
2240 register EMACS_INT size
= nextstr
->size
;
2242 /* NEXTSTR is the old address of the next string.
2243 Just skip it if it isn't marked. */
2244 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2246 /* It is marked, so its size field is really a chain of refs.
2247 Find the end of the chain, where the actual size lives. */
2248 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2250 if (size
& DONT_COPY_FLAG
)
2251 size
^= MARKBIT
| DONT_COPY_FLAG
;
2252 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2255 total_string_size
+= size
;
2257 /* If it won't fit in TO_SB, close it out,
2258 and move to the next sb. Keep doing so until
2259 TO_SB reaches a large enough, empty enough string block.
2260 We know that TO_SB cannot advance past FROM_SB here
2261 since FROM_SB is large enough to contain this string.
2262 Any string blocks skipped here
2263 will be patched out and freed later. */
2264 while (to_pos
+ STRING_FULLSIZE (size
)
2265 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2267 to_sb
->pos
= to_pos
;
2268 to_sb
= to_sb
->next
;
2271 /* Compute new address of this string
2272 and update TO_POS for the space being used. */
2273 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2274 to_pos
+= STRING_FULLSIZE (size
);
2276 /* Copy the string itself to the new place. */
2277 if (nextstr
!= newaddr
)
2278 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2279 + INTERVAL_PTR_SIZE
);
2281 /* Go through NEXTSTR's chain of references
2282 and make each slot in the chain point to
2283 the new address of this string. */
2284 size
= newaddr
->size
;
2285 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2287 register Lisp_Object
*objptr
;
2288 if (size
& DONT_COPY_FLAG
)
2289 size
^= MARKBIT
| DONT_COPY_FLAG
;
2290 objptr
= (Lisp_Object
*)size
;
2292 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2293 if (XMARKBIT (*objptr
))
2295 XSETSTRING (*objptr
, newaddr
);
2299 XSETSTRING (*objptr
, newaddr
);
2301 /* Store the actual size in the size field. */
2302 newaddr
->size
= size
;
2304 #ifdef USE_TEXT_PROPERTIES
2305 /* Now that the string has been relocated, rebalance its
2306 interval tree, and update the tree's parent pointer. */
2307 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2309 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2310 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2313 #endif /* USE_TEXT_PROPERTIES */
2315 pos
+= STRING_FULLSIZE (size
);
2319 /* Close out the last string block still used and free any that follow. */
2320 to_sb
->pos
= to_pos
;
2321 current_string_block
= to_sb
;
2323 from_sb
= to_sb
->next
;
2327 to_sb
= from_sb
->next
;
2332 /* Free any empty string blocks further back in the chain.
2333 This loop will never free first_string_block, but it is very
2334 unlikely that that one will become empty, so why bother checking? */
2336 from_sb
= first_string_block
;
2337 while (to_sb
= from_sb
->next
)
2339 if (to_sb
->pos
== 0)
2341 if (from_sb
->next
= to_sb
->next
)
2342 from_sb
->next
->prev
= from_sb
;
2350 /* Debugging aids. */
2352 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2353 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2354 This may be helpful in debugging Emacs's memory usage.\n\
2355 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2360 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2366 /* Initialization */
2370 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2373 pure_size
= PURESIZE
;
2376 ignore_warnings
= 1;
2381 #ifdef LISP_FLOAT_TYPE
2383 #endif /* LISP_FLOAT_TYPE */
2387 malloc_hysteresis
= 32;
2389 malloc_hysteresis
= 0;
2392 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2394 ignore_warnings
= 0;
2397 consing_since_gc
= 0;
2398 gc_cons_threshold
= 300000;
2399 #ifdef VIRT_ADDR_VARIES
2400 malloc_sbrk_unused
= 1<<22; /* A large number */
2401 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2402 #endif /* VIRT_ADDR_VARIES */
2413 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2414 "*Number of bytes of consing between garbage collections.\n\
2415 Garbage collection can happen automatically once this many bytes have been\n\
2416 allocated since the last garbage collection. All data types count.\n\n\
2417 Garbage collection happens automatically only when `eval' is called.\n\n\
2418 By binding this temporarily to a large number, you can effectively\n\
2419 prevent garbage collection during a part of the program.");
2421 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2422 "Number of bytes of sharable Lisp data allocated so far.");
2425 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2426 "Number of bytes of unshared memory allocated in this session.");
2428 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2429 "Number of bytes of unshared memory remaining available in this session.");
2432 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2433 "Non-nil means loading Lisp code in order to dump an executable.\n\
2434 This means that certain objects should be allocated in shared (pure) space.");
2436 DEFVAR_INT ("undo-limit", &undo_limit
,
2437 "Keep no more undo information once it exceeds this size.\n\
2438 This limit is applied when garbage collection happens.\n\
2439 The size is counted as the number of bytes occupied,\n\
2440 which includes both saved text and other data.");
2443 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2444 "Don't keep more than this much size of undo information.\n\
2445 A command which pushes past this size is itself forgotten.\n\
2446 This limit is applied when garbage collection happens.\n\
2447 The size is counted as the number of bytes occupied,\n\
2448 which includes both saved text and other data.");
2449 undo_strong_limit
= 30000;
2451 /* We build this in advance because if we wait until we need it, we might
2452 not be able to allocate the memory to hold it. */
2454 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2455 staticpro (&memory_signal_data
);
2457 staticpro (&Qgc_cons_threshold
);
2458 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2463 defsubr (&Smake_byte_code
);
2464 defsubr (&Smake_list
);
2465 defsubr (&Smake_vector
);
2466 defsubr (&Smake_string
);
2467 defsubr (&Smake_symbol
);
2468 defsubr (&Smake_marker
);
2469 defsubr (&Spurecopy
);
2470 defsubr (&Sgarbage_collect
);
2471 defsubr (&Smemory_limit
);