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"
38 /* The following come from gmalloc.c. */
40 #if defined (__STDC__) && __STDC__
42 #define __malloc_size_t size_t
44 #define __malloc_size_t unsigned int
46 extern __malloc_size_t _bytes_used
;
47 extern int __malloc_extra_blocks
;
49 #define max(A,B) ((A) > (B) ? (A) : (B))
50 #define min(A,B) ((A) < (B) ? (A) : (B))
52 /* Macro to verify that storage intended for Lisp objects is not
53 out of range to fit in the space for a pointer.
54 ADDRESS is the start of the block, and SIZE
55 is the amount of space within which objects can start. */
56 #define VALIDATE_LISP_STORAGE(address, size) \
60 XSETCONS (val, (char *) address + size); \
61 if ((char *) XCONS (val) != (char *) address + size) \
68 /* Value of _bytes_used, when spare_memory was freed. */
69 static __malloc_size_t bytes_used_when_full
;
71 /* Number of bytes of consing done since the last gc */
74 /* Number of bytes of consing since gc before another gc should be done. */
75 int gc_cons_threshold
;
77 /* Nonzero during gc */
80 #ifndef VIRT_ADDR_VARIES
82 #endif /* VIRT_ADDR_VARIES */
85 #ifndef VIRT_ADDR_VARIES
87 #endif /* VIRT_ADDR_VARIES */
88 int malloc_sbrk_unused
;
90 /* Two limits controlling how much undo information to keep. */
92 int undo_strong_limit
;
94 /* Points to memory space allocated as "spare",
95 to be freed if we run out of memory. */
96 static char *spare_memory
;
98 /* Amount of spare memory to keep in reserve. */
99 #define SPARE_MEMORY (1 << 14)
101 /* Number of extra blocks malloc should get when it needs more core. */
102 static int malloc_hysteresis
;
104 /* Non-nil means defun should do purecopy on the function definition */
105 Lisp_Object Vpurify_flag
;
108 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
109 #define PUREBEG (char *) pure
111 #define pure PURE_SEG_BITS /* Use shared memory segment */
112 #define PUREBEG (char *)PURE_SEG_BITS
114 /* This variable is used only by the XPNTR macro when HAVE_SHM is
115 defined. If we used the PURESIZE macro directly there, that would
116 make most of emacs dependent on puresize.h, which we don't want -
117 you should be able to change that without too much recompilation.
118 So map_in_data initializes pure_size, and the dependencies work
121 #endif /* not HAVE_SHM */
123 /* Index in pure at which next pure object will be allocated. */
126 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
127 char *pending_malloc_warning
;
129 /* Pre-computed signal argument for use when memory is exhausted. */
130 Lisp_Object memory_signal_data
;
132 /* Maximum amount of C stack to save when a GC happens. */
134 #ifndef MAX_SAVE_STACK
135 #define MAX_SAVE_STACK 16000
138 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
139 pointer to a Lisp_Object, when that pointer is viewed as an integer.
140 (On most machines, pointers are even, so we can use the low bit.
141 Word-addressible architectures may need to override this in the m-file.)
142 When linking references to small strings through the size field, we
143 use this slot to hold the bit that would otherwise be interpreted as
145 #ifndef DONT_COPY_FLAG
146 #define DONT_COPY_FLAG 1
147 #endif /* no DONT_COPY_FLAG */
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 Lisp_Object Qgc_cons_threshold
;
159 static void mark_object (), mark_buffer (), mark_kboards ();
160 static void clear_marks (), gc_sweep ();
161 static void compact_strings ();
163 /* Versions of malloc and realloc that print warnings as memory gets full. */
166 malloc_warning_1 (str
)
169 Fprinc (str
, Vstandard_output
);
170 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
171 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
172 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
176 /* malloc calls this if it finds we are near exhausting storage */
180 pending_malloc_warning
= str
;
183 display_malloc_warning ()
185 register Lisp_Object val
;
187 val
= build_string (pending_malloc_warning
);
188 pending_malloc_warning
= 0;
189 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
192 /* Called if malloc returns zero */
196 #ifndef SYSTEM_MALLOC
197 bytes_used_when_full
= _bytes_used
;
200 /* The first time we get here, free the spare memory. */
207 /* This used to call error, but if we've run out of memory, we could get
208 infinite recursion trying to build the string. */
210 Fsignal (Qerror
, memory_signal_data
);
213 /* Called if we can't allocate relocatable space for a buffer. */
216 buffer_memory_full ()
218 /* If buffers use the relocating allocator,
219 no need to free spare_memory, because we may have plenty of malloc
220 space left that we could get, and if we don't, the malloc that fails
221 will itself cause spare_memory to be freed.
222 If buffers don't use the relocating allocator,
223 treat this like any other failing malloc. */
229 /* This used to call error, but if we've run out of memory, we could get
230 infinite recursion trying to build the string. */
232 Fsignal (Qerror
, memory_signal_data
);
235 /* like malloc routines but check for no memory and block interrupt input. */
244 val
= (long *) malloc (size
);
247 if (!val
&& size
) memory_full ();
252 xrealloc (block
, size
)
259 /* We must call malloc explicitly when BLOCK is 0, since some
260 reallocs don't do this. */
262 val
= (long *) malloc (size
);
264 val
= (long *) realloc (block
, size
);
267 if (!val
&& size
) memory_full ();
281 /* Arranging to disable input signals while we're in malloc.
283 This only works with GNU malloc. To help out systems which can't
284 use GNU malloc, all the calls to malloc, realloc, and free
285 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
286 pairs; unfortunately, we have no idea what C library functions
287 might call malloc, so we can't really protect them unless you're
288 using GNU malloc. Fortunately, most of the major operating can use
291 #ifndef SYSTEM_MALLOC
292 extern void * (*__malloc_hook
) ();
293 static void * (*old_malloc_hook
) ();
294 extern void * (*__realloc_hook
) ();
295 static void * (*old_realloc_hook
) ();
296 extern void (*__free_hook
) ();
297 static void (*old_free_hook
) ();
299 /* This function is used as the hook for free to call. */
302 emacs_blocked_free (ptr
)
306 __free_hook
= old_free_hook
;
308 /* If we released our reserve (due to running out of memory),
309 and we have a fair amount free once again,
310 try to set aside another reserve in case we run out once more. */
311 if (spare_memory
== 0
312 /* Verify there is enough space that even with the malloc
313 hysteresis this call won't run out again.
314 The code here is correct as long as SPARE_MEMORY
315 is substantially larger than the block size malloc uses. */
316 && (bytes_used_when_full
317 > _bytes_used
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
318 spare_memory
= (char *) malloc (SPARE_MEMORY
);
320 __free_hook
= emacs_blocked_free
;
324 /* If we released our reserve (due to running out of memory),
325 and we have a fair amount free once again,
326 try to set aside another reserve in case we run out once more.
328 This is called when a relocatable block is freed in ralloc.c. */
331 refill_memory_reserve ()
333 if (spare_memory
== 0)
334 spare_memory
= (char *) malloc (SPARE_MEMORY
);
337 /* This function is the malloc hook that Emacs uses. */
340 emacs_blocked_malloc (size
)
346 __malloc_hook
= old_malloc_hook
;
347 __malloc_extra_blocks
= malloc_hysteresis
;
348 value
= (void *) malloc (size
);
349 __malloc_hook
= emacs_blocked_malloc
;
356 emacs_blocked_realloc (ptr
, size
)
363 __realloc_hook
= old_realloc_hook
;
364 value
= (void *) realloc (ptr
, size
);
365 __realloc_hook
= emacs_blocked_realloc
;
372 uninterrupt_malloc ()
374 old_free_hook
= __free_hook
;
375 __free_hook
= emacs_blocked_free
;
377 old_malloc_hook
= __malloc_hook
;
378 __malloc_hook
= emacs_blocked_malloc
;
380 old_realloc_hook
= __realloc_hook
;
381 __realloc_hook
= emacs_blocked_realloc
;
385 /* Interval allocation. */
387 #ifdef USE_TEXT_PROPERTIES
388 #define INTERVAL_BLOCK_SIZE \
389 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
391 struct interval_block
393 struct interval_block
*next
;
394 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
397 struct interval_block
*interval_block
;
398 static int interval_block_index
;
400 INTERVAL interval_free_list
;
406 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
407 interval_block
->next
= 0;
408 bzero (interval_block
->intervals
, sizeof interval_block
->intervals
);
409 interval_block_index
= 0;
410 interval_free_list
= 0;
413 #define INIT_INTERVALS init_intervals ()
420 if (interval_free_list
)
422 val
= interval_free_list
;
423 interval_free_list
= interval_free_list
->parent
;
427 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
429 register struct interval_block
*newi
430 = (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
432 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
433 newi
->next
= interval_block
;
434 interval_block
= newi
;
435 interval_block_index
= 0;
437 val
= &interval_block
->intervals
[interval_block_index
++];
439 consing_since_gc
+= sizeof (struct interval
);
440 RESET_INTERVAL (val
);
444 static int total_free_intervals
, total_intervals
;
446 /* Mark the pointers of one interval. */
449 mark_interval (i
, dummy
)
453 if (XMARKBIT (i
->plist
))
455 mark_object (&i
->plist
);
460 mark_interval_tree (tree
)
461 register INTERVAL tree
;
463 /* No need to test if this tree has been marked already; this
464 function is always called through the MARK_INTERVAL_TREE macro,
465 which takes care of that. */
467 /* XMARK expands to an assignment; the LHS of an assignment can't be
469 XMARK (* (Lisp_Object
*) &tree
->parent
);
471 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
474 #define MARK_INTERVAL_TREE(i) \
476 if (!NULL_INTERVAL_P (i) \
477 && ! XMARKBIT ((Lisp_Object) i->parent)) \
478 mark_interval_tree (i); \
481 /* The oddity in the call to XUNMARK is necessary because XUNMARK
482 expands to an assignment to its argument, and most C compilers don't
483 support casts on the left operand of `='. */
484 #define UNMARK_BALANCE_INTERVALS(i) \
486 if (! NULL_INTERVAL_P (i)) \
488 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
489 (i) = balance_intervals (i); \
493 #else /* no interval use */
495 #define INIT_INTERVALS
497 #define UNMARK_BALANCE_INTERVALS(i)
498 #define MARK_INTERVAL_TREE(i)
500 #endif /* no interval use */
502 /* Floating point allocation. */
504 #ifdef LISP_FLOAT_TYPE
505 /* Allocation of float cells, just like conses */
506 /* We store float cells inside of float_blocks, allocating a new
507 float_block with malloc whenever necessary. Float cells reclaimed by
508 GC are put on a free list to be reallocated before allocating
509 any new float cells from the latest float_block.
511 Each float_block is just under 1020 bytes long,
512 since malloc really allocates in units of powers of two
513 and uses 4 bytes for its own overhead. */
515 #define FLOAT_BLOCK_SIZE \
516 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
520 struct float_block
*next
;
521 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
524 struct float_block
*float_block
;
525 int float_block_index
;
527 struct Lisp_Float
*float_free_list
;
532 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
533 float_block
->next
= 0;
534 bzero (float_block
->floats
, sizeof float_block
->floats
);
535 float_block_index
= 0;
539 /* Explicitly free a float cell. */
541 struct Lisp_Float
*ptr
;
543 *(struct Lisp_Float
**)&ptr
->type
= float_free_list
;
544 float_free_list
= ptr
;
548 make_float (float_value
)
551 register Lisp_Object val
;
555 XSETFLOAT (val
, float_free_list
);
556 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->type
;
560 if (float_block_index
== FLOAT_BLOCK_SIZE
)
562 register struct float_block
*new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
563 VALIDATE_LISP_STORAGE (new, sizeof *new);
564 new->next
= float_block
;
566 float_block_index
= 0;
568 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
570 XFLOAT (val
)->data
= float_value
;
571 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
572 consing_since_gc
+= sizeof (struct Lisp_Float
);
576 #endif /* LISP_FLOAT_TYPE */
578 /* Allocation of cons cells */
579 /* We store cons cells inside of cons_blocks, allocating a new
580 cons_block with malloc whenever necessary. Cons cells reclaimed by
581 GC are put on a free list to be reallocated before allocating
582 any new cons cells from the latest cons_block.
584 Each cons_block is just under 1020 bytes long,
585 since malloc really allocates in units of powers of two
586 and uses 4 bytes for its own overhead. */
588 #define CONS_BLOCK_SIZE \
589 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
593 struct cons_block
*next
;
594 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
597 struct cons_block
*cons_block
;
598 int cons_block_index
;
600 struct Lisp_Cons
*cons_free_list
;
605 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
606 cons_block
->next
= 0;
607 bzero (cons_block
->conses
, sizeof cons_block
->conses
);
608 cons_block_index
= 0;
612 /* Explicitly free a cons cell. */
614 struct Lisp_Cons
*ptr
;
616 *(struct Lisp_Cons
**)&ptr
->car
= cons_free_list
;
617 cons_free_list
= ptr
;
620 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
621 "Create a new cons, give it CAR and CDR as components, and return it.")
623 Lisp_Object car
, cdr
;
625 register Lisp_Object val
;
629 XSETCONS (val
, cons_free_list
);
630 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->car
;
634 if (cons_block_index
== CONS_BLOCK_SIZE
)
636 register struct cons_block
*new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
637 VALIDATE_LISP_STORAGE (new, sizeof *new);
638 new->next
= cons_block
;
640 cons_block_index
= 0;
642 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
644 XCONS (val
)->car
= car
;
645 XCONS (val
)->cdr
= cdr
;
646 consing_since_gc
+= sizeof (struct Lisp_Cons
);
650 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
651 "Return a newly created list with specified arguments as elements.\n\
652 Any number of arguments, even zero arguments, are allowed.")
655 register Lisp_Object
*args
;
657 register Lisp_Object len
, val
, val_tail
;
659 XSETFASTINT (len
, nargs
);
660 val
= Fmake_list (len
, Qnil
);
662 while (!NILP (val_tail
))
664 XCONS (val_tail
)->car
= *args
++;
665 val_tail
= XCONS (val_tail
)->cdr
;
670 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
671 "Return a newly created list of length LENGTH, with each element being INIT.")
673 register Lisp_Object length
, init
;
675 register Lisp_Object val
;
678 CHECK_NATNUM (length
, 0);
679 size
= XFASTINT (length
);
683 val
= Fcons (init
, val
);
687 /* Allocation of vectors */
689 struct Lisp_Vector
*all_vectors
;
692 allocate_vectorlike (len
)
695 struct Lisp_Vector
*p
;
697 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
698 + (len
- 1) * sizeof (Lisp_Object
));
699 VALIDATE_LISP_STORAGE (p
, 0);
700 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
701 + (len
- 1) * sizeof (Lisp_Object
));
703 p
->next
= all_vectors
;
708 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
709 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
710 See also the function `vector'.")
712 register Lisp_Object length
, init
;
715 register EMACS_INT sizei
;
717 register struct Lisp_Vector
*p
;
719 CHECK_NATNUM (length
, 0);
720 sizei
= XFASTINT (length
);
722 p
= allocate_vectorlike (sizei
);
724 for (index
= 0; index
< sizei
; index
++)
725 p
->contents
[index
] = init
;
727 XSETVECTOR (vector
, p
);
731 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
732 "Return a newly created vector with specified arguments as elements.\n\
733 Any number of arguments, even zero arguments, are allowed.")
738 register Lisp_Object len
, val
;
740 register struct Lisp_Vector
*p
;
742 XSETFASTINT (len
, nargs
);
743 val
= Fmake_vector (len
, Qnil
);
745 for (index
= 0; index
< nargs
; index
++)
746 p
->contents
[index
] = args
[index
];
750 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
751 "Create a byte-code object with specified arguments as elements.\n\
752 The arguments should be the arglist, bytecode-string, constant vector,\n\
753 stack size, (optional) doc string, and (optional) interactive spec.\n\
754 The first four arguments are required; at most six have any\n\
760 register Lisp_Object len
, val
;
762 register struct Lisp_Vector
*p
;
764 XSETFASTINT (len
, nargs
);
765 if (!NILP (Vpurify_flag
))
766 val
= make_pure_vector (len
);
768 val
= Fmake_vector (len
, Qnil
);
770 for (index
= 0; index
< nargs
; index
++)
772 if (!NILP (Vpurify_flag
))
773 args
[index
] = Fpurecopy (args
[index
]);
774 p
->contents
[index
] = args
[index
];
776 XSETCOMPILED (val
, val
);
780 /* Allocation of symbols.
781 Just like allocation of conses!
783 Each symbol_block is just under 1020 bytes long,
784 since malloc really allocates in units of powers of two
785 and uses 4 bytes for its own overhead. */
787 #define SYMBOL_BLOCK_SIZE \
788 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
792 struct symbol_block
*next
;
793 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
796 struct symbol_block
*symbol_block
;
797 int symbol_block_index
;
799 struct Lisp_Symbol
*symbol_free_list
;
804 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
805 symbol_block
->next
= 0;
806 bzero (symbol_block
->symbols
, sizeof symbol_block
->symbols
);
807 symbol_block_index
= 0;
808 symbol_free_list
= 0;
811 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
812 "Return a newly allocated uninterned symbol whose name is NAME.\n\
813 Its value and function definition are void, and its property list is nil.")
817 register Lisp_Object val
;
818 register struct Lisp_Symbol
*p
;
820 CHECK_STRING (str
, 0);
822 if (symbol_free_list
)
824 XSETSYMBOL (val
, symbol_free_list
);
825 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
829 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
831 struct symbol_block
*new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
832 VALIDATE_LISP_STORAGE (new, sizeof *new);
833 new->next
= symbol_block
;
835 symbol_block_index
= 0;
837 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
840 p
->name
= XSTRING (str
);
843 p
->function
= Qunbound
;
845 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
849 /* Allocation of markers and other objects that share that structure.
850 Works like allocation of conses. */
852 #define MARKER_BLOCK_SIZE \
853 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
857 struct marker_block
*next
;
858 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
861 struct marker_block
*marker_block
;
862 int marker_block_index
;
864 union Lisp_Misc
*marker_free_list
;
869 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
870 marker_block
->next
= 0;
871 bzero (marker_block
->markers
, sizeof marker_block
->markers
);
872 marker_block_index
= 0;
873 marker_free_list
= 0;
876 /* Return a newly allocated Lisp_Misc object, with no substructure. */
882 if (marker_free_list
)
884 XSETMISC (val
, marker_free_list
);
885 marker_free_list
= marker_free_list
->u_free
.chain
;
889 if (marker_block_index
== MARKER_BLOCK_SIZE
)
891 struct marker_block
*new
892 = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
893 VALIDATE_LISP_STORAGE (new, sizeof *new);
894 new->next
= marker_block
;
896 marker_block_index
= 0;
898 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
900 consing_since_gc
+= sizeof (union Lisp_Misc
);
904 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
905 "Return a newly allocated marker which does not point at any place.")
908 register Lisp_Object val
;
909 register struct Lisp_Marker
*p
;
911 val
= allocate_misc ();
912 XMISCTYPE (val
) = Lisp_Misc_Marker
;
920 /* Allocation of strings */
922 /* Strings reside inside of string_blocks. The entire data of the string,
923 both the size and the contents, live in part of the `chars' component of a string_block.
924 The `pos' component is the index within `chars' of the first free byte.
926 first_string_block points to the first string_block ever allocated.
927 Each block points to the next one with its `next' field.
928 The `prev' fields chain in reverse order.
929 The last one allocated is the one currently being filled.
930 current_string_block points to it.
932 The string_blocks that hold individual large strings
933 go in a separate chain, started by large_string_blocks. */
936 /* String blocks contain this many useful bytes.
937 8188 is power of 2, minus 4 for malloc overhead. */
938 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
940 /* A string bigger than this gets its own specially-made string block
941 if it doesn't fit in the current one. */
942 #define STRING_BLOCK_OUTSIZE 1024
944 struct string_block_head
946 struct string_block
*next
, *prev
;
952 struct string_block
*next
, *prev
;
954 char chars
[STRING_BLOCK_SIZE
];
957 /* This points to the string block we are now allocating strings. */
959 struct string_block
*current_string_block
;
961 /* This points to the oldest string block, the one that starts the chain. */
963 struct string_block
*first_string_block
;
965 /* Last string block in chain of those made for individual large strings. */
967 struct string_block
*large_string_blocks
;
969 /* If SIZE is the length of a string, this returns how many bytes
970 the string occupies in a string_block (including padding). */
972 #define STRING_FULLSIZE(size) (((size) + sizeof (struct Lisp_String) + PAD) \
974 #define PAD (sizeof (EMACS_INT))
977 #define STRING_FULLSIZE(SIZE) \
978 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
984 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
985 first_string_block
= current_string_block
;
986 consing_since_gc
+= sizeof (struct string_block
);
987 current_string_block
->next
= 0;
988 current_string_block
->prev
= 0;
989 current_string_block
->pos
= 0;
990 large_string_blocks
= 0;
993 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
994 "Return a newly created string of length LENGTH, with each element being INIT.\n\
995 Both LENGTH and INIT must be numbers.")
997 Lisp_Object length
, init
;
999 register Lisp_Object val
;
1000 register unsigned char *p
, *end
, c
;
1002 CHECK_NATNUM (length
, 0);
1003 CHECK_NUMBER (init
, 1);
1004 val
= make_uninit_string (XFASTINT (length
));
1006 p
= XSTRING (val
)->data
;
1007 end
= p
+ XSTRING (val
)->size
;
1015 make_string (contents
, length
)
1019 register Lisp_Object val
;
1020 val
= make_uninit_string (length
);
1021 bcopy (contents
, XSTRING (val
)->data
, length
);
1029 return make_string (str
, strlen (str
));
1033 make_uninit_string (length
)
1036 register Lisp_Object val
;
1037 register int fullsize
= STRING_FULLSIZE (length
);
1039 if (length
< 0) abort ();
1041 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1042 /* This string can fit in the current string block */
1045 ((struct Lisp_String
*)
1046 (current_string_block
->chars
+ current_string_block
->pos
)));
1047 current_string_block
->pos
+= fullsize
;
1049 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1050 /* This string gets its own string block */
1052 register struct string_block
*new
1053 = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1054 VALIDATE_LISP_STORAGE (new, 0);
1055 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1056 new->pos
= fullsize
;
1057 new->next
= large_string_blocks
;
1058 large_string_blocks
= new;
1060 ((struct Lisp_String
*)
1061 ((struct string_block_head
*)new + 1)));
1064 /* Make a new current string block and start it off with this string */
1066 register struct string_block
*new
1067 = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1068 VALIDATE_LISP_STORAGE (new, sizeof *new);
1069 consing_since_gc
+= sizeof (struct string_block
);
1070 current_string_block
->next
= new;
1071 new->prev
= current_string_block
;
1073 current_string_block
= new;
1074 new->pos
= fullsize
;
1076 (struct Lisp_String
*) current_string_block
->chars
);
1079 XSTRING (val
)->size
= length
;
1080 XSTRING (val
)->data
[length
] = 0;
1081 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1086 /* Return a newly created vector or string with specified arguments as
1087 elements. If all the arguments are characters that can fit
1088 in a string of events, make a string; otherwise, make a vector.
1090 Any number of arguments, even zero arguments, are allowed. */
1093 make_event_array (nargs
, args
)
1099 for (i
= 0; i
< nargs
; i
++)
1100 /* The things that fit in a string
1101 are characters that are in 0...127,
1102 after discarding the meta bit and all the bits above it. */
1103 if (!INTEGERP (args
[i
])
1104 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1105 return Fvector (nargs
, args
);
1107 /* Since the loop exited, we know that all the things in it are
1108 characters, so we can make a string. */
1112 result
= Fmake_string (nargs
, make_number (0));
1113 for (i
= 0; i
< nargs
; i
++)
1115 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1116 /* Move the meta bit to the right place for a string char. */
1117 if (XINT (args
[i
]) & CHAR_META
)
1118 XSTRING (result
)->data
[i
] |= 0x80;
1125 /* Pure storage management. */
1127 /* Must get an error if pure storage is full,
1128 since if it cannot hold a large string
1129 it may be able to hold conses that point to that string;
1130 then the string is not protected from gc. */
1133 make_pure_string (data
, length
)
1137 register Lisp_Object
new;
1138 register int size
= sizeof (EMACS_INT
) + INTERVAL_PTR_SIZE
+ length
+ 1;
1140 if (pureptr
+ size
> PURESIZE
)
1141 error ("Pure Lisp storage exhausted");
1142 XSETSTRING (new, PUREBEG
+ pureptr
);
1143 XSTRING (new)->size
= length
;
1144 bcopy (data
, XSTRING (new)->data
, length
);
1145 XSTRING (new)->data
[length
] = 0;
1147 /* We must give strings in pure storage some kind of interval. So we
1148 give them a null one. */
1149 #if defined (USE_TEXT_PROPERTIES)
1150 XSTRING (new)->intervals
= NULL_INTERVAL
;
1152 pureptr
+= (size
+ sizeof (EMACS_INT
) - 1)
1153 / sizeof (EMACS_INT
) * sizeof (EMACS_INT
);
1158 pure_cons (car
, cdr
)
1159 Lisp_Object car
, cdr
;
1161 register Lisp_Object
new;
1163 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1164 error ("Pure Lisp storage exhausted");
1165 XSETCONS (new, PUREBEG
+ pureptr
);
1166 pureptr
+= sizeof (struct Lisp_Cons
);
1167 XCONS (new)->car
= Fpurecopy (car
);
1168 XCONS (new)->cdr
= Fpurecopy (cdr
);
1172 #ifdef LISP_FLOAT_TYPE
1175 make_pure_float (num
)
1178 register Lisp_Object
new;
1180 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1181 (double) boundary. Some architectures (like the sparc) require
1182 this, and I suspect that floats are rare enough that it's no
1183 tragedy for those that do. */
1186 char *p
= PUREBEG
+ pureptr
;
1190 alignment
= __alignof (struct Lisp_Float
);
1192 alignment
= sizeof (struct Lisp_Float
);
1195 alignment
= sizeof (struct Lisp_Float
);
1197 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1198 pureptr
= p
- PUREBEG
;
1201 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1202 error ("Pure Lisp storage exhausted");
1203 XSETFLOAT (new, PUREBEG
+ pureptr
);
1204 pureptr
+= sizeof (struct Lisp_Float
);
1205 XFLOAT (new)->data
= num
;
1206 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1210 #endif /* LISP_FLOAT_TYPE */
1213 make_pure_vector (len
)
1216 register Lisp_Object
new;
1217 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1219 if (pureptr
+ size
> PURESIZE
)
1220 error ("Pure Lisp storage exhausted");
1222 XSETVECTOR (new, PUREBEG
+ pureptr
);
1224 XVECTOR (new)->size
= len
;
1228 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1229 "Make a copy of OBJECT in pure storage.\n\
1230 Recursively copies contents of vectors and cons cells.\n\
1231 Does not copy symbols.")
1233 register Lisp_Object obj
;
1235 if (NILP (Vpurify_flag
))
1238 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1239 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1243 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1244 #ifdef LISP_FLOAT_TYPE
1245 else if (FLOATP (obj
))
1246 return make_pure_float (XFLOAT (obj
)->data
);
1247 #endif /* LISP_FLOAT_TYPE */
1248 else if (STRINGP (obj
))
1249 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
);
1250 else if (COMPILEDP (obj
) || VECTORP (obj
))
1252 register struct Lisp_Vector
*vec
;
1253 register int i
, size
;
1255 size
= XVECTOR (obj
)->size
;
1256 if (size
& PSEUDOVECTOR_FLAG
)
1257 size
&= PSEUDOVECTOR_SIZE_MASK
;
1258 vec
= XVECTOR (make_pure_vector (size
));
1259 for (i
= 0; i
< size
; i
++)
1260 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1261 if (COMPILEDP (obj
))
1262 XSETCOMPILED (obj
, vec
);
1264 XSETVECTOR (obj
, vec
);
1267 else if (MARKERP (obj
))
1268 error ("Attempt to copy a marker to pure storage");
1273 /* Recording what needs to be marked for gc. */
1275 struct gcpro
*gcprolist
;
1277 #define NSTATICS 768
1279 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1283 /* Put an entry in staticvec, pointing at the variable whose address is given */
1286 staticpro (varaddress
)
1287 Lisp_Object
*varaddress
;
1289 staticvec
[staticidx
++] = varaddress
;
1290 if (staticidx
>= NSTATICS
)
1298 struct catchtag
*next
;
1299 /* jmp_buf jmp; /* We don't need this for GC purposes */
1304 struct backtrace
*next
;
1305 Lisp_Object
*function
;
1306 Lisp_Object
*args
; /* Points to vector of args. */
1307 int nargs
; /* length of vector */
1308 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1312 /* Garbage collection! */
1314 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
1315 int total_free_conses
, total_free_markers
, total_free_symbols
;
1316 #ifdef LISP_FLOAT_TYPE
1317 int total_free_floats
, total_floats
;
1318 #endif /* LISP_FLOAT_TYPE */
1320 /* Temporarily prevent garbage collection. */
1323 inhibit_garbage_collection ()
1325 int count
= specpdl_ptr
- specpdl
;
1327 int nbits
= min (VALBITS
, INTBITS
);
1329 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1331 specbind (Qgc_cons_threshold
, number
);
1336 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1337 "Reclaim storage for Lisp objects no longer needed.\n\
1338 Returns info on amount of space in use:\n\
1339 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1340 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1341 (USED-FLOATS . FREE-FLOATS))\n\
1342 Garbage collection happens automatically if you cons more than\n\
1343 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1346 register struct gcpro
*tail
;
1347 register struct specbinding
*bind
;
1348 struct catchtag
*catch;
1349 struct handler
*handler
;
1350 register struct backtrace
*backlist
;
1351 register Lisp_Object tem
;
1352 char *omessage
= echo_area_glyphs
;
1353 int omessage_length
= echo_area_glyphs_length
;
1354 char stack_top_variable
;
1357 /* In case user calls debug_print during GC,
1358 don't let that cause a recursive GC. */
1359 consing_since_gc
= 0;
1361 /* Save a copy of the contents of the stack, for debugging. */
1362 #if MAX_SAVE_STACK > 0
1363 if (NILP (Vpurify_flag
))
1365 i
= &stack_top_variable
- stack_bottom
;
1367 if (i
< MAX_SAVE_STACK
)
1369 if (stack_copy
== 0)
1370 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1371 else if (stack_copy_size
< i
)
1372 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1375 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1376 bcopy (stack_bottom
, stack_copy
, i
);
1378 bcopy (&stack_top_variable
, stack_copy
, i
);
1382 #endif /* MAX_SAVE_STACK > 0 */
1384 if (!noninteractive
)
1385 message1_nolog ("Garbage collecting...");
1387 /* Don't keep command history around forever */
1388 tem
= Fnthcdr (make_number (30), Vcommand_history
);
1390 XCONS (tem
)->cdr
= Qnil
;
1392 /* Likewise for undo information. */
1394 register struct buffer
*nextb
= all_buffers
;
1398 /* If a buffer's undo list is Qt, that means that undo is
1399 turned off in that buffer. Calling truncate_undo_list on
1400 Qt tends to return NULL, which effectively turns undo back on.
1401 So don't call truncate_undo_list if undo_list is Qt. */
1402 if (! EQ (nextb
->undo_list
, Qt
))
1404 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1406 nextb
= nextb
->next
;
1412 /* clear_marks (); */
1414 /* In each "large string", set the MARKBIT of the size field.
1415 That enables mark_object to recognize them. */
1417 register struct string_block
*b
;
1418 for (b
= large_string_blocks
; b
; b
= b
->next
)
1419 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1422 /* Mark all the special slots that serve as the roots of accessibility.
1424 Usually the special slots to mark are contained in particular structures.
1425 Then we know no slot is marked twice because the structures don't overlap.
1426 In some cases, the structures point to the slots to be marked.
1427 For these, we use MARKBIT to avoid double marking of the slot. */
1429 for (i
= 0; i
< staticidx
; i
++)
1430 mark_object (staticvec
[i
]);
1431 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1432 for (i
= 0; i
< tail
->nvars
; i
++)
1433 if (!XMARKBIT (tail
->var
[i
]))
1435 mark_object (&tail
->var
[i
]);
1436 XMARK (tail
->var
[i
]);
1438 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1440 mark_object (&bind
->symbol
);
1441 mark_object (&bind
->old_value
);
1443 for (catch = catchlist
; catch; catch = catch->next
)
1445 mark_object (&catch->tag
);
1446 mark_object (&catch->val
);
1448 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1450 mark_object (&handler
->handler
);
1451 mark_object (&handler
->var
);
1453 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1455 if (!XMARKBIT (*backlist
->function
))
1457 mark_object (backlist
->function
);
1458 XMARK (*backlist
->function
);
1460 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1463 i
= backlist
->nargs
- 1;
1465 if (!XMARKBIT (backlist
->args
[i
]))
1467 mark_object (&backlist
->args
[i
]);
1468 XMARK (backlist
->args
[i
]);
1475 /* Clear the mark bits that we set in certain root slots. */
1477 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1478 for (i
= 0; i
< tail
->nvars
; i
++)
1479 XUNMARK (tail
->var
[i
]);
1480 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1482 XUNMARK (*backlist
->function
);
1483 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1486 i
= backlist
->nargs
- 1;
1488 XUNMARK (backlist
->args
[i
]);
1490 XUNMARK (buffer_defaults
.name
);
1491 XUNMARK (buffer_local_symbols
.name
);
1493 /* clear_marks (); */
1496 consing_since_gc
= 0;
1497 if (gc_cons_threshold
< 10000)
1498 gc_cons_threshold
= 10000;
1500 if (omessage
|| minibuf_level
> 0)
1501 message2_nolog (omessage
, omessage_length
);
1502 else if (!noninteractive
)
1503 message1_nolog ("Garbage collecting...done");
1505 return Fcons (Fcons (make_number (total_conses
),
1506 make_number (total_free_conses
)),
1507 Fcons (Fcons (make_number (total_symbols
),
1508 make_number (total_free_symbols
)),
1509 Fcons (Fcons (make_number (total_markers
),
1510 make_number (total_free_markers
)),
1511 Fcons (make_number (total_string_size
),
1512 Fcons (make_number (total_vector_size
),
1514 #ifdef LISP_FLOAT_TYPE
1515 Fcons (Fcons (make_number (total_floats
),
1516 make_number (total_free_floats
)),
1518 #else /* not LISP_FLOAT_TYPE */
1520 #endif /* not LISP_FLOAT_TYPE */
1528 /* Clear marks on all conses */
1530 register struct cons_block
*cblk
;
1531 register int lim
= cons_block_index
;
1533 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1536 for (i
= 0; i
< lim
; i
++)
1537 XUNMARK (cblk
->conses
[i
].car
);
1538 lim
= CONS_BLOCK_SIZE
;
1541 /* Clear marks on all symbols */
1543 register struct symbol_block
*sblk
;
1544 register int lim
= symbol_block_index
;
1546 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1549 for (i
= 0; i
< lim
; i
++)
1551 XUNMARK (sblk
->symbols
[i
].plist
);
1553 lim
= SYMBOL_BLOCK_SIZE
;
1556 /* Clear marks on all markers */
1558 register struct marker_block
*sblk
;
1559 register int lim
= marker_block_index
;
1561 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1564 for (i
= 0; i
< lim
; i
++)
1565 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1566 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1567 lim
= MARKER_BLOCK_SIZE
;
1570 /* Clear mark bits on all buffers */
1572 register struct buffer
*nextb
= all_buffers
;
1576 XUNMARK (nextb
->name
);
1577 nextb
= nextb
->next
;
1583 /* Mark reference to a Lisp_Object.
1584 If the object referred to has not been seen yet, recursively mark
1585 all the references contained in it.
1587 If the object referenced is a short string, the referencing slot
1588 is threaded into a chain of such slots, pointed to from
1589 the `size' field of the string. The actual string size
1590 lives in the last slot in the chain. We recognize the end
1591 because it is < (unsigned) STRING_BLOCK_SIZE. */
1593 #define LAST_MARKED_SIZE 500
1594 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1595 int last_marked_index
;
1598 mark_object (objptr
)
1599 Lisp_Object
*objptr
;
1601 register Lisp_Object obj
;
1608 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1609 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1612 last_marked
[last_marked_index
++] = objptr
;
1613 if (last_marked_index
== LAST_MARKED_SIZE
)
1614 last_marked_index
= 0;
1616 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
1620 register struct Lisp_String
*ptr
= XSTRING (obj
);
1622 MARK_INTERVAL_TREE (ptr
->intervals
);
1623 if (ptr
->size
& MARKBIT
)
1624 /* A large string. Just set ARRAY_MARK_FLAG. */
1625 ptr
->size
|= ARRAY_MARK_FLAG
;
1628 /* A small string. Put this reference
1629 into the chain of references to it.
1630 If the address includes MARKBIT, put that bit elsewhere
1631 when we store OBJPTR into the size field. */
1633 if (XMARKBIT (*objptr
))
1635 XSETFASTINT (*objptr
, ptr
->size
);
1639 XSETFASTINT (*objptr
, ptr
->size
);
1641 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
1643 ptr
->size
= (EMACS_INT
) objptr
;
1644 if (ptr
->size
& MARKBIT
)
1645 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
1650 case Lisp_Vectorlike
:
1651 if (GC_BUFFERP (obj
))
1653 if (!XMARKBIT (XBUFFER (obj
)->name
))
1656 else if (GC_SUBRP (obj
))
1658 else if (GC_COMPILEDP (obj
))
1659 /* We could treat this just like a vector, but it is better
1660 to save the COMPILED_CONSTANTS element for last and avoid recursion
1663 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1664 register EMACS_INT size
= ptr
->size
;
1665 /* See comment above under Lisp_Vector. */
1666 struct Lisp_Vector
*volatile ptr1
= ptr
;
1669 if (size
& ARRAY_MARK_FLAG
)
1670 break; /* Already marked */
1671 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1672 size
&= PSEUDOVECTOR_SIZE_MASK
;
1673 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1675 if (i
!= COMPILED_CONSTANTS
)
1676 mark_object (&ptr1
->contents
[i
]);
1678 /* This cast should be unnecessary, but some Mips compiler complains
1679 (MIPS-ABI + SysVR4, DC/OSx, etc). */
1680 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
1684 else if (GC_FRAMEP (obj
))
1686 /* See comment above under Lisp_Vector for why this is volatile. */
1687 register struct frame
*volatile ptr
= XFRAME (obj
);
1688 register EMACS_INT size
= ptr
->size
;
1690 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1691 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1693 mark_object (&ptr
->name
);
1694 mark_object (&ptr
->icon_name
);
1695 mark_object (&ptr
->focus_frame
);
1696 mark_object (&ptr
->selected_window
);
1697 mark_object (&ptr
->minibuffer_window
);
1698 mark_object (&ptr
->param_alist
);
1699 mark_object (&ptr
->scroll_bars
);
1700 mark_object (&ptr
->condemned_scroll_bars
);
1701 mark_object (&ptr
->menu_bar_items
);
1702 mark_object (&ptr
->face_alist
);
1703 mark_object (&ptr
->menu_bar_vector
);
1704 mark_object (&ptr
->buffer_predicate
);
1706 #endif /* MULTI_FRAME */
1709 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
1710 register EMACS_INT size
= ptr
->size
;
1711 /* The reason we use ptr1 is to avoid an apparent hardware bug
1712 that happens occasionally on the FSF's HP 300s.
1713 The bug is that a2 gets clobbered by recursive calls to mark_object.
1714 The clobberage seems to happen during function entry,
1715 perhaps in the moveml instruction.
1716 Yes, this is a crock, but we have to do it. */
1717 struct Lisp_Vector
*volatile ptr1
= ptr
;
1720 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
1721 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
1722 if (size
& PSEUDOVECTOR_FLAG
)
1723 size
&= PSEUDOVECTOR_SIZE_MASK
;
1724 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
1725 mark_object (&ptr1
->contents
[i
]);
1731 /* See comment above under Lisp_Vector for why this is volatile. */
1732 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
1733 struct Lisp_Symbol
*ptrx
;
1735 if (XMARKBIT (ptr
->plist
)) break;
1737 mark_object ((Lisp_Object
*) &ptr
->value
);
1738 mark_object (&ptr
->function
);
1739 mark_object (&ptr
->plist
);
1740 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
1741 mark_object (&ptr
->name
);
1745 /* For the benefit of the last_marked log. */
1746 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
1747 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
1748 XSETSYMBOL (obj
, ptrx
);
1749 /* We can't goto loop here because *objptr doesn't contain an
1750 actual Lisp_Object with valid datatype field. */
1757 switch (XMISCTYPE (obj
))
1759 case Lisp_Misc_Marker
:
1760 XMARK (XMARKER (obj
)->chain
);
1761 /* DO NOT mark thru the marker's chain.
1762 The buffer's markers chain does not preserve markers from gc;
1763 instead, markers are removed from the chain when freed by gc. */
1766 case Lisp_Misc_Buffer_Local_Value
:
1767 case Lisp_Misc_Some_Buffer_Local_Value
:
1769 register struct Lisp_Buffer_Local_Value
*ptr
1770 = XBUFFER_LOCAL_VALUE (obj
);
1771 if (XMARKBIT (ptr
->car
)) break;
1773 /* If the cdr is nil, avoid recursion for the car. */
1774 if (EQ (ptr
->cdr
, Qnil
))
1779 mark_object (&ptr
->car
);
1780 /* See comment above under Lisp_Vector for why not use ptr here. */
1781 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
1785 case Lisp_Misc_Intfwd
:
1786 case Lisp_Misc_Boolfwd
:
1787 case Lisp_Misc_Objfwd
:
1788 case Lisp_Misc_Buffer_Objfwd
:
1789 case Lisp_Misc_Kboard_Objfwd
:
1790 /* Don't bother with Lisp_Buffer_Objfwd,
1791 since all markable slots in current buffer marked anyway. */
1792 /* Don't need to do Lisp_Objfwd, since the places they point
1793 are protected with staticpro. */
1796 case Lisp_Misc_Overlay
:
1798 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
1799 if (!XMARKBIT (ptr
->plist
))
1802 mark_object (&ptr
->start
);
1803 mark_object (&ptr
->end
);
1804 objptr
= &ptr
->plist
;
1817 register struct Lisp_Cons
*ptr
= XCONS (obj
);
1818 if (XMARKBIT (ptr
->car
)) break;
1820 /* If the cdr is nil, avoid recursion for the car. */
1821 if (EQ (ptr
->cdr
, Qnil
))
1826 mark_object (&ptr
->car
);
1827 /* See comment above under Lisp_Vector for why not use ptr here. */
1828 objptr
= &XCONS (obj
)->cdr
;
1832 #ifdef LISP_FLOAT_TYPE
1834 XMARK (XFLOAT (obj
)->type
);
1836 #endif /* LISP_FLOAT_TYPE */
1846 /* Mark the pointers in a buffer structure. */
1852 register struct buffer
*buffer
= XBUFFER (buf
);
1853 register Lisp_Object
*ptr
;
1854 Lisp_Object base_buffer
;
1856 /* This is the buffer's markbit */
1857 mark_object (&buffer
->name
);
1858 XMARK (buffer
->name
);
1860 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
1863 mark_object (buffer
->syntax_table
);
1865 /* Mark the various string-pointers in the buffer object.
1866 Since the strings may be relocated, we must mark them
1867 in their actual slots. So gc_sweep must convert each slot
1868 back to an ordinary C pointer. */
1869 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
1870 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
1871 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
1872 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
1874 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
1875 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
1876 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
1877 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
1880 for (ptr
= &buffer
->name
+ 1;
1881 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
1885 /* If this is an indirect buffer, mark its base buffer. */
1886 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
1888 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
1889 mark_buffer (base_buffer
);
1894 /* Mark the pointers in the kboard objects. */
1901 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
1903 if (kb
->kbd_macro_buffer
)
1904 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
1906 mark_object (&kb
->Vprefix_arg
);
1907 mark_object (&kb
->kbd_queue
);
1908 mark_object (&kb
->Vlast_kbd_macro
);
1909 mark_object (&kb
->Vsystem_key_alist
);
1910 mark_object (&kb
->system_key_syms
);
1914 /* Sweep: find all structures not marked, and free them. */
1919 total_string_size
= 0;
1922 /* Put all unmarked conses on free list */
1924 register struct cons_block
*cblk
;
1925 register int lim
= cons_block_index
;
1926 register int num_free
= 0, num_used
= 0;
1930 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1933 for (i
= 0; i
< lim
; i
++)
1934 if (!XMARKBIT (cblk
->conses
[i
].car
))
1937 *(struct Lisp_Cons
**)&cblk
->conses
[i
].car
= cons_free_list
;
1938 cons_free_list
= &cblk
->conses
[i
];
1943 XUNMARK (cblk
->conses
[i
].car
);
1945 lim
= CONS_BLOCK_SIZE
;
1947 total_conses
= num_used
;
1948 total_free_conses
= num_free
;
1951 #ifdef LISP_FLOAT_TYPE
1952 /* Put all unmarked floats on free list */
1954 register struct float_block
*fblk
;
1955 register int lim
= float_block_index
;
1956 register int num_free
= 0, num_used
= 0;
1958 float_free_list
= 0;
1960 for (fblk
= float_block
; fblk
; fblk
= fblk
->next
)
1963 for (i
= 0; i
< lim
; i
++)
1964 if (!XMARKBIT (fblk
->floats
[i
].type
))
1967 *(struct Lisp_Float
**)&fblk
->floats
[i
].type
= float_free_list
;
1968 float_free_list
= &fblk
->floats
[i
];
1973 XUNMARK (fblk
->floats
[i
].type
);
1975 lim
= FLOAT_BLOCK_SIZE
;
1977 total_floats
= num_used
;
1978 total_free_floats
= num_free
;
1980 #endif /* LISP_FLOAT_TYPE */
1982 #ifdef USE_TEXT_PROPERTIES
1983 /* Put all unmarked intervals on free list */
1985 register struct interval_block
*iblk
;
1986 register int lim
= interval_block_index
;
1987 register int num_free
= 0, num_used
= 0;
1989 interval_free_list
= 0;
1991 for (iblk
= interval_block
; iblk
; iblk
= iblk
->next
)
1995 for (i
= 0; i
< lim
; i
++)
1997 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
1999 iblk
->intervals
[i
].parent
= interval_free_list
;
2000 interval_free_list
= &iblk
->intervals
[i
];
2006 XUNMARK (iblk
->intervals
[i
].plist
);
2009 lim
= INTERVAL_BLOCK_SIZE
;
2011 total_intervals
= num_used
;
2012 total_free_intervals
= num_free
;
2014 #endif /* USE_TEXT_PROPERTIES */
2016 /* Put all unmarked symbols on free list */
2018 register struct symbol_block
*sblk
;
2019 register int lim
= symbol_block_index
;
2020 register int num_free
= 0, num_used
= 0;
2022 symbol_free_list
= 0;
2024 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
2027 for (i
= 0; i
< lim
; i
++)
2028 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2030 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2031 symbol_free_list
= &sblk
->symbols
[i
];
2037 sblk
->symbols
[i
].name
2038 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2039 XUNMARK (sblk
->symbols
[i
].plist
);
2041 lim
= SYMBOL_BLOCK_SIZE
;
2043 total_symbols
= num_used
;
2044 total_free_symbols
= num_free
;
2048 /* Put all unmarked markers on free list.
2049 Dechain each one first from the buffer it points into,
2050 but only if it's a real marker. */
2052 register struct marker_block
*mblk
;
2053 register int lim
= marker_block_index
;
2054 register int num_free
= 0, num_used
= 0;
2056 marker_free_list
= 0;
2058 for (mblk
= marker_block
; mblk
; mblk
= mblk
->next
)
2061 EMACS_INT already_free
= -1;
2063 for (i
= 0; i
< lim
; i
++)
2065 Lisp_Object
*markword
;
2066 switch (mblk
->markers
[i
].u_marker
.type
)
2068 case Lisp_Misc_Marker
:
2069 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2071 case Lisp_Misc_Buffer_Local_Value
:
2072 case Lisp_Misc_Some_Buffer_Local_Value
:
2073 markword
= &mblk
->markers
[i
].u_buffer_local_value
.car
;
2075 case Lisp_Misc_Overlay
:
2076 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2078 case Lisp_Misc_Free
:
2079 /* If the object was already free, keep it
2080 on the free list. */
2081 markword
= &already_free
;
2087 if (markword
&& !XMARKBIT (*markword
))
2090 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2092 /* tem1 avoids Sun compiler bug */
2093 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2094 XSETMARKER (tem
, tem1
);
2095 unchain_marker (tem
);
2097 /* Set the type of the freed object to Lisp_Misc_Free.
2098 We could leave the type alone, since nobody checks it,
2099 but this might catch bugs faster. */
2100 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2101 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2102 marker_free_list
= &mblk
->markers
[i
];
2109 XUNMARK (*markword
);
2112 lim
= MARKER_BLOCK_SIZE
;
2115 total_markers
= num_used
;
2116 total_free_markers
= num_free
;
2119 /* Free all unmarked buffers */
2121 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2124 if (!XMARKBIT (buffer
->name
))
2127 prev
->next
= buffer
->next
;
2129 all_buffers
= buffer
->next
;
2130 next
= buffer
->next
;
2136 XUNMARK (buffer
->name
);
2137 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2140 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2141 for purposes of marking and relocation.
2142 Turn them back into C pointers now. */
2143 buffer
->upcase_table
2144 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2145 buffer
->downcase_table
2146 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2148 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2149 buffer
->folding_sort_table
2150 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2153 prev
= buffer
, buffer
= buffer
->next
;
2157 #endif /* standalone */
2159 /* Free all unmarked vectors */
2161 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2162 total_vector_size
= 0;
2165 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2168 prev
->next
= vector
->next
;
2170 all_vectors
= vector
->next
;
2171 next
= vector
->next
;
2177 vector
->size
&= ~ARRAY_MARK_FLAG
;
2178 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2179 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2181 total_vector_size
+= vector
->size
;
2182 prev
= vector
, vector
= vector
->next
;
2186 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2188 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2189 struct Lisp_String
*s
;
2193 s
= (struct Lisp_String
*) &sb
->chars
[0];
2194 if (s
->size
& ARRAY_MARK_FLAG
)
2196 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2197 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2198 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2199 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2200 prev
= sb
, sb
= sb
->next
;
2205 prev
->next
= sb
->next
;
2207 large_string_blocks
= sb
->next
;
2216 /* Compactify strings, relocate references, and free empty string blocks. */
2221 /* String block of old strings we are scanning. */
2222 register struct string_block
*from_sb
;
2223 /* A preceding string block (or maybe the same one)
2224 where we are copying the still-live strings to. */
2225 register struct string_block
*to_sb
;
2229 to_sb
= first_string_block
;
2232 /* Scan each existing string block sequentially, string by string. */
2233 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2236 /* POS is the index of the next string in the block. */
2237 while (pos
< from_sb
->pos
)
2239 register struct Lisp_String
*nextstr
2240 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2242 register struct Lisp_String
*newaddr
;
2243 register EMACS_INT size
= nextstr
->size
;
2245 /* NEXTSTR is the old address of the next string.
2246 Just skip it if it isn't marked. */
2247 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2249 /* It is marked, so its size field is really a chain of refs.
2250 Find the end of the chain, where the actual size lives. */
2251 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2253 if (size
& DONT_COPY_FLAG
)
2254 size
^= MARKBIT
| DONT_COPY_FLAG
;
2255 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2258 total_string_size
+= size
;
2260 /* If it won't fit in TO_SB, close it out,
2261 and move to the next sb. Keep doing so until
2262 TO_SB reaches a large enough, empty enough string block.
2263 We know that TO_SB cannot advance past FROM_SB here
2264 since FROM_SB is large enough to contain this string.
2265 Any string blocks skipped here
2266 will be patched out and freed later. */
2267 while (to_pos
+ STRING_FULLSIZE (size
)
2268 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2270 to_sb
->pos
= to_pos
;
2271 to_sb
= to_sb
->next
;
2274 /* Compute new address of this string
2275 and update TO_POS for the space being used. */
2276 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2277 to_pos
+= STRING_FULLSIZE (size
);
2279 /* Copy the string itself to the new place. */
2280 if (nextstr
!= newaddr
)
2281 bcopy (nextstr
, newaddr
, size
+ 1 + sizeof (EMACS_INT
)
2282 + INTERVAL_PTR_SIZE
);
2284 /* Go through NEXTSTR's chain of references
2285 and make each slot in the chain point to
2286 the new address of this string. */
2287 size
= newaddr
->size
;
2288 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2290 register Lisp_Object
*objptr
;
2291 if (size
& DONT_COPY_FLAG
)
2292 size
^= MARKBIT
| DONT_COPY_FLAG
;
2293 objptr
= (Lisp_Object
*)size
;
2295 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2296 if (XMARKBIT (*objptr
))
2298 XSETSTRING (*objptr
, newaddr
);
2302 XSETSTRING (*objptr
, newaddr
);
2304 /* Store the actual size in the size field. */
2305 newaddr
->size
= size
;
2307 #ifdef USE_TEXT_PROPERTIES
2308 /* Now that the string has been relocated, rebalance its
2309 interval tree, and update the tree's parent pointer. */
2310 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2312 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2313 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2316 #endif /* USE_TEXT_PROPERTIES */
2318 pos
+= STRING_FULLSIZE (size
);
2322 /* Close out the last string block still used and free any that follow. */
2323 to_sb
->pos
= to_pos
;
2324 current_string_block
= to_sb
;
2326 from_sb
= to_sb
->next
;
2330 to_sb
= from_sb
->next
;
2335 /* Free any empty string blocks further back in the chain.
2336 This loop will never free first_string_block, but it is very
2337 unlikely that that one will become empty, so why bother checking? */
2339 from_sb
= first_string_block
;
2340 while (to_sb
= from_sb
->next
)
2342 if (to_sb
->pos
== 0)
2344 if (from_sb
->next
= to_sb
->next
)
2345 from_sb
->next
->prev
= from_sb
;
2353 /* Debugging aids. */
2355 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2356 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2357 This may be helpful in debugging Emacs's memory usage.\n\
2358 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2363 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2369 /* Initialization */
2373 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2376 pure_size
= PURESIZE
;
2379 ignore_warnings
= 1;
2384 #ifdef LISP_FLOAT_TYPE
2386 #endif /* LISP_FLOAT_TYPE */
2390 malloc_hysteresis
= 32;
2392 malloc_hysteresis
= 0;
2395 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2397 ignore_warnings
= 0;
2400 consing_since_gc
= 0;
2401 gc_cons_threshold
= 300000;
2402 #ifdef VIRT_ADDR_VARIES
2403 malloc_sbrk_unused
= 1<<22; /* A large number */
2404 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2405 #endif /* VIRT_ADDR_VARIES */
2416 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2417 "*Number of bytes of consing between garbage collections.\n\
2418 Garbage collection can happen automatically once this many bytes have been\n\
2419 allocated since the last garbage collection. All data types count.\n\n\
2420 Garbage collection happens automatically only when `eval' is called.\n\n\
2421 By binding this temporarily to a large number, you can effectively\n\
2422 prevent garbage collection during a part of the program.");
2424 DEFVAR_INT ("pure-bytes-used", &pureptr
,
2425 "Number of bytes of sharable Lisp data allocated so far.");
2428 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
2429 "Number of bytes of unshared memory allocated in this session.");
2431 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
2432 "Number of bytes of unshared memory remaining available in this session.");
2435 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
2436 "Non-nil means loading Lisp code in order to dump an executable.\n\
2437 This means that certain objects should be allocated in shared (pure) space.");
2439 DEFVAR_INT ("undo-limit", &undo_limit
,
2440 "Keep no more undo information once it exceeds this size.\n\
2441 This limit is applied when garbage collection happens.\n\
2442 The size is counted as the number of bytes occupied,\n\
2443 which includes both saved text and other data.");
2446 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
2447 "Don't keep more than this much size of undo information.\n\
2448 A command which pushes past this size is itself forgotten.\n\
2449 This limit is applied when garbage collection happens.\n\
2450 The size is counted as the number of bytes occupied,\n\
2451 which includes both saved text and other data.");
2452 undo_strong_limit
= 30000;
2454 /* We build this in advance because if we wait until we need it, we might
2455 not be able to allocate the memory to hold it. */
2457 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
2458 staticpro (&memory_signal_data
);
2460 staticpro (&Qgc_cons_threshold
);
2461 Qgc_cons_threshold
= intern ("gc-cons-threshold");
2466 defsubr (&Smake_byte_code
);
2467 defsubr (&Smake_list
);
2468 defsubr (&Smake_vector
);
2469 defsubr (&Smake_string
);
2470 defsubr (&Smake_symbol
);
2471 defsubr (&Smake_marker
);
2472 defsubr (&Spurecopy
);
2473 defsubr (&Sgarbage_collect
);
2474 defsubr (&Smemory_limit
);