1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 1998
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Note that this declares bzero on OSF/1. How dumb. */
27 #include "intervals.h"
33 #include "blockinput.h"
38 #include "syssignal.h"
42 #ifdef DOUG_LEA_MALLOC
44 #define __malloc_size_t int
46 /* The following come from gmalloc.c. */
48 #if defined (__STDC__) && __STDC__
50 #define __malloc_size_t size_t
52 #define __malloc_size_t unsigned int
54 extern __malloc_size_t _bytes_used
;
55 extern int __malloc_extra_blocks
;
56 #endif /* !defined(DOUG_LEA_MALLOC) */
58 extern Lisp_Object Vhistory_length
;
60 #define max(A,B) ((A) > (B) ? (A) : (B))
61 #define min(A,B) ((A) < (B) ? (A) : (B))
63 /* Macro to verify that storage intended for Lisp objects is not
64 out of range to fit in the space for a pointer.
65 ADDRESS is the start of the block, and SIZE
66 is the amount of space within which objects can start. */
67 #define VALIDATE_LISP_STORAGE(address, size) \
71 XSETCONS (val, (char *) address + size); \
72 if ((char *) XCONS (val) != (char *) address + size) \
79 /* Value of _bytes_used, when spare_memory was freed. */
80 static __malloc_size_t bytes_used_when_full
;
82 /* Number of bytes of consing done since the last gc */
85 /* Count the amount of consing of various sorts of space. */
86 int cons_cells_consed
;
88 int vector_cells_consed
;
90 int string_chars_consed
;
91 int misc_objects_consed
;
94 /* Number of bytes of consing since gc before another gc should be done. */
95 int gc_cons_threshold
;
97 /* Nonzero during gc */
100 /* Nonzero means display messages at beginning and end of GC. */
101 int garbage_collection_messages
;
103 #ifndef VIRT_ADDR_VARIES
105 #endif /* VIRT_ADDR_VARIES */
106 int malloc_sbrk_used
;
108 #ifndef VIRT_ADDR_VARIES
110 #endif /* VIRT_ADDR_VARIES */
111 int malloc_sbrk_unused
;
113 /* Two limits controlling how much undo information to keep. */
115 int undo_strong_limit
;
117 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
118 int total_free_conses
, total_free_markers
, total_free_symbols
;
119 #ifdef LISP_FLOAT_TYPE
120 int total_free_floats
, total_floats
;
121 #endif /* LISP_FLOAT_TYPE */
123 /* Points to memory space allocated as "spare",
124 to be freed if we run out of memory. */
125 static char *spare_memory
;
127 /* Amount of spare memory to keep in reserve. */
128 #define SPARE_MEMORY (1 << 14)
130 /* Number of extra blocks malloc should get when it needs more core. */
131 static int malloc_hysteresis
;
133 /* Nonzero when malloc is called for allocating Lisp object space. */
134 int allocating_for_lisp
;
136 /* Non-nil means defun should do purecopy on the function definition */
137 Lisp_Object Vpurify_flag
;
140 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
141 #define PUREBEG (char *) pure
143 #define pure PURE_SEG_BITS /* Use shared memory segment */
144 #define PUREBEG (char *)PURE_SEG_BITS
146 /* This variable is used only by the XPNTR macro when HAVE_SHM is
147 defined. If we used the PURESIZE macro directly there, that would
148 make most of emacs dependent on puresize.h, which we don't want -
149 you should be able to change that without too much recompilation.
150 So map_in_data initializes pure_size, and the dependencies work
153 #endif /* not HAVE_SHM */
155 /* Index in pure at which next pure object will be allocated. */
158 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
159 char *pending_malloc_warning
;
161 /* Pre-computed signal argument for use when memory is exhausted. */
162 Lisp_Object memory_signal_data
;
164 /* Maximum amount of C stack to save when a GC happens. */
166 #ifndef MAX_SAVE_STACK
167 #define MAX_SAVE_STACK 16000
170 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
171 pointer to a Lisp_Object, when that pointer is viewed as an integer.
172 (On most machines, pointers are even, so we can use the low bit.
173 Word-addressable architectures may need to override this in the m-file.)
174 When linking references to small strings through the size field, we
175 use this slot to hold the bit that would otherwise be interpreted as
177 #ifndef DONT_COPY_FLAG
178 #define DONT_COPY_FLAG 1
179 #endif /* no DONT_COPY_FLAG */
181 /* Buffer in which we save a copy of the C stack at each GC. */
186 /* Non-zero means ignore malloc warnings. Set during initialization. */
189 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
191 static void mark_object (), mark_buffer (), mark_kboards ();
192 static void clear_marks (), gc_sweep ();
193 static void compact_strings ();
195 extern int message_enable_multibyte
;
197 /* Versions of malloc and realloc that print warnings as memory gets full. */
200 malloc_warning_1 (str
)
203 Fprinc (str
, Vstandard_output
);
204 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
205 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
206 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
210 /* malloc calls this if it finds we are near exhausting storage */
216 pending_malloc_warning
= str
;
220 display_malloc_warning ()
222 register Lisp_Object val
;
224 val
= build_string (pending_malloc_warning
);
225 pending_malloc_warning
= 0;
226 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
229 #ifdef DOUG_LEA_MALLOC
230 # define BYTES_USED (mallinfo ().arena)
232 # define BYTES_USED _bytes_used
235 /* Called if malloc returns zero */
240 #ifndef SYSTEM_MALLOC
241 bytes_used_when_full
= BYTES_USED
;
244 /* The first time we get here, free the spare memory. */
251 /* This used to call error, but if we've run out of memory, we could get
252 infinite recursion trying to build the string. */
254 Fsignal (Qnil
, memory_signal_data
);
257 /* Called if we can't allocate relocatable space for a buffer. */
260 buffer_memory_full ()
262 /* If buffers use the relocating allocator,
263 no need to free spare_memory, because we may have plenty of malloc
264 space left that we could get, and if we don't, the malloc that fails
265 will itself cause spare_memory to be freed.
266 If buffers don't use the relocating allocator,
267 treat this like any other failing malloc. */
273 /* This used to call error, but if we've run out of memory, we could get
274 infinite recursion trying to build the string. */
276 Fsignal (Qerror
, memory_signal_data
);
279 /* like malloc routines but check for no memory and block interrupt input. */
288 val
= (long *) malloc (size
);
291 if (!val
&& size
) memory_full ();
296 xrealloc (block
, size
)
303 /* We must call malloc explicitly when BLOCK is 0, since some
304 reallocs don't do this. */
306 val
= (long *) malloc (size
);
308 val
= (long *) realloc (block
, size
);
311 if (!val
&& size
) memory_full ();
325 /* Arranging to disable input signals while we're in malloc.
327 This only works with GNU malloc. To help out systems which can't
328 use GNU malloc, all the calls to malloc, realloc, and free
329 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
330 pairs; unfortunately, we have no idea what C library functions
331 might call malloc, so we can't really protect them unless you're
332 using GNU malloc. Fortunately, most of the major operating can use
335 #ifndef SYSTEM_MALLOC
336 extern void * (*__malloc_hook
) ();
337 static void * (*old_malloc_hook
) ();
338 extern void * (*__realloc_hook
) ();
339 static void * (*old_realloc_hook
) ();
340 extern void (*__free_hook
) ();
341 static void (*old_free_hook
) ();
343 /* This function is used as the hook for free to call. */
346 emacs_blocked_free (ptr
)
350 __free_hook
= old_free_hook
;
352 /* If we released our reserve (due to running out of memory),
353 and we have a fair amount free once again,
354 try to set aside another reserve in case we run out once more. */
355 if (spare_memory
== 0
356 /* Verify there is enough space that even with the malloc
357 hysteresis this call won't run out again.
358 The code here is correct as long as SPARE_MEMORY
359 is substantially larger than the block size malloc uses. */
360 && (bytes_used_when_full
361 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
362 spare_memory
= (char *) malloc (SPARE_MEMORY
);
364 __free_hook
= emacs_blocked_free
;
368 /* If we released our reserve (due to running out of memory),
369 and we have a fair amount free once again,
370 try to set aside another reserve in case we run out once more.
372 This is called when a relocatable block is freed in ralloc.c. */
375 refill_memory_reserve ()
377 if (spare_memory
== 0)
378 spare_memory
= (char *) malloc (SPARE_MEMORY
);
381 /* This function is the malloc hook that Emacs uses. */
384 emacs_blocked_malloc (size
)
390 __malloc_hook
= old_malloc_hook
;
391 #ifdef DOUG_LEA_MALLOC
392 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
394 __malloc_extra_blocks
= malloc_hysteresis
;
396 value
= (void *) malloc (size
);
397 __malloc_hook
= emacs_blocked_malloc
;
404 emacs_blocked_realloc (ptr
, size
)
411 __realloc_hook
= old_realloc_hook
;
412 value
= (void *) realloc (ptr
, size
);
413 __realloc_hook
= emacs_blocked_realloc
;
420 uninterrupt_malloc ()
422 old_free_hook
= __free_hook
;
423 __free_hook
= emacs_blocked_free
;
425 old_malloc_hook
= __malloc_hook
;
426 __malloc_hook
= emacs_blocked_malloc
;
428 old_realloc_hook
= __realloc_hook
;
429 __realloc_hook
= emacs_blocked_realloc
;
433 /* Interval allocation. */
435 #ifdef USE_TEXT_PROPERTIES
436 #define INTERVAL_BLOCK_SIZE \
437 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
439 struct interval_block
441 struct interval_block
*next
;
442 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
445 struct interval_block
*interval_block
;
446 static int interval_block_index
;
448 INTERVAL interval_free_list
;
453 allocating_for_lisp
= 1;
455 = (struct interval_block
*) malloc (sizeof (struct interval_block
));
456 allocating_for_lisp
= 0;
457 interval_block
->next
= 0;
458 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
459 interval_block_index
= 0;
460 interval_free_list
= 0;
463 #define INIT_INTERVALS init_intervals ()
470 if (interval_free_list
)
472 val
= interval_free_list
;
473 interval_free_list
= interval_free_list
->parent
;
477 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
479 register struct interval_block
*newi
;
481 allocating_for_lisp
= 1;
482 newi
= (struct interval_block
*) xmalloc (sizeof (struct interval_block
));
484 allocating_for_lisp
= 0;
485 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
486 newi
->next
= interval_block
;
487 interval_block
= newi
;
488 interval_block_index
= 0;
490 val
= &interval_block
->intervals
[interval_block_index
++];
492 consing_since_gc
+= sizeof (struct interval
);
494 RESET_INTERVAL (val
);
498 static int total_free_intervals
, total_intervals
;
500 /* Mark the pointers of one interval. */
503 mark_interval (i
, dummy
)
507 if (XMARKBIT (i
->plist
))
509 mark_object (&i
->plist
);
514 mark_interval_tree (tree
)
515 register INTERVAL tree
;
517 /* No need to test if this tree has been marked already; this
518 function is always called through the MARK_INTERVAL_TREE macro,
519 which takes care of that. */
521 /* XMARK expands to an assignment; the LHS of an assignment can't be
523 XMARK (* (Lisp_Object
*) &tree
->parent
);
525 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
528 #define MARK_INTERVAL_TREE(i) \
530 if (!NULL_INTERVAL_P (i) \
531 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
532 mark_interval_tree (i); \
535 /* The oddity in the call to XUNMARK is necessary because XUNMARK
536 expands to an assignment to its argument, and most C compilers don't
537 support casts on the left operand of `='. */
538 #define UNMARK_BALANCE_INTERVALS(i) \
540 if (! NULL_INTERVAL_P (i)) \
542 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
543 (i) = balance_intervals (i); \
547 #else /* no interval use */
549 #define INIT_INTERVALS
551 #define UNMARK_BALANCE_INTERVALS(i)
552 #define MARK_INTERVAL_TREE(i)
554 #endif /* no interval use */
556 /* Floating point allocation. */
558 #ifdef LISP_FLOAT_TYPE
559 /* Allocation of float cells, just like conses */
560 /* We store float cells inside of float_blocks, allocating a new
561 float_block with malloc whenever necessary. Float cells reclaimed by
562 GC are put on a free list to be reallocated before allocating
563 any new float cells from the latest float_block.
565 Each float_block is just under 1020 bytes long,
566 since malloc really allocates in units of powers of two
567 and uses 4 bytes for its own overhead. */
569 #define FLOAT_BLOCK_SIZE \
570 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
574 struct float_block
*next
;
575 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
578 struct float_block
*float_block
;
579 int float_block_index
;
581 struct Lisp_Float
*float_free_list
;
586 allocating_for_lisp
= 1;
587 float_block
= (struct float_block
*) malloc (sizeof (struct float_block
));
588 allocating_for_lisp
= 0;
589 float_block
->next
= 0;
590 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
591 float_block_index
= 0;
595 /* Explicitly free a float cell. */
597 struct Lisp_Float
*ptr
;
599 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
600 float_free_list
= ptr
;
604 make_float (float_value
)
607 register Lisp_Object val
;
611 /* We use the data field for chaining the free list
612 so that we won't use the same field that has the mark bit. */
613 XSETFLOAT (val
, float_free_list
);
614 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
618 if (float_block_index
== FLOAT_BLOCK_SIZE
)
620 register struct float_block
*new;
622 allocating_for_lisp
= 1;
623 new = (struct float_block
*) xmalloc (sizeof (struct float_block
));
624 allocating_for_lisp
= 0;
625 VALIDATE_LISP_STORAGE (new, sizeof *new);
626 new->next
= float_block
;
628 float_block_index
= 0;
630 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
632 XFLOAT (val
)->data
= float_value
;
633 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
634 consing_since_gc
+= sizeof (struct Lisp_Float
);
639 #endif /* LISP_FLOAT_TYPE */
641 /* Allocation of cons cells */
642 /* We store cons cells inside of cons_blocks, allocating a new
643 cons_block with malloc whenever necessary. Cons cells reclaimed by
644 GC are put on a free list to be reallocated before allocating
645 any new cons cells from the latest cons_block.
647 Each cons_block is just under 1020 bytes long,
648 since malloc really allocates in units of powers of two
649 and uses 4 bytes for its own overhead. */
651 #define CONS_BLOCK_SIZE \
652 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
656 struct cons_block
*next
;
657 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
660 struct cons_block
*cons_block
;
661 int cons_block_index
;
663 struct Lisp_Cons
*cons_free_list
;
668 allocating_for_lisp
= 1;
669 cons_block
= (struct cons_block
*) malloc (sizeof (struct cons_block
));
670 allocating_for_lisp
= 0;
671 cons_block
->next
= 0;
672 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
673 cons_block_index
= 0;
677 /* Explicitly free a cons cell. */
681 struct Lisp_Cons
*ptr
;
683 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
684 cons_free_list
= ptr
;
687 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
688 "Create a new cons, give it CAR and CDR as components, and return it.")
690 Lisp_Object car
, cdr
;
692 register Lisp_Object val
;
696 /* We use the cdr for chaining the free list
697 so that we won't use the same field that has the mark bit. */
698 XSETCONS (val
, cons_free_list
);
699 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
703 if (cons_block_index
== CONS_BLOCK_SIZE
)
705 register struct cons_block
*new;
706 allocating_for_lisp
= 1;
707 new = (struct cons_block
*) xmalloc (sizeof (struct cons_block
));
708 allocating_for_lisp
= 0;
709 VALIDATE_LISP_STORAGE (new, sizeof *new);
710 new->next
= cons_block
;
712 cons_block_index
= 0;
714 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
716 XCONS (val
)->car
= car
;
717 XCONS (val
)->cdr
= cdr
;
718 consing_since_gc
+= sizeof (struct Lisp_Cons
);
723 /* Make a list of 2, 3, 4 or 5 specified objects. */
727 Lisp_Object arg1
, arg2
;
729 return Fcons (arg1
, Fcons (arg2
, Qnil
));
733 list3 (arg1
, arg2
, arg3
)
734 Lisp_Object arg1
, arg2
, arg3
;
736 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
740 list4 (arg1
, arg2
, arg3
, arg4
)
741 Lisp_Object arg1
, arg2
, arg3
, arg4
;
743 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
747 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
748 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
750 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
751 Fcons (arg5
, Qnil
)))));
754 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
755 "Return a newly created list with specified arguments as elements.\n\
756 Any number of arguments, even zero arguments, are allowed.")
759 register Lisp_Object
*args
;
761 register Lisp_Object val
;
767 val
= Fcons (args
[nargs
], val
);
772 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
773 "Return a newly created list of length LENGTH, with each element being INIT.")
775 register Lisp_Object length
, init
;
777 register Lisp_Object val
;
780 CHECK_NATNUM (length
, 0);
781 size
= XFASTINT (length
);
785 val
= Fcons (init
, val
);
789 /* Allocation of vectors */
791 struct Lisp_Vector
*all_vectors
;
794 allocate_vectorlike (len
)
797 struct Lisp_Vector
*p
;
799 allocating_for_lisp
= 1;
800 #ifdef DOUG_LEA_MALLOC
801 /* Prevent mmap'ing the chunk (which is potentially very large). */
802 mallopt (M_MMAP_MAX
, 0);
804 p
= (struct Lisp_Vector
*)xmalloc (sizeof (struct Lisp_Vector
)
805 + (len
- 1) * sizeof (Lisp_Object
));
806 #ifdef DOUG_LEA_MALLOC
807 /* Back to a reasonable maximum of mmap'ed areas. */
808 mallopt (M_MMAP_MAX
, 64);
810 allocating_for_lisp
= 0;
811 VALIDATE_LISP_STORAGE (p
, 0);
812 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
813 + (len
- 1) * sizeof (Lisp_Object
));
814 vector_cells_consed
+= len
;
816 p
->next
= all_vectors
;
821 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
822 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
823 See also the function `vector'.")
825 register Lisp_Object length
, init
;
828 register EMACS_INT sizei
;
830 register struct Lisp_Vector
*p
;
832 CHECK_NATNUM (length
, 0);
833 sizei
= XFASTINT (length
);
835 p
= allocate_vectorlike (sizei
);
837 for (index
= 0; index
< sizei
; index
++)
838 p
->contents
[index
] = init
;
840 XSETVECTOR (vector
, p
);
844 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
845 "Return a newly created char-table, with purpose PURPOSE.\n\
846 Each element is initialized to INIT, which defaults to nil.\n\
847 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
848 The property's value should be an integer between 0 and 10.")
850 register Lisp_Object purpose
, init
;
854 CHECK_SYMBOL (purpose
, 1);
855 n
= Fget (purpose
, Qchar_table_extra_slots
);
857 if (XINT (n
) < 0 || XINT (n
) > 10)
858 args_out_of_range (n
, Qnil
);
859 /* Add 2 to the size for the defalt and parent slots. */
860 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
862 XCHAR_TABLE (vector
)->top
= Qt
;
863 XCHAR_TABLE (vector
)->parent
= Qnil
;
864 XCHAR_TABLE (vector
)->purpose
= purpose
;
865 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
869 /* Return a newly created sub char table with default value DEFALT.
870 Since a sub char table does not appear as a top level Emacs Lisp
871 object, we don't need a Lisp interface to make it. */
874 make_sub_char_table (defalt
)
878 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
879 XCHAR_TABLE (vector
)->top
= Qnil
;
880 XCHAR_TABLE (vector
)->defalt
= defalt
;
881 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
885 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
886 "Return a newly created vector with specified arguments as elements.\n\
887 Any number of arguments, even zero arguments, are allowed.")
892 register Lisp_Object len
, val
;
894 register struct Lisp_Vector
*p
;
896 XSETFASTINT (len
, nargs
);
897 val
= Fmake_vector (len
, Qnil
);
899 for (index
= 0; index
< nargs
; index
++)
900 p
->contents
[index
] = args
[index
];
904 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
905 "Create a byte-code object with specified arguments as elements.\n\
906 The arguments should be the arglist, bytecode-string, constant vector,\n\
907 stack size, (optional) doc string, and (optional) interactive spec.\n\
908 The first four arguments are required; at most six have any\n\
914 register Lisp_Object len
, val
;
916 register struct Lisp_Vector
*p
;
918 XSETFASTINT (len
, nargs
);
919 if (!NILP (Vpurify_flag
))
920 val
= make_pure_vector ((EMACS_INT
) nargs
);
922 val
= Fmake_vector (len
, Qnil
);
924 for (index
= 0; index
< nargs
; index
++)
926 if (!NILP (Vpurify_flag
))
927 args
[index
] = Fpurecopy (args
[index
]);
928 p
->contents
[index
] = args
[index
];
930 XSETCOMPILED (val
, p
);
934 /* Allocation of symbols.
935 Just like allocation of conses!
937 Each symbol_block is just under 1020 bytes long,
938 since malloc really allocates in units of powers of two
939 and uses 4 bytes for its own overhead. */
941 #define SYMBOL_BLOCK_SIZE \
942 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
946 struct symbol_block
*next
;
947 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
950 struct symbol_block
*symbol_block
;
951 int symbol_block_index
;
953 struct Lisp_Symbol
*symbol_free_list
;
958 allocating_for_lisp
= 1;
959 symbol_block
= (struct symbol_block
*) malloc (sizeof (struct symbol_block
));
960 allocating_for_lisp
= 0;
961 symbol_block
->next
= 0;
962 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
963 symbol_block_index
= 0;
964 symbol_free_list
= 0;
967 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
968 "Return a newly allocated uninterned symbol whose name is NAME.\n\
969 Its value and function definition are void, and its property list is nil.")
973 register Lisp_Object val
;
974 register struct Lisp_Symbol
*p
;
976 CHECK_STRING (name
, 0);
978 if (symbol_free_list
)
980 XSETSYMBOL (val
, symbol_free_list
);
981 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
985 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
987 struct symbol_block
*new;
988 allocating_for_lisp
= 1;
989 new = (struct symbol_block
*) xmalloc (sizeof (struct symbol_block
));
990 allocating_for_lisp
= 0;
991 VALIDATE_LISP_STORAGE (new, sizeof *new);
992 new->next
= symbol_block
;
994 symbol_block_index
= 0;
996 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
999 p
->name
= XSTRING (name
);
1002 p
->value
= Qunbound
;
1003 p
->function
= Qunbound
;
1005 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
1010 /* Allocation of markers and other objects that share that structure.
1011 Works like allocation of conses. */
1013 #define MARKER_BLOCK_SIZE \
1014 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
1018 struct marker_block
*next
;
1019 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
1022 struct marker_block
*marker_block
;
1023 int marker_block_index
;
1025 union Lisp_Misc
*marker_free_list
;
1030 allocating_for_lisp
= 1;
1031 marker_block
= (struct marker_block
*) malloc (sizeof (struct marker_block
));
1032 allocating_for_lisp
= 0;
1033 marker_block
->next
= 0;
1034 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1035 marker_block_index
= 0;
1036 marker_free_list
= 0;
1039 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1045 if (marker_free_list
)
1047 XSETMISC (val
, marker_free_list
);
1048 marker_free_list
= marker_free_list
->u_free
.chain
;
1052 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1054 struct marker_block
*new;
1055 allocating_for_lisp
= 1;
1056 new = (struct marker_block
*) xmalloc (sizeof (struct marker_block
));
1057 allocating_for_lisp
= 0;
1058 VALIDATE_LISP_STORAGE (new, sizeof *new);
1059 new->next
= marker_block
;
1061 marker_block_index
= 0;
1063 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1065 consing_since_gc
+= sizeof (union Lisp_Misc
);
1066 misc_objects_consed
++;
1070 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1071 "Return a newly allocated marker which does not point at any place.")
1074 register Lisp_Object val
;
1075 register struct Lisp_Marker
*p
;
1077 val
= allocate_misc ();
1078 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1084 p
->insertion_type
= 0;
1088 /* Put MARKER back on the free list after using it temporarily. */
1091 free_marker (marker
)
1094 unchain_marker (marker
);
1096 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1097 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1098 marker_free_list
= XMISC (marker
);
1100 total_free_markers
++;
1103 /* Allocation of strings */
1105 /* Strings reside inside of string_blocks. The entire data of the string,
1106 both the size and the contents, live in part of the `chars' component of a string_block.
1107 The `pos' component is the index within `chars' of the first free byte.
1109 first_string_block points to the first string_block ever allocated.
1110 Each block points to the next one with its `next' field.
1111 The `prev' fields chain in reverse order.
1112 The last one allocated is the one currently being filled.
1113 current_string_block points to it.
1115 The string_blocks that hold individual large strings
1116 go in a separate chain, started by large_string_blocks. */
1119 /* String blocks contain this many useful bytes.
1120 8188 is power of 2, minus 4 for malloc overhead. */
1121 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1123 /* A string bigger than this gets its own specially-made string block
1124 if it doesn't fit in the current one. */
1125 #define STRING_BLOCK_OUTSIZE 1024
1127 struct string_block_head
1129 struct string_block
*next
, *prev
;
1135 struct string_block
*next
, *prev
;
1137 char chars
[STRING_BLOCK_SIZE
];
1140 /* This points to the string block we are now allocating strings. */
1142 struct string_block
*current_string_block
;
1144 /* This points to the oldest string block, the one that starts the chain. */
1146 struct string_block
*first_string_block
;
1148 /* Last string block in chain of those made for individual large strings. */
1150 struct string_block
*large_string_blocks
;
1152 /* If SIZE is the length of a string, this returns how many bytes
1153 the string occupies in a string_block (including padding). */
1155 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1156 & ~(STRING_PAD - 1))
1157 /* Add 1 for the null terminator,
1158 and add STRING_PAD - 1 as part of rounding up. */
1160 #define STRING_PAD (sizeof (EMACS_INT))
1161 /* Size of the stuff in the string not including its data. */
1162 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1165 #define STRING_FULLSIZE(SIZE) \
1166 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1172 allocating_for_lisp
= 1;
1173 current_string_block
= (struct string_block
*) malloc (sizeof (struct string_block
));
1174 allocating_for_lisp
= 0;
1175 first_string_block
= current_string_block
;
1176 consing_since_gc
+= sizeof (struct string_block
);
1177 current_string_block
->next
= 0;
1178 current_string_block
->prev
= 0;
1179 current_string_block
->pos
= 0;
1180 large_string_blocks
= 0;
1183 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1184 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1185 Both LENGTH and INIT must be numbers.")
1187 Lisp_Object length
, init
;
1189 register Lisp_Object val
;
1190 register unsigned char *p
, *end
;
1193 CHECK_NATNUM (length
, 0);
1194 CHECK_NUMBER (init
, 1);
1197 if (SINGLE_BYTE_CHAR_P (c
))
1199 nbytes
= XINT (length
);
1200 val
= make_uninit_string (nbytes
);
1201 p
= XSTRING (val
)->data
;
1202 end
= p
+ XSTRING (val
)->size
;
1208 unsigned char work
[4], *str
;
1209 int len
= CHAR_STRING (c
, work
, str
);
1211 nbytes
= len
* XINT (length
);
1212 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1213 p
= XSTRING (val
)->data
;
1217 bcopy (str
, p
, len
);
1225 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1226 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1227 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1229 Lisp_Object length
, init
;
1231 register Lisp_Object val
;
1232 struct Lisp_Bool_Vector
*p
;
1234 int length_in_chars
, length_in_elts
, bits_per_value
;
1236 CHECK_NATNUM (length
, 0);
1238 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1240 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1241 length_in_chars
= length_in_elts
* sizeof (EMACS_INT
);
1243 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1244 slot `size' of the struct Lisp_Bool_Vector. */
1245 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1246 p
= XBOOL_VECTOR (val
);
1247 /* Get rid of any bits that would cause confusion. */
1249 XSETBOOL_VECTOR (val
, p
);
1250 p
->size
= XFASTINT (length
);
1252 real_init
= (NILP (init
) ? 0 : -1);
1253 for (i
= 0; i
< length_in_chars
; i
++)
1254 p
->data
[i
] = real_init
;
1259 /* Make a string from NBYTES bytes at CONTENTS,
1260 and compute the number of characters from the contents.
1261 This string may be unibyte or multibyte, depending on the contents. */
1264 make_string (contents
, nbytes
)
1268 register Lisp_Object val
;
1269 int nchars
= chars_in_text (contents
, nbytes
);
1270 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1271 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1272 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1273 SET_STRING_BYTES (XSTRING (val
), -1);
1277 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
1280 make_unibyte_string (contents
, length
)
1284 register Lisp_Object val
;
1285 val
= make_uninit_string (length
);
1286 bcopy (contents
, XSTRING (val
)->data
, length
);
1287 SET_STRING_BYTES (XSTRING (val
), -1);
1291 /* Make a multibyte string from NCHARS characters
1292 occupying NBYTES bytes at CONTENTS. */
1295 make_multibyte_string (contents
, nchars
, nbytes
)
1299 register Lisp_Object val
;
1300 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1301 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1305 /* Make a string from NCHARS characters
1306 occupying NBYTES bytes at CONTENTS.
1307 It is a multibyte string if NBYTES != NCHARS. */
1310 make_string_from_bytes (contents
, nchars
, nbytes
)
1314 register Lisp_Object val
;
1315 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1316 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1317 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1318 SET_STRING_BYTES (XSTRING (val
), -1);
1322 /* Make a multibyte string from NCHARS characters
1323 occupying NBYTES bytes at CONTENTS. */
1326 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1331 register Lisp_Object val
;
1332 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1333 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1335 SET_STRING_BYTES (XSTRING (val
), -1);
1339 /* Make a string from the data at STR,
1340 treating it as multibyte if the data warrants. */
1346 return make_string (str
, strlen (str
));
1350 make_uninit_string (length
)
1354 val
= make_uninit_multibyte_string (length
, length
);
1355 SET_STRING_BYTES (XSTRING (val
), -1);
1360 make_uninit_multibyte_string (length
, length_byte
)
1361 int length
, length_byte
;
1363 register Lisp_Object val
;
1364 register int fullsize
= STRING_FULLSIZE (length_byte
);
1366 if (length
< 0) abort ();
1368 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1369 /* This string can fit in the current string block */
1372 ((struct Lisp_String
*)
1373 (current_string_block
->chars
+ current_string_block
->pos
)));
1374 current_string_block
->pos
+= fullsize
;
1376 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1377 /* This string gets its own string block */
1379 register struct string_block
*new;
1380 allocating_for_lisp
= 1;
1381 #ifdef DOUG_LEA_MALLOC
1382 /* Prevent mmap'ing the chunk (which is potentially very large). */
1383 mallopt (M_MMAP_MAX
, 0);
1385 new = (struct string_block
*) xmalloc (sizeof (struct string_block_head
) + fullsize
);
1386 #ifdef DOUG_LEA_MALLOC
1387 /* Back to a reasonable maximum of mmap'ed areas. */
1388 mallopt (M_MMAP_MAX
, 64);
1390 allocating_for_lisp
= 0;
1391 VALIDATE_LISP_STORAGE (new, 0);
1392 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1393 new->pos
= fullsize
;
1394 new->next
= large_string_blocks
;
1395 large_string_blocks
= new;
1397 ((struct Lisp_String
*)
1398 ((struct string_block_head
*)new + 1)));
1401 /* Make a new current string block and start it off with this string */
1403 register struct string_block
*new;
1404 allocating_for_lisp
= 1;
1405 new = (struct string_block
*) xmalloc (sizeof (struct string_block
));
1406 allocating_for_lisp
= 0;
1407 VALIDATE_LISP_STORAGE (new, sizeof *new);
1408 consing_since_gc
+= sizeof (struct string_block
);
1409 current_string_block
->next
= new;
1410 new->prev
= current_string_block
;
1412 current_string_block
= new;
1413 new->pos
= fullsize
;
1415 (struct Lisp_String
*) current_string_block
->chars
);
1418 string_chars_consed
+= fullsize
;
1419 XSTRING (val
)->size
= length
;
1420 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1421 XSTRING (val
)->data
[length_byte
] = 0;
1422 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1427 /* Return a newly created vector or string with specified arguments as
1428 elements. If all the arguments are characters that can fit
1429 in a string of events, make a string; otherwise, make a vector.
1431 Any number of arguments, even zero arguments, are allowed. */
1434 make_event_array (nargs
, args
)
1440 for (i
= 0; i
< nargs
; i
++)
1441 /* The things that fit in a string
1442 are characters that are in 0...127,
1443 after discarding the meta bit and all the bits above it. */
1444 if (!INTEGERP (args
[i
])
1445 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1446 return Fvector (nargs
, args
);
1448 /* Since the loop exited, we know that all the things in it are
1449 characters, so we can make a string. */
1453 result
= Fmake_string (make_number (nargs
), make_number (0));
1454 for (i
= 0; i
< nargs
; i
++)
1456 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1457 /* Move the meta bit to the right place for a string char. */
1458 if (XINT (args
[i
]) & CHAR_META
)
1459 XSTRING (result
)->data
[i
] |= 0x80;
1466 /* Pure storage management. */
1468 /* Must get an error if pure storage is full,
1469 since if it cannot hold a large string
1470 it may be able to hold conses that point to that string;
1471 then the string is not protected from gc. */
1474 make_pure_string (data
, length
, length_byte
, multibyte
)
1481 register Lisp_Object
new;
1482 register int size
= STRING_FULLSIZE (length_byte
);
1484 if (pureptr
+ size
> PURESIZE
)
1485 error ("Pure Lisp storage exhausted");
1486 XSETSTRING (new, PUREBEG
+ pureptr
);
1487 XSTRING (new)->size
= length
;
1488 SET_STRING_BYTES (XSTRING (new), (multibyte
? length_byte
: -1));
1489 bcopy (data
, XSTRING (new)->data
, length_byte
);
1490 XSTRING (new)->data
[length_byte
] = 0;
1492 /* We must give strings in pure storage some kind of interval. So we
1493 give them a null one. */
1494 #if defined (USE_TEXT_PROPERTIES)
1495 XSTRING (new)->intervals
= NULL_INTERVAL
;
1502 pure_cons (car
, cdr
)
1503 Lisp_Object car
, cdr
;
1505 register Lisp_Object
new;
1507 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1508 error ("Pure Lisp storage exhausted");
1509 XSETCONS (new, PUREBEG
+ pureptr
);
1510 pureptr
+= sizeof (struct Lisp_Cons
);
1511 XCONS (new)->car
= Fpurecopy (car
);
1512 XCONS (new)->cdr
= Fpurecopy (cdr
);
1516 #ifdef LISP_FLOAT_TYPE
1519 make_pure_float (num
)
1522 register Lisp_Object
new;
1524 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1525 (double) boundary. Some architectures (like the sparc) require
1526 this, and I suspect that floats are rare enough that it's no
1527 tragedy for those that do. */
1530 char *p
= PUREBEG
+ pureptr
;
1534 alignment
= __alignof (struct Lisp_Float
);
1536 alignment
= sizeof (struct Lisp_Float
);
1539 alignment
= sizeof (struct Lisp_Float
);
1541 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1542 pureptr
= p
- PUREBEG
;
1545 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1546 error ("Pure Lisp storage exhausted");
1547 XSETFLOAT (new, PUREBEG
+ pureptr
);
1548 pureptr
+= sizeof (struct Lisp_Float
);
1549 XFLOAT (new)->data
= num
;
1550 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1554 #endif /* LISP_FLOAT_TYPE */
1557 make_pure_vector (len
)
1560 register Lisp_Object
new;
1561 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1563 if (pureptr
+ size
> PURESIZE
)
1564 error ("Pure Lisp storage exhausted");
1566 XSETVECTOR (new, PUREBEG
+ pureptr
);
1568 XVECTOR (new)->size
= len
;
1572 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1573 "Make a copy of OBJECT in pure storage.\n\
1574 Recursively copies contents of vectors and cons cells.\n\
1575 Does not copy symbols.")
1577 register Lisp_Object obj
;
1579 if (NILP (Vpurify_flag
))
1582 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1583 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1587 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1588 #ifdef LISP_FLOAT_TYPE
1589 else if (FLOATP (obj
))
1590 return make_pure_float (XFLOAT (obj
)->data
);
1591 #endif /* LISP_FLOAT_TYPE */
1592 else if (STRINGP (obj
))
1593 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1594 STRING_BYTES (XSTRING (obj
)),
1595 STRING_MULTIBYTE (obj
));
1596 else if (COMPILEDP (obj
) || VECTORP (obj
))
1598 register struct Lisp_Vector
*vec
;
1599 register int i
, size
;
1601 size
= XVECTOR (obj
)->size
;
1602 if (size
& PSEUDOVECTOR_FLAG
)
1603 size
&= PSEUDOVECTOR_SIZE_MASK
;
1604 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1605 for (i
= 0; i
< size
; i
++)
1606 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1607 if (COMPILEDP (obj
))
1608 XSETCOMPILED (obj
, vec
);
1610 XSETVECTOR (obj
, vec
);
1613 else if (MARKERP (obj
))
1614 error ("Attempt to copy a marker to pure storage");
1619 /* Recording what needs to be marked for gc. */
1621 struct gcpro
*gcprolist
;
1623 #define NSTATICS 768
1625 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1629 /* Put an entry in staticvec, pointing at the variable whose address is given */
1632 staticpro (varaddress
)
1633 Lisp_Object
*varaddress
;
1635 staticvec
[staticidx
++] = varaddress
;
1636 if (staticidx
>= NSTATICS
)
1644 struct catchtag
*next
;
1645 #if 0 /* We don't need this for GC purposes */
1652 struct backtrace
*next
;
1653 Lisp_Object
*function
;
1654 Lisp_Object
*args
; /* Points to vector of args. */
1655 int nargs
; /* length of vector */
1656 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1660 /* Garbage collection! */
1662 /* Temporarily prevent garbage collection. */
1665 inhibit_garbage_collection ()
1667 int count
= specpdl_ptr
- specpdl
;
1669 int nbits
= min (VALBITS
, BITS_PER_INT
);
1671 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1673 specbind (Qgc_cons_threshold
, number
);
1678 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1679 "Reclaim storage for Lisp objects no longer needed.\n\
1680 Returns info on amount of space in use:\n\
1681 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1682 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1683 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1684 Garbage collection happens automatically if you cons more than\n\
1685 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1688 register struct gcpro
*tail
;
1689 register struct specbinding
*bind
;
1690 struct catchtag
*catch;
1691 struct handler
*handler
;
1692 register struct backtrace
*backlist
;
1693 register Lisp_Object tem
;
1694 char *omessage
= echo_area_glyphs
;
1695 int omessage_length
= echo_area_glyphs_length
;
1696 int oldmultibyte
= message_enable_multibyte
;
1697 char stack_top_variable
;
1700 /* In case user calls debug_print during GC,
1701 don't let that cause a recursive GC. */
1702 consing_since_gc
= 0;
1704 /* Save a copy of the contents of the stack, for debugging. */
1705 #if MAX_SAVE_STACK > 0
1706 if (NILP (Vpurify_flag
))
1708 i
= &stack_top_variable
- stack_bottom
;
1710 if (i
< MAX_SAVE_STACK
)
1712 if (stack_copy
== 0)
1713 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1714 else if (stack_copy_size
< i
)
1715 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1718 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1719 bcopy (stack_bottom
, stack_copy
, i
);
1721 bcopy (&stack_top_variable
, stack_copy
, i
);
1725 #endif /* MAX_SAVE_STACK > 0 */
1727 if (garbage_collection_messages
)
1728 message1_nolog ("Garbage collecting...");
1730 /* Don't keep command history around forever. */
1731 if (NUMBERP (Vhistory_length
) && XINT (Vhistory_length
) > 0)
1733 tem
= Fnthcdr (Vhistory_length
, Vcommand_history
);
1735 XCONS (tem
)->cdr
= Qnil
;
1738 /* Likewise for undo information. */
1740 register struct buffer
*nextb
= all_buffers
;
1744 /* If a buffer's undo list is Qt, that means that undo is
1745 turned off in that buffer. Calling truncate_undo_list on
1746 Qt tends to return NULL, which effectively turns undo back on.
1747 So don't call truncate_undo_list if undo_list is Qt. */
1748 if (! EQ (nextb
->undo_list
, Qt
))
1750 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1752 nextb
= nextb
->next
;
1758 /* clear_marks (); */
1760 /* In each "large string", set the MARKBIT of the size field.
1761 That enables mark_object to recognize them. */
1763 register struct string_block
*b
;
1764 for (b
= large_string_blocks
; b
; b
= b
->next
)
1765 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1768 /* Mark all the special slots that serve as the roots of accessibility.
1770 Usually the special slots to mark are contained in particular structures.
1771 Then we know no slot is marked twice because the structures don't overlap.
1772 In some cases, the structures point to the slots to be marked.
1773 For these, we use MARKBIT to avoid double marking of the slot. */
1775 for (i
= 0; i
< staticidx
; i
++)
1776 mark_object (staticvec
[i
]);
1777 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1778 for (i
= 0; i
< tail
->nvars
; i
++)
1779 if (!XMARKBIT (tail
->var
[i
]))
1781 mark_object (&tail
->var
[i
]);
1782 XMARK (tail
->var
[i
]);
1784 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1786 mark_object (&bind
->symbol
);
1787 mark_object (&bind
->old_value
);
1789 for (catch = catchlist
; catch; catch = catch->next
)
1791 mark_object (&catch->tag
);
1792 mark_object (&catch->val
);
1794 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1796 mark_object (&handler
->handler
);
1797 mark_object (&handler
->var
);
1799 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1801 if (!XMARKBIT (*backlist
->function
))
1803 mark_object (backlist
->function
);
1804 XMARK (*backlist
->function
);
1806 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1809 i
= backlist
->nargs
- 1;
1811 if (!XMARKBIT (backlist
->args
[i
]))
1813 mark_object (&backlist
->args
[i
]);
1814 XMARK (backlist
->args
[i
]);
1819 /* Look thru every buffer's undo list
1820 for elements that update markers that were not marked,
1823 register struct buffer
*nextb
= all_buffers
;
1827 /* If a buffer's undo list is Qt, that means that undo is
1828 turned off in that buffer. Calling truncate_undo_list on
1829 Qt tends to return NULL, which effectively turns undo back on.
1830 So don't call truncate_undo_list if undo_list is Qt. */
1831 if (! EQ (nextb
->undo_list
, Qt
))
1833 Lisp_Object tail
, prev
;
1834 tail
= nextb
->undo_list
;
1836 while (CONSP (tail
))
1838 if (GC_CONSP (XCONS (tail
)->car
)
1839 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1840 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1843 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1845 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1850 tail
= XCONS (tail
)->cdr
;
1855 nextb
= nextb
->next
;
1861 /* Clear the mark bits that we set in certain root slots. */
1863 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1864 for (i
= 0; i
< tail
->nvars
; i
++)
1865 XUNMARK (tail
->var
[i
]);
1866 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1868 XUNMARK (*backlist
->function
);
1869 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1872 i
= backlist
->nargs
- 1;
1874 XUNMARK (backlist
->args
[i
]);
1876 XUNMARK (buffer_defaults
.name
);
1877 XUNMARK (buffer_local_symbols
.name
);
1879 /* clear_marks (); */
1882 consing_since_gc
= 0;
1883 if (gc_cons_threshold
< 10000)
1884 gc_cons_threshold
= 10000;
1886 if (garbage_collection_messages
)
1888 if (omessage
|| minibuf_level
> 0)
1889 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1891 message1_nolog ("Garbage collecting...done");
1894 return Fcons (Fcons (make_number (total_conses
),
1895 make_number (total_free_conses
)),
1896 Fcons (Fcons (make_number (total_symbols
),
1897 make_number (total_free_symbols
)),
1898 Fcons (Fcons (make_number (total_markers
),
1899 make_number (total_free_markers
)),
1900 Fcons (make_number (total_string_size
),
1901 Fcons (make_number (total_vector_size
),
1903 #ifdef LISP_FLOAT_TYPE
1904 (make_number (total_floats
),
1905 make_number (total_free_floats
)),
1906 #else /* not LISP_FLOAT_TYPE */
1907 (make_number (0), make_number (0)),
1908 #endif /* not LISP_FLOAT_TYPE */
1910 #ifdef USE_TEXT_PROPERTIES
1911 (make_number (total_intervals
),
1912 make_number (total_free_intervals
)),
1913 #else /* not USE_TEXT_PROPERTIES */
1914 (make_number (0), make_number (0)),
1915 #endif /* not USE_TEXT_PROPERTIES */
1923 /* Clear marks on all conses */
1925 register struct cons_block
*cblk
;
1926 register int lim
= cons_block_index
;
1928 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1931 for (i
= 0; i
< lim
; i
++)
1932 XUNMARK (cblk
->conses
[i
].car
);
1933 lim
= CONS_BLOCK_SIZE
;
1936 /* Clear marks on all symbols */
1938 register struct symbol_block
*sblk
;
1939 register int lim
= symbol_block_index
;
1941 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1944 for (i
= 0; i
< lim
; i
++)
1946 XUNMARK (sblk
->symbols
[i
].plist
);
1948 lim
= SYMBOL_BLOCK_SIZE
;
1951 /* Clear marks on all markers */
1953 register struct marker_block
*sblk
;
1954 register int lim
= marker_block_index
;
1956 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
1959 for (i
= 0; i
< lim
; i
++)
1960 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
1961 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
1962 lim
= MARKER_BLOCK_SIZE
;
1965 /* Clear mark bits on all buffers */
1967 register struct buffer
*nextb
= all_buffers
;
1971 XUNMARK (nextb
->name
);
1972 nextb
= nextb
->next
;
1978 /* Mark reference to a Lisp_Object.
1979 If the object referred to has not been seen yet, recursively mark
1980 all the references contained in it.
1982 If the object referenced is a short string, the referencing slot
1983 is threaded into a chain of such slots, pointed to from
1984 the `size' field of the string. The actual string size
1985 lives in the last slot in the chain. We recognize the end
1986 because it is < (unsigned) STRING_BLOCK_SIZE. */
1988 #define LAST_MARKED_SIZE 500
1989 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
1990 int last_marked_index
;
1993 mark_object (argptr
)
1994 Lisp_Object
*argptr
;
1996 Lisp_Object
*objptr
= argptr
;
1997 register Lisp_Object obj
;
2004 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2005 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2008 last_marked
[last_marked_index
++] = objptr
;
2009 if (last_marked_index
== LAST_MARKED_SIZE
)
2010 last_marked_index
= 0;
2012 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2016 register struct Lisp_String
*ptr
= XSTRING (obj
);
2018 MARK_INTERVAL_TREE (ptr
->intervals
);
2019 if (ptr
->size
& MARKBIT
)
2020 /* A large string. Just set ARRAY_MARK_FLAG. */
2021 ptr
->size
|= ARRAY_MARK_FLAG
;
2024 /* A small string. Put this reference
2025 into the chain of references to it.
2026 If the address includes MARKBIT, put that bit elsewhere
2027 when we store OBJPTR into the size field. */
2029 if (XMARKBIT (*objptr
))
2031 XSETFASTINT (*objptr
, ptr
->size
);
2035 XSETFASTINT (*objptr
, ptr
->size
);
2037 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2039 ptr
->size
= (EMACS_INT
) objptr
;
2040 if (ptr
->size
& MARKBIT
)
2041 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2046 case Lisp_Vectorlike
:
2047 if (GC_BUFFERP (obj
))
2049 if (!XMARKBIT (XBUFFER (obj
)->name
))
2052 else if (GC_SUBRP (obj
))
2054 else if (GC_COMPILEDP (obj
))
2055 /* We could treat this just like a vector, but it is better
2056 to save the COMPILED_CONSTANTS element for last and avoid recursion
2059 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2060 register EMACS_INT size
= ptr
->size
;
2061 /* See comment above under Lisp_Vector. */
2062 struct Lisp_Vector
*volatile ptr1
= ptr
;
2065 if (size
& ARRAY_MARK_FLAG
)
2066 break; /* Already marked */
2067 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2068 size
&= PSEUDOVECTOR_SIZE_MASK
;
2069 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2071 if (i
!= COMPILED_CONSTANTS
)
2072 mark_object (&ptr1
->contents
[i
]);
2074 /* This cast should be unnecessary, but some Mips compiler complains
2075 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2076 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2079 else if (GC_FRAMEP (obj
))
2081 /* See comment above under Lisp_Vector for why this is volatile. */
2082 register struct frame
*volatile ptr
= XFRAME (obj
);
2083 register EMACS_INT size
= ptr
->size
;
2085 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2086 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2088 mark_object (&ptr
->name
);
2089 mark_object (&ptr
->icon_name
);
2090 mark_object (&ptr
->title
);
2091 mark_object (&ptr
->focus_frame
);
2092 mark_object (&ptr
->selected_window
);
2093 mark_object (&ptr
->minibuffer_window
);
2094 mark_object (&ptr
->param_alist
);
2095 mark_object (&ptr
->scroll_bars
);
2096 mark_object (&ptr
->condemned_scroll_bars
);
2097 mark_object (&ptr
->menu_bar_items
);
2098 mark_object (&ptr
->face_alist
);
2099 mark_object (&ptr
->menu_bar_vector
);
2100 mark_object (&ptr
->buffer_predicate
);
2101 mark_object (&ptr
->buffer_list
);
2103 else if (GC_BOOL_VECTOR_P (obj
))
2105 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2107 if (ptr
->size
& ARRAY_MARK_FLAG
)
2108 break; /* Already marked */
2109 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2113 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2114 register EMACS_INT size
= ptr
->size
;
2115 /* The reason we use ptr1 is to avoid an apparent hardware bug
2116 that happens occasionally on the FSF's HP 300s.
2117 The bug is that a2 gets clobbered by recursive calls to mark_object.
2118 The clobberage seems to happen during function entry,
2119 perhaps in the moveml instruction.
2120 Yes, this is a crock, but we have to do it. */
2121 struct Lisp_Vector
*volatile ptr1
= ptr
;
2124 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2125 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2126 if (size
& PSEUDOVECTOR_FLAG
)
2127 size
&= PSEUDOVECTOR_SIZE_MASK
;
2128 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2129 mark_object (&ptr1
->contents
[i
]);
2135 /* See comment above under Lisp_Vector for why this is volatile. */
2136 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2137 struct Lisp_Symbol
*ptrx
;
2139 if (XMARKBIT (ptr
->plist
)) break;
2141 mark_object ((Lisp_Object
*) &ptr
->value
);
2142 mark_object (&ptr
->function
);
2143 mark_object (&ptr
->plist
);
2144 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2145 mark_object (&ptr
->name
);
2146 /* Note that we do not mark the obarray of the symbol.
2147 It is safe not to do so because nothing accesses that
2148 slot except to check whether it is nil. */
2152 /* For the benefit of the last_marked log. */
2153 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2154 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2155 XSETSYMBOL (obj
, ptrx
);
2156 /* We can't goto loop here because *objptr doesn't contain an
2157 actual Lisp_Object with valid datatype field. */
2164 switch (XMISCTYPE (obj
))
2166 case Lisp_Misc_Marker
:
2167 XMARK (XMARKER (obj
)->chain
);
2168 /* DO NOT mark thru the marker's chain.
2169 The buffer's markers chain does not preserve markers from gc;
2170 instead, markers are removed from the chain when freed by gc. */
2173 case Lisp_Misc_Buffer_Local_Value
:
2174 case Lisp_Misc_Some_Buffer_Local_Value
:
2176 register struct Lisp_Buffer_Local_Value
*ptr
2177 = XBUFFER_LOCAL_VALUE (obj
);
2178 if (XMARKBIT (ptr
->realvalue
)) break;
2179 XMARK (ptr
->realvalue
);
2180 /* If the cdr is nil, avoid recursion for the car. */
2181 if (EQ (ptr
->cdr
, Qnil
))
2183 objptr
= &ptr
->realvalue
;
2186 mark_object (&ptr
->realvalue
);
2187 mark_object (&ptr
->buffer
);
2188 mark_object (&ptr
->frame
);
2189 /* See comment above under Lisp_Vector for why not use ptr here. */
2190 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2194 case Lisp_Misc_Intfwd
:
2195 case Lisp_Misc_Boolfwd
:
2196 case Lisp_Misc_Objfwd
:
2197 case Lisp_Misc_Buffer_Objfwd
:
2198 case Lisp_Misc_Kboard_Objfwd
:
2199 /* Don't bother with Lisp_Buffer_Objfwd,
2200 since all markable slots in current buffer marked anyway. */
2201 /* Don't need to do Lisp_Objfwd, since the places they point
2202 are protected with staticpro. */
2205 case Lisp_Misc_Overlay
:
2207 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2208 if (!XMARKBIT (ptr
->plist
))
2211 mark_object (&ptr
->start
);
2212 mark_object (&ptr
->end
);
2213 objptr
= &ptr
->plist
;
2226 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2227 if (XMARKBIT (ptr
->car
)) break;
2229 /* If the cdr is nil, avoid recursion for the car. */
2230 if (EQ (ptr
->cdr
, Qnil
))
2235 mark_object (&ptr
->car
);
2236 /* See comment above under Lisp_Vector for why not use ptr here. */
2237 objptr
= &XCONS (obj
)->cdr
;
2241 #ifdef LISP_FLOAT_TYPE
2243 XMARK (XFLOAT (obj
)->type
);
2245 #endif /* LISP_FLOAT_TYPE */
2255 /* Mark the pointers in a buffer structure. */
2261 register struct buffer
*buffer
= XBUFFER (buf
);
2262 register Lisp_Object
*ptr
;
2263 Lisp_Object base_buffer
;
2265 /* This is the buffer's markbit */
2266 mark_object (&buffer
->name
);
2267 XMARK (buffer
->name
);
2269 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2271 if (CONSP (buffer
->undo_list
))
2274 tail
= buffer
->undo_list
;
2276 while (CONSP (tail
))
2278 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2280 if (XMARKBIT (ptr
->car
))
2283 if (GC_CONSP (ptr
->car
)
2284 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2285 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2287 XMARK (XCONS (ptr
->car
)->car
);
2288 mark_object (&XCONS (ptr
->car
)->cdr
);
2291 mark_object (&ptr
->car
);
2293 if (CONSP (ptr
->cdr
))
2299 mark_object (&XCONS (tail
)->cdr
);
2302 mark_object (&buffer
->undo_list
);
2305 mark_object (buffer
->syntax_table
);
2307 /* Mark the various string-pointers in the buffer object.
2308 Since the strings may be relocated, we must mark them
2309 in their actual slots. So gc_sweep must convert each slot
2310 back to an ordinary C pointer. */
2311 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2312 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2313 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2314 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2316 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2317 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2318 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2319 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2322 for (ptr
= &buffer
->name
+ 1;
2323 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2327 /* If this is an indirect buffer, mark its base buffer. */
2328 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2330 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2331 mark_buffer (base_buffer
);
2336 /* Mark the pointers in the kboard objects. */
2343 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2345 if (kb
->kbd_macro_buffer
)
2346 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2348 mark_object (&kb
->Vprefix_arg
);
2349 mark_object (&kb
->kbd_queue
);
2350 mark_object (&kb
->Vlast_kbd_macro
);
2351 mark_object (&kb
->Vsystem_key_alist
);
2352 mark_object (&kb
->system_key_syms
);
2356 /* Sweep: find all structures not marked, and free them. */
2361 total_string_size
= 0;
2364 /* Put all unmarked conses on free list */
2366 register struct cons_block
*cblk
;
2367 struct cons_block
**cprev
= &cons_block
;
2368 register int lim
= cons_block_index
;
2369 register int num_free
= 0, num_used
= 0;
2373 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2377 for (i
= 0; i
< lim
; i
++)
2378 if (!XMARKBIT (cblk
->conses
[i
].car
))
2382 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2383 cons_free_list
= &cblk
->conses
[i
];
2388 XUNMARK (cblk
->conses
[i
].car
);
2390 lim
= CONS_BLOCK_SIZE
;
2391 /* If this block contains only free conses and we have already
2392 seen more than two blocks worth of free conses then deallocate
2394 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> 2*CONS_BLOCK_SIZE
)
2396 num_free
-= CONS_BLOCK_SIZE
;
2397 *cprev
= cblk
->next
;
2398 /* Unhook from the free list. */
2399 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2403 cprev
= &cblk
->next
;
2405 total_conses
= num_used
;
2406 total_free_conses
= num_free
;
2409 #ifdef LISP_FLOAT_TYPE
2410 /* Put all unmarked floats on free list */
2412 register struct float_block
*fblk
;
2413 struct float_block
**fprev
= &float_block
;
2414 register int lim
= float_block_index
;
2415 register int num_free
= 0, num_used
= 0;
2417 float_free_list
= 0;
2419 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2423 for (i
= 0; i
< lim
; i
++)
2424 if (!XMARKBIT (fblk
->floats
[i
].type
))
2428 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2429 float_free_list
= &fblk
->floats
[i
];
2434 XUNMARK (fblk
->floats
[i
].type
);
2436 lim
= FLOAT_BLOCK_SIZE
;
2437 /* If this block contains only free floats and we have already
2438 seen more than two blocks worth of free floats then deallocate
2440 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> 2*FLOAT_BLOCK_SIZE
)
2442 num_free
-= FLOAT_BLOCK_SIZE
;
2443 *fprev
= fblk
->next
;
2444 /* Unhook from the free list. */
2445 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2449 fprev
= &fblk
->next
;
2451 total_floats
= num_used
;
2452 total_free_floats
= num_free
;
2454 #endif /* LISP_FLOAT_TYPE */
2456 #ifdef USE_TEXT_PROPERTIES
2457 /* Put all unmarked intervals on free list */
2459 register struct interval_block
*iblk
;
2460 struct interval_block
**iprev
= &interval_block
;
2461 register int lim
= interval_block_index
;
2462 register int num_free
= 0, num_used
= 0;
2464 interval_free_list
= 0;
2466 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2471 for (i
= 0; i
< lim
; i
++)
2473 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2475 iblk
->intervals
[i
].parent
= interval_free_list
;
2476 interval_free_list
= &iblk
->intervals
[i
];
2483 XUNMARK (iblk
->intervals
[i
].plist
);
2486 lim
= INTERVAL_BLOCK_SIZE
;
2487 /* If this block contains only free intervals and we have already
2488 seen more than two blocks worth of free intervals then
2489 deallocate this block. */
2490 if (this_free
== INTERVAL_BLOCK_SIZE
2491 && num_free
> 2*INTERVAL_BLOCK_SIZE
)
2493 num_free
-= INTERVAL_BLOCK_SIZE
;
2494 *iprev
= iblk
->next
;
2495 /* Unhook from the free list. */
2496 interval_free_list
= iblk
->intervals
[0].parent
;
2500 iprev
= &iblk
->next
;
2502 total_intervals
= num_used
;
2503 total_free_intervals
= num_free
;
2505 #endif /* USE_TEXT_PROPERTIES */
2507 /* Put all unmarked symbols on free list */
2509 register struct symbol_block
*sblk
;
2510 struct symbol_block
**sprev
= &symbol_block
;
2511 register int lim
= symbol_block_index
;
2512 register int num_free
= 0, num_used
= 0;
2514 symbol_free_list
= 0;
2516 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2520 for (i
= 0; i
< lim
; i
++)
2521 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2523 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2524 symbol_free_list
= &sblk
->symbols
[i
];
2531 sblk
->symbols
[i
].name
2532 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2533 XUNMARK (sblk
->symbols
[i
].plist
);
2535 lim
= SYMBOL_BLOCK_SIZE
;
2536 /* If this block contains only free symbols and we have already
2537 seen more than two blocks worth of free symbols then deallocate
2539 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> 2*SYMBOL_BLOCK_SIZE
)
2541 num_free
-= SYMBOL_BLOCK_SIZE
;
2542 *sprev
= sblk
->next
;
2543 /* Unhook from the free list. */
2544 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2548 sprev
= &sblk
->next
;
2550 total_symbols
= num_used
;
2551 total_free_symbols
= num_free
;
2555 /* Put all unmarked misc's on free list.
2556 For a marker, first unchain it from the buffer it points into. */
2558 register struct marker_block
*mblk
;
2559 struct marker_block
**mprev
= &marker_block
;
2560 register int lim
= marker_block_index
;
2561 register int num_free
= 0, num_used
= 0;
2563 marker_free_list
= 0;
2565 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2569 EMACS_INT already_free
= -1;
2571 for (i
= 0; i
< lim
; i
++)
2573 Lisp_Object
*markword
;
2574 switch (mblk
->markers
[i
].u_marker
.type
)
2576 case Lisp_Misc_Marker
:
2577 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2579 case Lisp_Misc_Buffer_Local_Value
:
2580 case Lisp_Misc_Some_Buffer_Local_Value
:
2581 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2583 case Lisp_Misc_Overlay
:
2584 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2586 case Lisp_Misc_Free
:
2587 /* If the object was already free, keep it
2588 on the free list. */
2589 markword
= (Lisp_Object
*) &already_free
;
2595 if (markword
&& !XMARKBIT (*markword
))
2598 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2600 /* tem1 avoids Sun compiler bug */
2601 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2602 XSETMARKER (tem
, tem1
);
2603 unchain_marker (tem
);
2605 /* Set the type of the freed object to Lisp_Misc_Free.
2606 We could leave the type alone, since nobody checks it,
2607 but this might catch bugs faster. */
2608 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2609 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2610 marker_free_list
= &mblk
->markers
[i
];
2618 XUNMARK (*markword
);
2621 lim
= MARKER_BLOCK_SIZE
;
2622 /* If this block contains only free markers and we have already
2623 seen more than two blocks worth of free markers then deallocate
2625 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> 2*MARKER_BLOCK_SIZE
)
2627 num_free
-= MARKER_BLOCK_SIZE
;
2628 *mprev
= mblk
->next
;
2629 /* Unhook from the free list. */
2630 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2634 mprev
= &mblk
->next
;
2637 total_markers
= num_used
;
2638 total_free_markers
= num_free
;
2641 /* Free all unmarked buffers */
2643 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2646 if (!XMARKBIT (buffer
->name
))
2649 prev
->next
= buffer
->next
;
2651 all_buffers
= buffer
->next
;
2652 next
= buffer
->next
;
2658 XUNMARK (buffer
->name
);
2659 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2662 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2663 for purposes of marking and relocation.
2664 Turn them back into C pointers now. */
2665 buffer
->upcase_table
2666 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2667 buffer
->downcase_table
2668 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2670 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2671 buffer
->folding_sort_table
2672 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2675 prev
= buffer
, buffer
= buffer
->next
;
2679 #endif /* standalone */
2681 /* Free all unmarked vectors */
2683 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2684 total_vector_size
= 0;
2687 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2690 prev
->next
= vector
->next
;
2692 all_vectors
= vector
->next
;
2693 next
= vector
->next
;
2699 vector
->size
&= ~ARRAY_MARK_FLAG
;
2700 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2701 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2703 total_vector_size
+= vector
->size
;
2704 prev
= vector
, vector
= vector
->next
;
2708 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2710 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2711 struct Lisp_String
*s
;
2715 s
= (struct Lisp_String
*) &sb
->chars
[0];
2716 if (s
->size
& ARRAY_MARK_FLAG
)
2718 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2719 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2720 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2721 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2722 prev
= sb
, sb
= sb
->next
;
2727 prev
->next
= sb
->next
;
2729 large_string_blocks
= sb
->next
;
2738 /* Compactify strings, relocate references, and free empty string blocks. */
2743 /* String block of old strings we are scanning. */
2744 register struct string_block
*from_sb
;
2745 /* A preceding string block (or maybe the same one)
2746 where we are copying the still-live strings to. */
2747 register struct string_block
*to_sb
;
2751 to_sb
= first_string_block
;
2754 /* Scan each existing string block sequentially, string by string. */
2755 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2758 /* POS is the index of the next string in the block. */
2759 while (pos
< from_sb
->pos
)
2761 register struct Lisp_String
*nextstr
2762 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2764 register struct Lisp_String
*newaddr
;
2765 register EMACS_INT size
= nextstr
->size
;
2766 EMACS_INT size_byte
= nextstr
->size_byte
;
2768 /* NEXTSTR is the old address of the next string.
2769 Just skip it if it isn't marked. */
2770 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2772 /* It is marked, so its size field is really a chain of refs.
2773 Find the end of the chain, where the actual size lives. */
2774 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2776 if (size
& DONT_COPY_FLAG
)
2777 size
^= MARKBIT
| DONT_COPY_FLAG
;
2778 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2784 total_string_size
+= size_byte
;
2786 /* If it won't fit in TO_SB, close it out,
2787 and move to the next sb. Keep doing so until
2788 TO_SB reaches a large enough, empty enough string block.
2789 We know that TO_SB cannot advance past FROM_SB here
2790 since FROM_SB is large enough to contain this string.
2791 Any string blocks skipped here
2792 will be patched out and freed later. */
2793 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2794 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2796 to_sb
->pos
= to_pos
;
2797 to_sb
= to_sb
->next
;
2800 /* Compute new address of this string
2801 and update TO_POS for the space being used. */
2802 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2803 to_pos
+= STRING_FULLSIZE (size_byte
);
2805 /* Copy the string itself to the new place. */
2806 if (nextstr
!= newaddr
)
2807 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2809 /* Go through NEXTSTR's chain of references
2810 and make each slot in the chain point to
2811 the new address of this string. */
2812 size
= newaddr
->size
;
2813 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2815 register Lisp_Object
*objptr
;
2816 if (size
& DONT_COPY_FLAG
)
2817 size
^= MARKBIT
| DONT_COPY_FLAG
;
2818 objptr
= (Lisp_Object
*)size
;
2820 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2821 if (XMARKBIT (*objptr
))
2823 XSETSTRING (*objptr
, newaddr
);
2827 XSETSTRING (*objptr
, newaddr
);
2829 /* Store the actual size in the size field. */
2830 newaddr
->size
= size
;
2832 #ifdef USE_TEXT_PROPERTIES
2833 /* Now that the string has been relocated, rebalance its
2834 interval tree, and update the tree's parent pointer. */
2835 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2837 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2838 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2841 #endif /* USE_TEXT_PROPERTIES */
2843 else if (size_byte
< 0)
2846 pos
+= STRING_FULLSIZE (size_byte
);
2850 /* Close out the last string block still used and free any that follow. */
2851 to_sb
->pos
= to_pos
;
2852 current_string_block
= to_sb
;
2854 from_sb
= to_sb
->next
;
2858 to_sb
= from_sb
->next
;
2863 /* Free any empty string blocks further back in the chain.
2864 This loop will never free first_string_block, but it is very
2865 unlikely that that one will become empty, so why bother checking? */
2867 from_sb
= first_string_block
;
2868 while (to_sb
= from_sb
->next
)
2870 if (to_sb
->pos
== 0)
2872 if (from_sb
->next
= to_sb
->next
)
2873 from_sb
->next
->prev
= from_sb
;
2881 /* Debugging aids. */
2883 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2884 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2885 This may be helpful in debugging Emacs's memory usage.\n\
2886 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2891 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2896 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2897 "Return a list of counters that measure how much consing there has been.\n\
2898 Each of these counters increments for a certain kind of object.\n\
2899 The counters wrap around from the largest positive integer to zero.\n\
2900 Garbage collection does not decrease them.\n\
2901 The elements of the value are as follows:\n\
2902 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2903 All are in units of 1 = one object consed\n\
2904 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2906 MISCS include overlays, markers, and some internal types.\n\
2907 Frames, windows, buffers, and subprocesses count as vectors\n\
2908 (but the contents of a buffer's text do not count here).")
2911 Lisp_Object lisp_cons_cells_consed
;
2912 Lisp_Object lisp_floats_consed
;
2913 Lisp_Object lisp_vector_cells_consed
;
2914 Lisp_Object lisp_symbols_consed
;
2915 Lisp_Object lisp_string_chars_consed
;
2916 Lisp_Object lisp_misc_objects_consed
;
2917 Lisp_Object lisp_intervals_consed
;
2919 XSETINT (lisp_cons_cells_consed
,
2920 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2921 XSETINT (lisp_floats_consed
,
2922 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2923 XSETINT (lisp_vector_cells_consed
,
2924 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2925 XSETINT (lisp_symbols_consed
,
2926 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2927 XSETINT (lisp_string_chars_consed
,
2928 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2929 XSETINT (lisp_misc_objects_consed
,
2930 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2931 XSETINT (lisp_intervals_consed
,
2932 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2934 return Fcons (lisp_cons_cells_consed
,
2935 Fcons (lisp_floats_consed
,
2936 Fcons (lisp_vector_cells_consed
,
2937 Fcons (lisp_symbols_consed
,
2938 Fcons (lisp_string_chars_consed
,
2939 Fcons (lisp_misc_objects_consed
,
2940 Fcons (lisp_intervals_consed
,
2944 /* Initialization */
2948 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
2951 pure_size
= PURESIZE
;
2954 ignore_warnings
= 1;
2955 #ifdef DOUG_LEA_MALLOC
2956 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
2957 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
2958 mallopt (M_MMAP_MAX
, 64); /* max. number of mmap'ed areas */
2964 #ifdef LISP_FLOAT_TYPE
2966 #endif /* LISP_FLOAT_TYPE */
2970 malloc_hysteresis
= 32;
2972 malloc_hysteresis
= 0;
2975 spare_memory
= (char *) malloc (SPARE_MEMORY
);
2977 ignore_warnings
= 0;
2980 consing_since_gc
= 0;
2981 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
2982 #ifdef VIRT_ADDR_VARIES
2983 malloc_sbrk_unused
= 1<<22; /* A large number */
2984 malloc_sbrk_used
= 100000; /* as reasonable as any number */
2985 #endif /* VIRT_ADDR_VARIES */
2996 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
2997 "*Number of bytes of consing between garbage collections.\n\
2998 Garbage collection can happen automatically once this many bytes have been\n\
2999 allocated since the last garbage collection. All data types count.\n\n\
3000 Garbage collection happens automatically only when `eval' is called.\n\n\
3001 By binding this temporarily to a large number, you can effectively\n\
3002 prevent garbage collection during a part of the program.");
3004 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3005 "Number of bytes of sharable Lisp data allocated so far.");
3007 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3008 "Number of cons cells that have been consed so far.");
3010 DEFVAR_INT ("floats-consed", &floats_consed
,
3011 "Number of floats that have been consed so far.");
3013 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3014 "Number of vector cells that have been consed so far.");
3016 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3017 "Number of symbols that have been consed so far.");
3019 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3020 "Number of string characters that have been consed so far.");
3022 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3023 "Number of miscellaneous objects that have been consed so far.");
3025 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3026 "Number of intervals that have been consed so far.");
3029 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3030 "Number of bytes of unshared memory allocated in this session.");
3032 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3033 "Number of bytes of unshared memory remaining available in this session.");
3036 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3037 "Non-nil means loading Lisp code in order to dump an executable.\n\
3038 This means that certain objects should be allocated in shared (pure) space.");
3040 DEFVAR_INT ("undo-limit", &undo_limit
,
3041 "Keep no more undo information once it exceeds this size.\n\
3042 This limit is applied when garbage collection happens.\n\
3043 The size is counted as the number of bytes occupied,\n\
3044 which includes both saved text and other data.");
3047 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3048 "Don't keep more than this much size of undo information.\n\
3049 A command which pushes past this size is itself forgotten.\n\
3050 This limit is applied when garbage collection happens.\n\
3051 The size is counted as the number of bytes occupied,\n\
3052 which includes both saved text and other data.");
3053 undo_strong_limit
= 30000;
3055 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3056 "Non-nil means display messages at start and end of garbage collection.");
3057 garbage_collection_messages
= 0;
3059 /* We build this in advance because if we wait until we need it, we might
3060 not be able to allocate the memory to hold it. */
3062 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3063 staticpro (&memory_signal_data
);
3065 staticpro (&Qgc_cons_threshold
);
3066 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3068 staticpro (&Qchar_table_extra_slots
);
3069 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3074 defsubr (&Smake_byte_code
);
3075 defsubr (&Smake_list
);
3076 defsubr (&Smake_vector
);
3077 defsubr (&Smake_char_table
);
3078 defsubr (&Smake_string
);
3079 defsubr (&Smake_bool_vector
);
3080 defsubr (&Smake_symbol
);
3081 defsubr (&Smake_marker
);
3082 defsubr (&Spurecopy
);
3083 defsubr (&Sgarbage_collect
);
3084 defsubr (&Smemory_limit
);
3085 defsubr (&Smemory_use_counts
);