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 /* Specify maximum number of areas to mmap.
47 It would be nice to use a value that explicitly
49 #define MMAP_MAX_AREAS 100000000
52 /* The following come from gmalloc.c. */
54 #if defined (__STDC__) && __STDC__
56 #define __malloc_size_t size_t
58 #define __malloc_size_t unsigned int
60 extern __malloc_size_t _bytes_used
;
61 extern int __malloc_extra_blocks
;
62 #endif /* !defined(DOUG_LEA_MALLOC) */
64 #define max(A,B) ((A) > (B) ? (A) : (B))
65 #define min(A,B) ((A) < (B) ? (A) : (B))
67 /* Macro to verify that storage intended for Lisp objects is not
68 out of range to fit in the space for a pointer.
69 ADDRESS is the start of the block, and SIZE
70 is the amount of space within which objects can start. */
71 #define VALIDATE_LISP_STORAGE(address, size) \
75 XSETCONS (val, (char *) address + size); \
76 if ((char *) XCONS (val) != (char *) address + size) \
83 /* Value of _bytes_used, when spare_memory was freed. */
84 static __malloc_size_t bytes_used_when_full
;
86 /* Number of bytes of consing done since the last gc */
89 /* Count the amount of consing of various sorts of space. */
90 int cons_cells_consed
;
92 int vector_cells_consed
;
94 int string_chars_consed
;
95 int misc_objects_consed
;
98 /* Number of bytes of consing since gc before another gc should be done. */
99 int gc_cons_threshold
;
101 /* Nonzero during gc */
104 /* Nonzero means display messages at beginning and end of GC. */
105 int garbage_collection_messages
;
107 #ifndef VIRT_ADDR_VARIES
109 #endif /* VIRT_ADDR_VARIES */
110 int malloc_sbrk_used
;
112 #ifndef VIRT_ADDR_VARIES
114 #endif /* VIRT_ADDR_VARIES */
115 int malloc_sbrk_unused
;
117 /* Two limits controlling how much undo information to keep. */
119 int undo_strong_limit
;
121 int total_conses
, total_markers
, total_symbols
, total_string_size
, total_vector_size
;
122 int total_free_conses
, total_free_markers
, total_free_symbols
;
123 #ifdef LISP_FLOAT_TYPE
124 int total_free_floats
, total_floats
;
125 #endif /* LISP_FLOAT_TYPE */
127 /* Points to memory space allocated as "spare",
128 to be freed if we run out of memory. */
129 static char *spare_memory
;
131 /* Amount of spare memory to keep in reserve. */
132 #define SPARE_MEMORY (1 << 14)
134 /* Number of extra blocks malloc should get when it needs more core. */
135 static int malloc_hysteresis
;
137 /* Nonzero when malloc is called for allocating Lisp object space. */
138 int allocating_for_lisp
;
140 /* Non-nil means defun should do purecopy on the function definition */
141 Lisp_Object Vpurify_flag
;
144 EMACS_INT pure
[PURESIZE
/ sizeof (EMACS_INT
)] = {0,}; /* Force it into data space! */
145 #define PUREBEG (char *) pure
147 #define pure PURE_SEG_BITS /* Use shared memory segment */
148 #define PUREBEG (char *)PURE_SEG_BITS
150 /* This variable is used only by the XPNTR macro when HAVE_SHM is
151 defined. If we used the PURESIZE macro directly there, that would
152 make most of emacs dependent on puresize.h, which we don't want -
153 you should be able to change that without too much recompilation.
154 So map_in_data initializes pure_size, and the dependencies work
157 #endif /* not HAVE_SHM */
159 /* Index in pure at which next pure object will be allocated. */
162 /* If nonzero, this is a warning delivered by malloc and not yet displayed. */
163 char *pending_malloc_warning
;
165 /* Pre-computed signal argument for use when memory is exhausted. */
166 Lisp_Object memory_signal_data
;
168 /* Maximum amount of C stack to save when a GC happens. */
170 #ifndef MAX_SAVE_STACK
171 #define MAX_SAVE_STACK 16000
174 /* Define DONT_COPY_FLAG to be some bit which will always be zero in a
175 pointer to a Lisp_Object, when that pointer is viewed as an integer.
176 (On most machines, pointers are even, so we can use the low bit.
177 Word-addressable architectures may need to override this in the m-file.)
178 When linking references to small strings through the size field, we
179 use this slot to hold the bit that would otherwise be interpreted as
181 #ifndef DONT_COPY_FLAG
182 #define DONT_COPY_FLAG 1
183 #endif /* no DONT_COPY_FLAG */
185 /* Buffer in which we save a copy of the C stack at each GC. */
190 /* Non-zero means ignore malloc warnings. Set during initialization. */
193 Lisp_Object Qgc_cons_threshold
, Qchar_table_extra_slots
;
195 static void mark_object (), mark_buffer (), mark_kboards ();
196 static void clear_marks (), gc_sweep ();
197 static void compact_strings ();
199 extern int message_enable_multibyte
;
201 /* Versions of malloc and realloc that print warnings as memory gets full. */
204 malloc_warning_1 (str
)
207 Fprinc (str
, Vstandard_output
);
208 write_string ("\nKilling some buffers may delay running out of memory.\n", -1);
209 write_string ("However, certainly by the time you receive the 95% warning,\n", -1);
210 write_string ("you should clean up, kill this Emacs, and start a new one.", -1);
214 /* malloc calls this if it finds we are near exhausting storage */
220 pending_malloc_warning
= str
;
224 display_malloc_warning ()
226 register Lisp_Object val
;
228 val
= build_string (pending_malloc_warning
);
229 pending_malloc_warning
= 0;
230 internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1
, val
);
233 #ifdef DOUG_LEA_MALLOC
234 # define BYTES_USED (mallinfo ().arena)
236 # define BYTES_USED _bytes_used
239 /* Called if malloc returns zero */
244 #ifndef SYSTEM_MALLOC
245 bytes_used_when_full
= BYTES_USED
;
248 /* The first time we get here, free the spare memory. */
255 /* This used to call error, but if we've run out of memory, we could get
256 infinite recursion trying to build the string. */
258 Fsignal (Qnil
, memory_signal_data
);
261 /* Called if we can't allocate relocatable space for a buffer. */
264 buffer_memory_full ()
266 /* If buffers use the relocating allocator,
267 no need to free spare_memory, because we may have plenty of malloc
268 space left that we could get, and if we don't, the malloc that fails
269 will itself cause spare_memory to be freed.
270 If buffers don't use the relocating allocator,
271 treat this like any other failing malloc. */
277 /* This used to call error, but if we've run out of memory, we could get
278 infinite recursion trying to build the string. */
280 Fsignal (Qerror
, memory_signal_data
);
283 /* Like malloc routines but check for no memory and block interrupt input. */
292 val
= (long *) malloc (size
);
295 if (!val
&& size
) memory_full ();
300 xrealloc (block
, size
)
307 /* We must call malloc explicitly when BLOCK is 0, since some
308 reallocs don't do this. */
310 val
= (long *) malloc (size
);
312 val
= (long *) realloc (block
, size
);
315 if (!val
&& size
) memory_full ();
328 /* Like malloc but used for allocating Lisp data. */
337 allocating_for_lisp
++;
338 val
= (long *) malloc (size
);
339 allocating_for_lisp
--;
342 if (!val
&& size
) memory_full ();
351 allocating_for_lisp
++;
353 allocating_for_lisp
--;
357 /* Arranging to disable input signals while we're in malloc.
359 This only works with GNU malloc. To help out systems which can't
360 use GNU malloc, all the calls to malloc, realloc, and free
361 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
362 pairs; unfortunately, we have no idea what C library functions
363 might call malloc, so we can't really protect them unless you're
364 using GNU malloc. Fortunately, most of the major operating can use
367 #ifndef SYSTEM_MALLOC
368 extern void * (*__malloc_hook
) ();
369 static void * (*old_malloc_hook
) ();
370 extern void * (*__realloc_hook
) ();
371 static void * (*old_realloc_hook
) ();
372 extern void (*__free_hook
) ();
373 static void (*old_free_hook
) ();
375 /* This function is used as the hook for free to call. */
378 emacs_blocked_free (ptr
)
382 __free_hook
= old_free_hook
;
384 /* If we released our reserve (due to running out of memory),
385 and we have a fair amount free once again,
386 try to set aside another reserve in case we run out once more. */
387 if (spare_memory
== 0
388 /* Verify there is enough space that even with the malloc
389 hysteresis this call won't run out again.
390 The code here is correct as long as SPARE_MEMORY
391 is substantially larger than the block size malloc uses. */
392 && (bytes_used_when_full
393 > BYTES_USED
+ max (malloc_hysteresis
, 4) * SPARE_MEMORY
))
394 spare_memory
= (char *) malloc (SPARE_MEMORY
);
396 __free_hook
= emacs_blocked_free
;
400 /* If we released our reserve (due to running out of memory),
401 and we have a fair amount free once again,
402 try to set aside another reserve in case we run out once more.
404 This is called when a relocatable block is freed in ralloc.c. */
407 refill_memory_reserve ()
409 if (spare_memory
== 0)
410 spare_memory
= (char *) malloc (SPARE_MEMORY
);
413 /* This function is the malloc hook that Emacs uses. */
416 emacs_blocked_malloc (size
)
422 __malloc_hook
= old_malloc_hook
;
423 #ifdef DOUG_LEA_MALLOC
424 mallopt (M_TOP_PAD
, malloc_hysteresis
* 4096);
426 __malloc_extra_blocks
= malloc_hysteresis
;
428 value
= (void *) malloc (size
);
429 __malloc_hook
= emacs_blocked_malloc
;
436 emacs_blocked_realloc (ptr
, size
)
443 __realloc_hook
= old_realloc_hook
;
444 value
= (void *) realloc (ptr
, size
);
445 __realloc_hook
= emacs_blocked_realloc
;
452 uninterrupt_malloc ()
454 if (__free_hook
!= emacs_blocked_free
)
455 old_free_hook
= __free_hook
;
456 __free_hook
= emacs_blocked_free
;
458 if (__malloc_hook
!= emacs_blocked_malloc
)
459 old_malloc_hook
= __malloc_hook
;
460 __malloc_hook
= emacs_blocked_malloc
;
462 if (__realloc_hook
!= emacs_blocked_realloc
)
463 old_realloc_hook
= __realloc_hook
;
464 __realloc_hook
= emacs_blocked_realloc
;
468 /* Interval allocation. */
470 #ifdef USE_TEXT_PROPERTIES
471 #define INTERVAL_BLOCK_SIZE \
472 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
474 struct interval_block
476 struct interval_block
*next
;
477 struct interval intervals
[INTERVAL_BLOCK_SIZE
];
480 struct interval_block
*interval_block
;
481 static int interval_block_index
;
483 INTERVAL interval_free_list
;
485 /* Total number of interval blocks now in use. */
486 int n_interval_blocks
;
492 = (struct interval_block
*) lisp_malloc (sizeof (struct interval_block
));
493 interval_block
->next
= 0;
494 bzero ((char *) interval_block
->intervals
, sizeof interval_block
->intervals
);
495 interval_block_index
= 0;
496 interval_free_list
= 0;
497 n_interval_blocks
= 1;
500 #define INIT_INTERVALS init_intervals ()
507 if (interval_free_list
)
509 val
= interval_free_list
;
510 interval_free_list
= interval_free_list
->parent
;
514 if (interval_block_index
== INTERVAL_BLOCK_SIZE
)
516 register struct interval_block
*newi
;
518 newi
= (struct interval_block
*) lisp_malloc (sizeof (struct interval_block
));
520 VALIDATE_LISP_STORAGE (newi
, sizeof *newi
);
521 newi
->next
= interval_block
;
522 interval_block
= newi
;
523 interval_block_index
= 0;
526 val
= &interval_block
->intervals
[interval_block_index
++];
528 consing_since_gc
+= sizeof (struct interval
);
530 RESET_INTERVAL (val
);
534 static int total_free_intervals
, total_intervals
;
536 /* Mark the pointers of one interval. */
539 mark_interval (i
, dummy
)
543 if (XMARKBIT (i
->plist
))
545 mark_object (&i
->plist
);
550 mark_interval_tree (tree
)
551 register INTERVAL tree
;
553 /* No need to test if this tree has been marked already; this
554 function is always called through the MARK_INTERVAL_TREE macro,
555 which takes care of that. */
557 /* XMARK expands to an assignment; the LHS of an assignment can't be
559 XMARK (* (Lisp_Object
*) &tree
->parent
);
561 traverse_intervals (tree
, 1, 0, mark_interval
, Qnil
);
564 #define MARK_INTERVAL_TREE(i) \
566 if (!NULL_INTERVAL_P (i) \
567 && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
568 mark_interval_tree (i); \
571 /* The oddity in the call to XUNMARK is necessary because XUNMARK
572 expands to an assignment to its argument, and most C compilers don't
573 support casts on the left operand of `='. */
574 #define UNMARK_BALANCE_INTERVALS(i) \
576 if (! NULL_INTERVAL_P (i)) \
578 XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
579 (i) = balance_intervals (i); \
583 #else /* no interval use */
585 #define INIT_INTERVALS
587 #define UNMARK_BALANCE_INTERVALS(i)
588 #define MARK_INTERVAL_TREE(i)
590 #endif /* no interval use */
592 /* Floating point allocation. */
594 #ifdef LISP_FLOAT_TYPE
595 /* Allocation of float cells, just like conses */
596 /* We store float cells inside of float_blocks, allocating a new
597 float_block with malloc whenever necessary. Float cells reclaimed by
598 GC are put on a free list to be reallocated before allocating
599 any new float cells from the latest float_block.
601 Each float_block is just under 1020 bytes long,
602 since malloc really allocates in units of powers of two
603 and uses 4 bytes for its own overhead. */
605 #define FLOAT_BLOCK_SIZE \
606 ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
610 struct float_block
*next
;
611 struct Lisp_Float floats
[FLOAT_BLOCK_SIZE
];
614 struct float_block
*float_block
;
615 int float_block_index
;
617 /* Total number of float blocks now in use. */
620 struct Lisp_Float
*float_free_list
;
625 float_block
= (struct float_block
*) lisp_malloc (sizeof (struct float_block
));
626 float_block
->next
= 0;
627 bzero ((char *) float_block
->floats
, sizeof float_block
->floats
);
628 float_block_index
= 0;
633 /* Explicitly free a float cell. */
636 struct Lisp_Float
*ptr
;
638 *(struct Lisp_Float
**)&ptr
->data
= float_free_list
;
639 float_free_list
= ptr
;
643 make_float (float_value
)
646 register Lisp_Object val
;
650 /* We use the data field for chaining the free list
651 so that we won't use the same field that has the mark bit. */
652 XSETFLOAT (val
, float_free_list
);
653 float_free_list
= *(struct Lisp_Float
**)&float_free_list
->data
;
657 if (float_block_index
== FLOAT_BLOCK_SIZE
)
659 register struct float_block
*new;
661 new = (struct float_block
*) lisp_malloc (sizeof (struct float_block
));
662 VALIDATE_LISP_STORAGE (new, sizeof *new);
663 new->next
= float_block
;
665 float_block_index
= 0;
668 XSETFLOAT (val
, &float_block
->floats
[float_block_index
++]);
670 XFLOAT (val
)->data
= float_value
;
671 XSETFASTINT (XFLOAT (val
)->type
, 0); /* bug chasing -wsr */
672 consing_since_gc
+= sizeof (struct Lisp_Float
);
677 #endif /* LISP_FLOAT_TYPE */
679 /* Allocation of cons cells */
680 /* We store cons cells inside of cons_blocks, allocating a new
681 cons_block with malloc whenever necessary. Cons cells reclaimed by
682 GC are put on a free list to be reallocated before allocating
683 any new cons cells from the latest cons_block.
685 Each cons_block is just under 1020 bytes long,
686 since malloc really allocates in units of powers of two
687 and uses 4 bytes for its own overhead. */
689 #define CONS_BLOCK_SIZE \
690 ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
694 struct cons_block
*next
;
695 struct Lisp_Cons conses
[CONS_BLOCK_SIZE
];
698 struct cons_block
*cons_block
;
699 int cons_block_index
;
701 struct Lisp_Cons
*cons_free_list
;
703 /* Total number of cons blocks now in use. */
709 cons_block
= (struct cons_block
*) lisp_malloc (sizeof (struct cons_block
));
710 cons_block
->next
= 0;
711 bzero ((char *) cons_block
->conses
, sizeof cons_block
->conses
);
712 cons_block_index
= 0;
717 /* Explicitly free a cons cell. */
721 struct Lisp_Cons
*ptr
;
723 *(struct Lisp_Cons
**)&ptr
->cdr
= cons_free_list
;
724 cons_free_list
= ptr
;
727 DEFUN ("cons", Fcons
, Scons
, 2, 2, 0,
728 "Create a new cons, give it CAR and CDR as components, and return it.")
730 Lisp_Object car
, cdr
;
732 register Lisp_Object val
;
736 /* We use the cdr for chaining the free list
737 so that we won't use the same field that has the mark bit. */
738 XSETCONS (val
, cons_free_list
);
739 cons_free_list
= *(struct Lisp_Cons
**)&cons_free_list
->cdr
;
743 if (cons_block_index
== CONS_BLOCK_SIZE
)
745 register struct cons_block
*new;
746 new = (struct cons_block
*) lisp_malloc (sizeof (struct cons_block
));
747 VALIDATE_LISP_STORAGE (new, sizeof *new);
748 new->next
= cons_block
;
750 cons_block_index
= 0;
753 XSETCONS (val
, &cons_block
->conses
[cons_block_index
++]);
755 XCONS (val
)->car
= car
;
756 XCONS (val
)->cdr
= cdr
;
757 consing_since_gc
+= sizeof (struct Lisp_Cons
);
762 /* Make a list of 2, 3, 4 or 5 specified objects. */
766 Lisp_Object arg1
, arg2
;
768 return Fcons (arg1
, Fcons (arg2
, Qnil
));
772 list3 (arg1
, arg2
, arg3
)
773 Lisp_Object arg1
, arg2
, arg3
;
775 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Qnil
)));
779 list4 (arg1
, arg2
, arg3
, arg4
)
780 Lisp_Object arg1
, arg2
, arg3
, arg4
;
782 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
, Qnil
))));
786 list5 (arg1
, arg2
, arg3
, arg4
, arg5
)
787 Lisp_Object arg1
, arg2
, arg3
, arg4
, arg5
;
789 return Fcons (arg1
, Fcons (arg2
, Fcons (arg3
, Fcons (arg4
,
790 Fcons (arg5
, Qnil
)))));
793 DEFUN ("list", Flist
, Slist
, 0, MANY
, 0,
794 "Return a newly created list with specified arguments as elements.\n\
795 Any number of arguments, even zero arguments, are allowed.")
798 register Lisp_Object
*args
;
800 register Lisp_Object val
;
806 val
= Fcons (args
[nargs
], val
);
811 DEFUN ("make-list", Fmake_list
, Smake_list
, 2, 2, 0,
812 "Return a newly created list of length LENGTH, with each element being INIT.")
814 register Lisp_Object length
, init
;
816 register Lisp_Object val
;
819 CHECK_NATNUM (length
, 0);
820 size
= XFASTINT (length
);
824 val
= Fcons (init
, val
);
828 /* Allocation of vectors */
830 struct Lisp_Vector
*all_vectors
;
832 /* Total number of vectorlike objects now in use. */
836 allocate_vectorlike (len
)
839 struct Lisp_Vector
*p
;
841 #ifdef DOUG_LEA_MALLOC
842 /* Prevent mmap'ing the chunk (which is potentially very large). */
843 mallopt (M_MMAP_MAX
, 0);
845 p
= (struct Lisp_Vector
*)lisp_malloc (sizeof (struct Lisp_Vector
)
846 + (len
- 1) * sizeof (Lisp_Object
));
847 #ifdef DOUG_LEA_MALLOC
848 /* Back to a reasonable maximum of mmap'ed areas. */
849 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
851 VALIDATE_LISP_STORAGE (p
, 0);
852 consing_since_gc
+= (sizeof (struct Lisp_Vector
)
853 + (len
- 1) * sizeof (Lisp_Object
));
854 vector_cells_consed
+= len
;
857 p
->next
= all_vectors
;
862 DEFUN ("make-vector", Fmake_vector
, Smake_vector
, 2, 2, 0,
863 "Return a newly created vector of length LENGTH, with each element being INIT.\n\
864 See also the function `vector'.")
866 register Lisp_Object length
, init
;
869 register EMACS_INT sizei
;
871 register struct Lisp_Vector
*p
;
873 CHECK_NATNUM (length
, 0);
874 sizei
= XFASTINT (length
);
876 p
= allocate_vectorlike (sizei
);
878 for (index
= 0; index
< sizei
; index
++)
879 p
->contents
[index
] = init
;
881 XSETVECTOR (vector
, p
);
885 DEFUN ("make-char-table", Fmake_char_table
, Smake_char_table
, 1, 2, 0,
886 "Return a newly created char-table, with purpose PURPOSE.\n\
887 Each element is initialized to INIT, which defaults to nil.\n\
888 PURPOSE should be a symbol which has a `char-table-extra-slots' property.\n\
889 The property's value should be an integer between 0 and 10.")
891 register Lisp_Object purpose
, init
;
895 CHECK_SYMBOL (purpose
, 1);
896 n
= Fget (purpose
, Qchar_table_extra_slots
);
898 if (XINT (n
) < 0 || XINT (n
) > 10)
899 args_out_of_range (n
, Qnil
);
900 /* Add 2 to the size for the defalt and parent slots. */
901 vector
= Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS
+ XINT (n
)),
903 XCHAR_TABLE (vector
)->top
= Qt
;
904 XCHAR_TABLE (vector
)->parent
= Qnil
;
905 XCHAR_TABLE (vector
)->purpose
= purpose
;
906 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
910 /* Return a newly created sub char table with default value DEFALT.
911 Since a sub char table does not appear as a top level Emacs Lisp
912 object, we don't need a Lisp interface to make it. */
915 make_sub_char_table (defalt
)
919 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS
), Qnil
);
920 XCHAR_TABLE (vector
)->top
= Qnil
;
921 XCHAR_TABLE (vector
)->defalt
= defalt
;
922 XSETCHAR_TABLE (vector
, XCHAR_TABLE (vector
));
926 DEFUN ("vector", Fvector
, Svector
, 0, MANY
, 0,
927 "Return a newly created vector with specified arguments as elements.\n\
928 Any number of arguments, even zero arguments, are allowed.")
933 register Lisp_Object len
, val
;
935 register struct Lisp_Vector
*p
;
937 XSETFASTINT (len
, nargs
);
938 val
= Fmake_vector (len
, Qnil
);
940 for (index
= 0; index
< nargs
; index
++)
941 p
->contents
[index
] = args
[index
];
945 DEFUN ("make-byte-code", Fmake_byte_code
, Smake_byte_code
, 4, MANY
, 0,
946 "Create a byte-code object with specified arguments as elements.\n\
947 The arguments should be the arglist, bytecode-string, constant vector,\n\
948 stack size, (optional) doc string, and (optional) interactive spec.\n\
949 The first four arguments are required; at most six have any\n\
955 register Lisp_Object len
, val
;
957 register struct Lisp_Vector
*p
;
959 XSETFASTINT (len
, nargs
);
960 if (!NILP (Vpurify_flag
))
961 val
= make_pure_vector ((EMACS_INT
) nargs
);
963 val
= Fmake_vector (len
, Qnil
);
965 for (index
= 0; index
< nargs
; index
++)
967 if (!NILP (Vpurify_flag
))
968 args
[index
] = Fpurecopy (args
[index
]);
969 p
->contents
[index
] = args
[index
];
971 XSETCOMPILED (val
, p
);
975 /* Allocation of symbols.
976 Just like allocation of conses!
978 Each symbol_block is just under 1020 bytes long,
979 since malloc really allocates in units of powers of two
980 and uses 4 bytes for its own overhead. */
982 #define SYMBOL_BLOCK_SIZE \
983 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
987 struct symbol_block
*next
;
988 struct Lisp_Symbol symbols
[SYMBOL_BLOCK_SIZE
];
991 struct symbol_block
*symbol_block
;
992 int symbol_block_index
;
994 struct Lisp_Symbol
*symbol_free_list
;
996 /* Total number of symbol blocks now in use. */
1002 symbol_block
= (struct symbol_block
*) lisp_malloc (sizeof (struct symbol_block
));
1003 symbol_block
->next
= 0;
1004 bzero ((char *) symbol_block
->symbols
, sizeof symbol_block
->symbols
);
1005 symbol_block_index
= 0;
1006 symbol_free_list
= 0;
1007 n_symbol_blocks
= 1;
1010 DEFUN ("make-symbol", Fmake_symbol
, Smake_symbol
, 1, 1, 0,
1011 "Return a newly allocated uninterned symbol whose name is NAME.\n\
1012 Its value and function definition are void, and its property list is nil.")
1016 register Lisp_Object val
;
1017 register struct Lisp_Symbol
*p
;
1019 CHECK_STRING (name
, 0);
1021 if (symbol_free_list
)
1023 XSETSYMBOL (val
, symbol_free_list
);
1024 symbol_free_list
= *(struct Lisp_Symbol
**)&symbol_free_list
->value
;
1028 if (symbol_block_index
== SYMBOL_BLOCK_SIZE
)
1030 struct symbol_block
*new;
1031 new = (struct symbol_block
*) lisp_malloc (sizeof (struct symbol_block
));
1032 VALIDATE_LISP_STORAGE (new, sizeof *new);
1033 new->next
= symbol_block
;
1035 symbol_block_index
= 0;
1038 XSETSYMBOL (val
, &symbol_block
->symbols
[symbol_block_index
++]);
1041 p
->name
= XSTRING (name
);
1044 p
->value
= Qunbound
;
1045 p
->function
= Qunbound
;
1047 consing_since_gc
+= sizeof (struct Lisp_Symbol
);
1052 /* Allocation of markers and other objects that share that structure.
1053 Works like allocation of conses. */
1055 #define MARKER_BLOCK_SIZE \
1056 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
1060 struct marker_block
*next
;
1061 union Lisp_Misc markers
[MARKER_BLOCK_SIZE
];
1064 struct marker_block
*marker_block
;
1065 int marker_block_index
;
1067 union Lisp_Misc
*marker_free_list
;
1069 /* Total number of marker blocks now in use. */
1070 int n_marker_blocks
;
1075 marker_block
= (struct marker_block
*) lisp_malloc (sizeof (struct marker_block
));
1076 marker_block
->next
= 0;
1077 bzero ((char *) marker_block
->markers
, sizeof marker_block
->markers
);
1078 marker_block_index
= 0;
1079 marker_free_list
= 0;
1080 n_marker_blocks
= 1;
1083 /* Return a newly allocated Lisp_Misc object, with no substructure. */
1089 if (marker_free_list
)
1091 XSETMISC (val
, marker_free_list
);
1092 marker_free_list
= marker_free_list
->u_free
.chain
;
1096 if (marker_block_index
== MARKER_BLOCK_SIZE
)
1098 struct marker_block
*new;
1099 new = (struct marker_block
*) lisp_malloc (sizeof (struct marker_block
));
1100 VALIDATE_LISP_STORAGE (new, sizeof *new);
1101 new->next
= marker_block
;
1103 marker_block_index
= 0;
1106 XSETMISC (val
, &marker_block
->markers
[marker_block_index
++]);
1108 consing_since_gc
+= sizeof (union Lisp_Misc
);
1109 misc_objects_consed
++;
1113 DEFUN ("make-marker", Fmake_marker
, Smake_marker
, 0, 0, 0,
1114 "Return a newly allocated marker which does not point at any place.")
1117 register Lisp_Object val
;
1118 register struct Lisp_Marker
*p
;
1120 val
= allocate_misc ();
1121 XMISCTYPE (val
) = Lisp_Misc_Marker
;
1127 p
->insertion_type
= 0;
1131 /* Put MARKER back on the free list after using it temporarily. */
1134 free_marker (marker
)
1137 unchain_marker (marker
);
1139 XMISC (marker
)->u_marker
.type
= Lisp_Misc_Free
;
1140 XMISC (marker
)->u_free
.chain
= marker_free_list
;
1141 marker_free_list
= XMISC (marker
);
1143 total_free_markers
++;
1146 /* Allocation of strings */
1148 /* Strings reside inside of string_blocks. The entire data of the string,
1149 both the size and the contents, live in part of the `chars' component of a string_block.
1150 The `pos' component is the index within `chars' of the first free byte.
1152 first_string_block points to the first string_block ever allocated.
1153 Each block points to the next one with its `next' field.
1154 The `prev' fields chain in reverse order.
1155 The last one allocated is the one currently being filled.
1156 current_string_block points to it.
1158 The string_blocks that hold individual large strings
1159 go in a separate chain, started by large_string_blocks. */
1162 /* String blocks contain this many useful bytes.
1163 8188 is power of 2, minus 4 for malloc overhead. */
1164 #define STRING_BLOCK_SIZE (8188 - sizeof (struct string_block_head))
1166 /* A string bigger than this gets its own specially-made string block
1167 if it doesn't fit in the current one. */
1168 #define STRING_BLOCK_OUTSIZE 1024
1170 struct string_block_head
1172 struct string_block
*next
, *prev
;
1178 struct string_block
*next
, *prev
;
1180 char chars
[STRING_BLOCK_SIZE
];
1183 /* This points to the string block we are now allocating strings. */
1185 struct string_block
*current_string_block
;
1187 /* This points to the oldest string block, the one that starts the chain. */
1189 struct string_block
*first_string_block
;
1191 /* Last string block in chain of those made for individual large strings. */
1193 struct string_block
*large_string_blocks
;
1195 /* If SIZE is the length of a string, this returns how many bytes
1196 the string occupies in a string_block (including padding). */
1198 #define STRING_FULLSIZE(size) (((size) + 1 + STRING_BASE_SIZE + STRING_PAD - 1) \
1199 & ~(STRING_PAD - 1))
1200 /* Add 1 for the null terminator,
1201 and add STRING_PAD - 1 as part of rounding up. */
1203 #define STRING_PAD (sizeof (EMACS_INT))
1204 /* Size of the stuff in the string not including its data. */
1205 #define STRING_BASE_SIZE (((sizeof (struct Lisp_String) - 1) / STRING_PAD) * STRING_PAD)
1208 #define STRING_FULLSIZE(SIZE) \
1209 (((SIZE) + 2 * sizeof (EMACS_INT)) & ~(sizeof (EMACS_INT) - 1))
1212 /* Total number of string blocks now in use. */
1213 int n_string_blocks
;
1218 current_string_block
= (struct string_block
*) lisp_malloc (sizeof (struct string_block
));
1219 first_string_block
= current_string_block
;
1220 consing_since_gc
+= sizeof (struct string_block
);
1221 current_string_block
->next
= 0;
1222 current_string_block
->prev
= 0;
1223 current_string_block
->pos
= 0;
1224 large_string_blocks
= 0;
1225 n_string_blocks
= 1;
1228 DEFUN ("make-string", Fmake_string
, Smake_string
, 2, 2, 0,
1229 "Return a newly created string of length LENGTH, with each element being INIT.\n\
1230 Both LENGTH and INIT must be numbers.")
1232 Lisp_Object length
, init
;
1234 register Lisp_Object val
;
1235 register unsigned char *p
, *end
;
1238 CHECK_NATNUM (length
, 0);
1239 CHECK_NUMBER (init
, 1);
1242 if (SINGLE_BYTE_CHAR_P (c
))
1244 nbytes
= XINT (length
);
1245 val
= make_uninit_string (nbytes
);
1246 p
= XSTRING (val
)->data
;
1247 end
= p
+ XSTRING (val
)->size
;
1253 unsigned char work
[4], *str
;
1254 int len
= CHAR_STRING (c
, work
, str
);
1256 nbytes
= len
* XINT (length
);
1257 val
= make_uninit_multibyte_string (XINT (length
), nbytes
);
1258 p
= XSTRING (val
)->data
;
1262 bcopy (str
, p
, len
);
1270 DEFUN ("make-bool-vector", Fmake_bool_vector
, Smake_bool_vector
, 2, 2, 0,
1271 "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
1272 LENGTH must be a number. INIT matters only in whether it is t or nil.")
1274 Lisp_Object length
, init
;
1276 register Lisp_Object val
;
1277 struct Lisp_Bool_Vector
*p
;
1279 int length_in_chars
, length_in_elts
, bits_per_value
;
1281 CHECK_NATNUM (length
, 0);
1283 bits_per_value
= sizeof (EMACS_INT
) * BITS_PER_CHAR
;
1285 length_in_elts
= (XFASTINT (length
) + bits_per_value
- 1) / bits_per_value
;
1286 length_in_chars
= ((XFASTINT (length
) + BITS_PER_CHAR
- 1) / BITS_PER_CHAR
);
1288 /* We must allocate one more elements than LENGTH_IN_ELTS for the
1289 slot `size' of the struct Lisp_Bool_Vector. */
1290 val
= Fmake_vector (make_number (length_in_elts
+ 1), Qnil
);
1291 p
= XBOOL_VECTOR (val
);
1292 /* Get rid of any bits that would cause confusion. */
1294 XSETBOOL_VECTOR (val
, p
);
1295 p
->size
= XFASTINT (length
);
1297 real_init
= (NILP (init
) ? 0 : -1);
1298 for (i
= 0; i
< length_in_chars
; i
++)
1299 p
->data
[i
] = real_init
;
1300 /* Clear the extraneous bits in the last byte. */
1301 if (XINT (length
) != length_in_chars
* BITS_PER_CHAR
)
1302 XBOOL_VECTOR (val
)->data
[length_in_chars
- 1]
1303 &= (1 << (XINT (length
) % BITS_PER_CHAR
)) - 1;
1308 /* Make a string from NBYTES bytes at CONTENTS,
1309 and compute the number of characters from the contents.
1310 This string may be unibyte or multibyte, depending on the contents. */
1313 make_string (contents
, nbytes
)
1317 register Lisp_Object val
;
1318 int nchars
= chars_in_text (contents
, nbytes
);
1319 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1320 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1321 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1322 SET_STRING_BYTES (XSTRING (val
), -1);
1326 /* Make a unibyte string from LENGTH bytes at CONTENTS. */
1329 make_unibyte_string (contents
, length
)
1333 register Lisp_Object val
;
1334 val
= make_uninit_string (length
);
1335 bcopy (contents
, XSTRING (val
)->data
, length
);
1336 SET_STRING_BYTES (XSTRING (val
), -1);
1340 /* Make a multibyte string from NCHARS characters
1341 occupying NBYTES bytes at CONTENTS. */
1344 make_multibyte_string (contents
, nchars
, nbytes
)
1348 register Lisp_Object val
;
1349 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1350 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1354 /* Make a string from NCHARS characters
1355 occupying NBYTES bytes at CONTENTS.
1356 It is a multibyte string if NBYTES != NCHARS. */
1359 make_string_from_bytes (contents
, nchars
, nbytes
)
1363 register Lisp_Object val
;
1364 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1365 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1366 if (STRING_BYTES (XSTRING (val
)) == XSTRING (val
)->size
)
1367 SET_STRING_BYTES (XSTRING (val
), -1);
1371 /* Make a multibyte string from NCHARS characters
1372 occupying NBYTES bytes at CONTENTS. */
1375 make_specified_string (contents
, nchars
, nbytes
, multibyte
)
1380 register Lisp_Object val
;
1381 val
= make_uninit_multibyte_string (nchars
, nbytes
);
1382 bcopy (contents
, XSTRING (val
)->data
, nbytes
);
1384 SET_STRING_BYTES (XSTRING (val
), -1);
1388 /* Make a string from the data at STR,
1389 treating it as multibyte if the data warrants. */
1395 return make_string (str
, strlen (str
));
1399 make_uninit_string (length
)
1403 val
= make_uninit_multibyte_string (length
, length
);
1404 SET_STRING_BYTES (XSTRING (val
), -1);
1409 make_uninit_multibyte_string (length
, length_byte
)
1410 int length
, length_byte
;
1412 register Lisp_Object val
;
1413 register int fullsize
= STRING_FULLSIZE (length_byte
);
1415 if (length
< 0) abort ();
1417 if (fullsize
<= STRING_BLOCK_SIZE
- current_string_block
->pos
)
1418 /* This string can fit in the current string block */
1421 ((struct Lisp_String
*)
1422 (current_string_block
->chars
+ current_string_block
->pos
)));
1423 current_string_block
->pos
+= fullsize
;
1425 else if (fullsize
> STRING_BLOCK_OUTSIZE
)
1426 /* This string gets its own string block */
1428 register struct string_block
*new;
1429 #ifdef DOUG_LEA_MALLOC
1430 /* Prevent mmap'ing the chunk (which is potentially very large). */
1431 mallopt (M_MMAP_MAX
, 0);
1433 new = (struct string_block
*) lisp_malloc (sizeof (struct string_block_head
) + fullsize
);
1434 #ifdef DOUG_LEA_MALLOC
1435 /* Back to a reasonable maximum of mmap'ed areas. */
1436 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
);
1439 VALIDATE_LISP_STORAGE (new, 0);
1440 consing_since_gc
+= sizeof (struct string_block_head
) + fullsize
;
1441 new->pos
= fullsize
;
1442 new->next
= large_string_blocks
;
1443 large_string_blocks
= new;
1445 ((struct Lisp_String
*)
1446 ((struct string_block_head
*)new + 1)));
1449 /* Make a new current string block and start it off with this string */
1451 register struct string_block
*new;
1452 new = (struct string_block
*) lisp_malloc (sizeof (struct string_block
));
1454 VALIDATE_LISP_STORAGE (new, sizeof *new);
1455 consing_since_gc
+= sizeof (struct string_block
);
1456 current_string_block
->next
= new;
1457 new->prev
= current_string_block
;
1459 current_string_block
= new;
1460 new->pos
= fullsize
;
1462 (struct Lisp_String
*) current_string_block
->chars
);
1465 string_chars_consed
+= fullsize
;
1466 XSTRING (val
)->size
= length
;
1467 SET_STRING_BYTES (XSTRING (val
), length_byte
);
1468 XSTRING (val
)->data
[length_byte
] = 0;
1469 INITIALIZE_INTERVAL (XSTRING (val
), NULL_INTERVAL
);
1474 /* Return a newly created vector or string with specified arguments as
1475 elements. If all the arguments are characters that can fit
1476 in a string of events, make a string; otherwise, make a vector.
1478 Any number of arguments, even zero arguments, are allowed. */
1481 make_event_array (nargs
, args
)
1487 for (i
= 0; i
< nargs
; i
++)
1488 /* The things that fit in a string
1489 are characters that are in 0...127,
1490 after discarding the meta bit and all the bits above it. */
1491 if (!INTEGERP (args
[i
])
1492 || (XUINT (args
[i
]) & ~(-CHAR_META
)) >= 0200)
1493 return Fvector (nargs
, args
);
1495 /* Since the loop exited, we know that all the things in it are
1496 characters, so we can make a string. */
1500 result
= Fmake_string (make_number (nargs
), make_number (0));
1501 for (i
= 0; i
< nargs
; i
++)
1503 XSTRING (result
)->data
[i
] = XINT (args
[i
]);
1504 /* Move the meta bit to the right place for a string char. */
1505 if (XINT (args
[i
]) & CHAR_META
)
1506 XSTRING (result
)->data
[i
] |= 0x80;
1513 /* Pure storage management. */
1515 /* Must get an error if pure storage is full,
1516 since if it cannot hold a large string
1517 it may be able to hold conses that point to that string;
1518 then the string is not protected from gc. */
1521 make_pure_string (data
, length
, length_byte
, multibyte
)
1528 register Lisp_Object
new;
1529 register int size
= STRING_FULLSIZE (length_byte
);
1531 if (pureptr
+ size
> PURESIZE
)
1532 error ("Pure Lisp storage exhausted");
1533 XSETSTRING (new, PUREBEG
+ pureptr
);
1534 XSTRING (new)->size
= length
;
1535 SET_STRING_BYTES (XSTRING (new), (multibyte
? length_byte
: -1));
1536 bcopy (data
, XSTRING (new)->data
, length_byte
);
1537 XSTRING (new)->data
[length_byte
] = 0;
1539 /* We must give strings in pure storage some kind of interval. So we
1540 give them a null one. */
1541 #if defined (USE_TEXT_PROPERTIES)
1542 XSTRING (new)->intervals
= NULL_INTERVAL
;
1549 pure_cons (car
, cdr
)
1550 Lisp_Object car
, cdr
;
1552 register Lisp_Object
new;
1554 if (pureptr
+ sizeof (struct Lisp_Cons
) > PURESIZE
)
1555 error ("Pure Lisp storage exhausted");
1556 XSETCONS (new, PUREBEG
+ pureptr
);
1557 pureptr
+= sizeof (struct Lisp_Cons
);
1558 XCONS (new)->car
= Fpurecopy (car
);
1559 XCONS (new)->cdr
= Fpurecopy (cdr
);
1563 #ifdef LISP_FLOAT_TYPE
1566 make_pure_float (num
)
1569 register Lisp_Object
new;
1571 /* Make sure that PUREBEG + pureptr is aligned on at least a sizeof
1572 (double) boundary. Some architectures (like the sparc) require
1573 this, and I suspect that floats are rare enough that it's no
1574 tragedy for those that do. */
1577 char *p
= PUREBEG
+ pureptr
;
1581 alignment
= __alignof (struct Lisp_Float
);
1583 alignment
= sizeof (struct Lisp_Float
);
1586 alignment
= sizeof (struct Lisp_Float
);
1588 p
= (char *) (((unsigned long) p
+ alignment
- 1) & - alignment
);
1589 pureptr
= p
- PUREBEG
;
1592 if (pureptr
+ sizeof (struct Lisp_Float
) > PURESIZE
)
1593 error ("Pure Lisp storage exhausted");
1594 XSETFLOAT (new, PUREBEG
+ pureptr
);
1595 pureptr
+= sizeof (struct Lisp_Float
);
1596 XFLOAT (new)->data
= num
;
1597 XSETFASTINT (XFLOAT (new)->type
, 0); /* bug chasing -wsr */
1601 #endif /* LISP_FLOAT_TYPE */
1604 make_pure_vector (len
)
1607 register Lisp_Object
new;
1608 register EMACS_INT size
= sizeof (struct Lisp_Vector
) + (len
- 1) * sizeof (Lisp_Object
);
1610 if (pureptr
+ size
> PURESIZE
)
1611 error ("Pure Lisp storage exhausted");
1613 XSETVECTOR (new, PUREBEG
+ pureptr
);
1615 XVECTOR (new)->size
= len
;
1619 DEFUN ("purecopy", Fpurecopy
, Spurecopy
, 1, 1, 0,
1620 "Make a copy of OBJECT in pure storage.\n\
1621 Recursively copies contents of vectors and cons cells.\n\
1622 Does not copy symbols.")
1624 register Lisp_Object obj
;
1626 if (NILP (Vpurify_flag
))
1629 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
1630 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
1634 return pure_cons (XCONS (obj
)->car
, XCONS (obj
)->cdr
);
1635 #ifdef LISP_FLOAT_TYPE
1636 else if (FLOATP (obj
))
1637 return make_pure_float (XFLOAT (obj
)->data
);
1638 #endif /* LISP_FLOAT_TYPE */
1639 else if (STRINGP (obj
))
1640 return make_pure_string (XSTRING (obj
)->data
, XSTRING (obj
)->size
,
1641 STRING_BYTES (XSTRING (obj
)),
1642 STRING_MULTIBYTE (obj
));
1643 else if (COMPILEDP (obj
) || VECTORP (obj
))
1645 register struct Lisp_Vector
*vec
;
1646 register int i
, size
;
1648 size
= XVECTOR (obj
)->size
;
1649 if (size
& PSEUDOVECTOR_FLAG
)
1650 size
&= PSEUDOVECTOR_SIZE_MASK
;
1651 vec
= XVECTOR (make_pure_vector ((EMACS_INT
) size
));
1652 for (i
= 0; i
< size
; i
++)
1653 vec
->contents
[i
] = Fpurecopy (XVECTOR (obj
)->contents
[i
]);
1654 if (COMPILEDP (obj
))
1655 XSETCOMPILED (obj
, vec
);
1657 XSETVECTOR (obj
, vec
);
1660 else if (MARKERP (obj
))
1661 error ("Attempt to copy a marker to pure storage");
1666 /* Recording what needs to be marked for gc. */
1668 struct gcpro
*gcprolist
;
1670 #define NSTATICS 768
1672 Lisp_Object
*staticvec
[NSTATICS
] = {0};
1676 /* Put an entry in staticvec, pointing at the variable whose address is given */
1679 staticpro (varaddress
)
1680 Lisp_Object
*varaddress
;
1682 staticvec
[staticidx
++] = varaddress
;
1683 if (staticidx
>= NSTATICS
)
1691 struct catchtag
*next
;
1692 #if 0 /* We don't need this for GC purposes */
1699 struct backtrace
*next
;
1700 Lisp_Object
*function
;
1701 Lisp_Object
*args
; /* Points to vector of args. */
1702 int nargs
; /* length of vector */
1703 /* if nargs is UNEVALLED, args points to slot holding list of unevalled args */
1707 /* Garbage collection! */
1709 /* Temporarily prevent garbage collection. */
1712 inhibit_garbage_collection ()
1714 int count
= specpdl_ptr
- specpdl
;
1716 int nbits
= min (VALBITS
, BITS_PER_INT
);
1718 XSETINT (number
, ((EMACS_INT
) 1 << (nbits
- 1)) - 1);
1720 specbind (Qgc_cons_threshold
, number
);
1725 DEFUN ("garbage-collect", Fgarbage_collect
, Sgarbage_collect
, 0, 0, "",
1726 "Reclaim storage for Lisp objects no longer needed.\n\
1727 Returns info on amount of space in use:\n\
1728 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)\n\
1729 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS\n\
1730 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS))\n\
1731 Garbage collection happens automatically if you cons more than\n\
1732 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.")
1735 register struct gcpro
*tail
;
1736 register struct specbinding
*bind
;
1737 struct catchtag
*catch;
1738 struct handler
*handler
;
1739 register struct backtrace
*backlist
;
1740 register Lisp_Object tem
;
1741 char *omessage
= echo_area_glyphs
;
1742 int omessage_length
= echo_area_glyphs_length
;
1743 int oldmultibyte
= message_enable_multibyte
;
1744 char stack_top_variable
;
1747 /* In case user calls debug_print during GC,
1748 don't let that cause a recursive GC. */
1749 consing_since_gc
= 0;
1751 /* Save a copy of the contents of the stack, for debugging. */
1752 #if MAX_SAVE_STACK > 0
1753 if (NILP (Vpurify_flag
))
1755 i
= &stack_top_variable
- stack_bottom
;
1757 if (i
< MAX_SAVE_STACK
)
1759 if (stack_copy
== 0)
1760 stack_copy
= (char *) xmalloc (stack_copy_size
= i
);
1761 else if (stack_copy_size
< i
)
1762 stack_copy
= (char *) xrealloc (stack_copy
, (stack_copy_size
= i
));
1765 if ((EMACS_INT
) (&stack_top_variable
- stack_bottom
) > 0)
1766 bcopy (stack_bottom
, stack_copy
, i
);
1768 bcopy (&stack_top_variable
, stack_copy
, i
);
1772 #endif /* MAX_SAVE_STACK > 0 */
1774 if (garbage_collection_messages
)
1775 message1_nolog ("Garbage collecting...");
1779 shrink_regexp_cache ();
1781 /* Don't keep undo information around forever. */
1783 register struct buffer
*nextb
= all_buffers
;
1787 /* If a buffer's undo list is Qt, that means that undo is
1788 turned off in that buffer. Calling truncate_undo_list on
1789 Qt tends to return NULL, which effectively turns undo back on.
1790 So don't call truncate_undo_list if undo_list is Qt. */
1791 if (! EQ (nextb
->undo_list
, Qt
))
1793 = truncate_undo_list (nextb
->undo_list
, undo_limit
,
1795 nextb
= nextb
->next
;
1801 /* clear_marks (); */
1803 /* In each "large string", set the MARKBIT of the size field.
1804 That enables mark_object to recognize them. */
1806 register struct string_block
*b
;
1807 for (b
= large_string_blocks
; b
; b
= b
->next
)
1808 ((struct Lisp_String
*)(&b
->chars
[0]))->size
|= MARKBIT
;
1811 /* Mark all the special slots that serve as the roots of accessibility.
1813 Usually the special slots to mark are contained in particular structures.
1814 Then we know no slot is marked twice because the structures don't overlap.
1815 In some cases, the structures point to the slots to be marked.
1816 For these, we use MARKBIT to avoid double marking of the slot. */
1818 for (i
= 0; i
< staticidx
; i
++)
1819 mark_object (staticvec
[i
]);
1820 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1821 for (i
= 0; i
< tail
->nvars
; i
++)
1822 if (!XMARKBIT (tail
->var
[i
]))
1824 mark_object (&tail
->var
[i
]);
1825 XMARK (tail
->var
[i
]);
1827 for (bind
= specpdl
; bind
!= specpdl_ptr
; bind
++)
1829 mark_object (&bind
->symbol
);
1830 mark_object (&bind
->old_value
);
1832 for (catch = catchlist
; catch; catch = catch->next
)
1834 mark_object (&catch->tag
);
1835 mark_object (&catch->val
);
1837 for (handler
= handlerlist
; handler
; handler
= handler
->next
)
1839 mark_object (&handler
->handler
);
1840 mark_object (&handler
->var
);
1842 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1844 if (!XMARKBIT (*backlist
->function
))
1846 mark_object (backlist
->function
);
1847 XMARK (*backlist
->function
);
1849 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1852 i
= backlist
->nargs
- 1;
1854 if (!XMARKBIT (backlist
->args
[i
]))
1856 mark_object (&backlist
->args
[i
]);
1857 XMARK (backlist
->args
[i
]);
1862 /* Look thru every buffer's undo list
1863 for elements that update markers that were not marked,
1866 register struct buffer
*nextb
= all_buffers
;
1870 /* If a buffer's undo list is Qt, that means that undo is
1871 turned off in that buffer. Calling truncate_undo_list on
1872 Qt tends to return NULL, which effectively turns undo back on.
1873 So don't call truncate_undo_list if undo_list is Qt. */
1874 if (! EQ (nextb
->undo_list
, Qt
))
1876 Lisp_Object tail
, prev
;
1877 tail
= nextb
->undo_list
;
1879 while (CONSP (tail
))
1881 if (GC_CONSP (XCONS (tail
)->car
)
1882 && GC_MARKERP (XCONS (XCONS (tail
)->car
)->car
)
1883 && ! XMARKBIT (XMARKER (XCONS (XCONS (tail
)->car
)->car
)->chain
))
1886 nextb
->undo_list
= tail
= XCONS (tail
)->cdr
;
1888 tail
= XCONS (prev
)->cdr
= XCONS (tail
)->cdr
;
1893 tail
= XCONS (tail
)->cdr
;
1898 nextb
= nextb
->next
;
1904 /* Clear the mark bits that we set in certain root slots. */
1906 for (tail
= gcprolist
; tail
; tail
= tail
->next
)
1907 for (i
= 0; i
< tail
->nvars
; i
++)
1908 XUNMARK (tail
->var
[i
]);
1909 for (backlist
= backtrace_list
; backlist
; backlist
= backlist
->next
)
1911 XUNMARK (*backlist
->function
);
1912 if (backlist
->nargs
== UNEVALLED
|| backlist
->nargs
== MANY
)
1915 i
= backlist
->nargs
- 1;
1917 XUNMARK (backlist
->args
[i
]);
1919 XUNMARK (buffer_defaults
.name
);
1920 XUNMARK (buffer_local_symbols
.name
);
1924 /* clear_marks (); */
1927 consing_since_gc
= 0;
1928 if (gc_cons_threshold
< 10000)
1929 gc_cons_threshold
= 10000;
1931 if (garbage_collection_messages
)
1933 if (omessage
|| minibuf_level
> 0)
1934 message2_nolog (omessage
, omessage_length
, oldmultibyte
);
1936 message1_nolog ("Garbage collecting...done");
1939 return Fcons (Fcons (make_number (total_conses
),
1940 make_number (total_free_conses
)),
1941 Fcons (Fcons (make_number (total_symbols
),
1942 make_number (total_free_symbols
)),
1943 Fcons (Fcons (make_number (total_markers
),
1944 make_number (total_free_markers
)),
1945 Fcons (make_number (total_string_size
),
1946 Fcons (make_number (total_vector_size
),
1948 #ifdef LISP_FLOAT_TYPE
1949 (make_number (total_floats
),
1950 make_number (total_free_floats
)),
1951 #else /* not LISP_FLOAT_TYPE */
1952 (make_number (0), make_number (0)),
1953 #endif /* not LISP_FLOAT_TYPE */
1955 #ifdef USE_TEXT_PROPERTIES
1956 (make_number (total_intervals
),
1957 make_number (total_free_intervals
)),
1958 #else /* not USE_TEXT_PROPERTIES */
1959 (make_number (0), make_number (0)),
1960 #endif /* not USE_TEXT_PROPERTIES */
1968 /* Clear marks on all conses */
1970 register struct cons_block
*cblk
;
1971 register int lim
= cons_block_index
;
1973 for (cblk
= cons_block
; cblk
; cblk
= cblk
->next
)
1976 for (i
= 0; i
< lim
; i
++)
1977 XUNMARK (cblk
->conses
[i
].car
);
1978 lim
= CONS_BLOCK_SIZE
;
1981 /* Clear marks on all symbols */
1983 register struct symbol_block
*sblk
;
1984 register int lim
= symbol_block_index
;
1986 for (sblk
= symbol_block
; sblk
; sblk
= sblk
->next
)
1989 for (i
= 0; i
< lim
; i
++)
1991 XUNMARK (sblk
->symbols
[i
].plist
);
1993 lim
= SYMBOL_BLOCK_SIZE
;
1996 /* Clear marks on all markers */
1998 register struct marker_block
*sblk
;
1999 register int lim
= marker_block_index
;
2001 for (sblk
= marker_block
; sblk
; sblk
= sblk
->next
)
2004 for (i
= 0; i
< lim
; i
++)
2005 if (sblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2006 XUNMARK (sblk
->markers
[i
].u_marker
.chain
);
2007 lim
= MARKER_BLOCK_SIZE
;
2010 /* Clear mark bits on all buffers */
2012 register struct buffer
*nextb
= all_buffers
;
2016 XUNMARK (nextb
->name
);
2017 nextb
= nextb
->next
;
2023 /* Mark reference to a Lisp_Object.
2024 If the object referred to has not been seen yet, recursively mark
2025 all the references contained in it.
2027 If the object referenced is a short string, the referencing slot
2028 is threaded into a chain of such slots, pointed to from
2029 the `size' field of the string. The actual string size
2030 lives in the last slot in the chain. We recognize the end
2031 because it is < (unsigned) STRING_BLOCK_SIZE. */
2033 #define LAST_MARKED_SIZE 500
2034 Lisp_Object
*last_marked
[LAST_MARKED_SIZE
];
2035 int last_marked_index
;
2038 mark_object (argptr
)
2039 Lisp_Object
*argptr
;
2041 Lisp_Object
*objptr
= argptr
;
2042 register Lisp_Object obj
;
2049 if ((PNTR_COMPARISON_TYPE
) XPNTR (obj
) < (PNTR_COMPARISON_TYPE
) ((char *) pure
+ PURESIZE
)
2050 && (PNTR_COMPARISON_TYPE
) XPNTR (obj
) >= (PNTR_COMPARISON_TYPE
) pure
)
2053 last_marked
[last_marked_index
++] = objptr
;
2054 if (last_marked_index
== LAST_MARKED_SIZE
)
2055 last_marked_index
= 0;
2057 switch (SWITCH_ENUM_CAST (XGCTYPE (obj
)))
2061 register struct Lisp_String
*ptr
= XSTRING (obj
);
2063 MARK_INTERVAL_TREE (ptr
->intervals
);
2064 if (ptr
->size
& MARKBIT
)
2065 /* A large string. Just set ARRAY_MARK_FLAG. */
2066 ptr
->size
|= ARRAY_MARK_FLAG
;
2069 /* A small string. Put this reference
2070 into the chain of references to it.
2071 If the address includes MARKBIT, put that bit elsewhere
2072 when we store OBJPTR into the size field. */
2074 if (XMARKBIT (*objptr
))
2076 XSETFASTINT (*objptr
, ptr
->size
);
2080 XSETFASTINT (*objptr
, ptr
->size
);
2082 if ((EMACS_INT
) objptr
& DONT_COPY_FLAG
)
2084 ptr
->size
= (EMACS_INT
) objptr
;
2085 if (ptr
->size
& MARKBIT
)
2086 ptr
->size
^= MARKBIT
| DONT_COPY_FLAG
;
2091 case Lisp_Vectorlike
:
2092 if (GC_BUFFERP (obj
))
2094 if (!XMARKBIT (XBUFFER (obj
)->name
))
2097 else if (GC_SUBRP (obj
))
2099 else if (GC_COMPILEDP (obj
))
2100 /* We could treat this just like a vector, but it is better
2101 to save the COMPILED_CONSTANTS element for last and avoid recursion
2104 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2105 register EMACS_INT size
= ptr
->size
;
2106 /* See comment above under Lisp_Vector. */
2107 struct Lisp_Vector
*volatile ptr1
= ptr
;
2110 if (size
& ARRAY_MARK_FLAG
)
2111 break; /* Already marked */
2112 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2113 size
&= PSEUDOVECTOR_SIZE_MASK
;
2114 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2116 if (i
!= COMPILED_CONSTANTS
)
2117 mark_object (&ptr1
->contents
[i
]);
2119 /* This cast should be unnecessary, but some Mips compiler complains
2120 (MIPS-ABI + SysVR4, DC/OSx, etc). */
2121 objptr
= (Lisp_Object
*) &ptr1
->contents
[COMPILED_CONSTANTS
];
2124 else if (GC_FRAMEP (obj
))
2126 /* See comment above under Lisp_Vector for why this is volatile. */
2127 register struct frame
*volatile ptr
= XFRAME (obj
);
2128 register EMACS_INT size
= ptr
->size
;
2130 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2131 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2133 mark_object (&ptr
->name
);
2134 mark_object (&ptr
->icon_name
);
2135 mark_object (&ptr
->title
);
2136 mark_object (&ptr
->focus_frame
);
2137 mark_object (&ptr
->selected_window
);
2138 mark_object (&ptr
->minibuffer_window
);
2139 mark_object (&ptr
->param_alist
);
2140 mark_object (&ptr
->scroll_bars
);
2141 mark_object (&ptr
->condemned_scroll_bars
);
2142 mark_object (&ptr
->menu_bar_items
);
2143 mark_object (&ptr
->face_alist
);
2144 mark_object (&ptr
->menu_bar_vector
);
2145 mark_object (&ptr
->buffer_predicate
);
2146 mark_object (&ptr
->buffer_list
);
2148 else if (GC_BOOL_VECTOR_P (obj
))
2150 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2152 if (ptr
->size
& ARRAY_MARK_FLAG
)
2153 break; /* Already marked */
2154 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2158 register struct Lisp_Vector
*ptr
= XVECTOR (obj
);
2159 register EMACS_INT size
= ptr
->size
;
2160 /* The reason we use ptr1 is to avoid an apparent hardware bug
2161 that happens occasionally on the FSF's HP 300s.
2162 The bug is that a2 gets clobbered by recursive calls to mark_object.
2163 The clobberage seems to happen during function entry,
2164 perhaps in the moveml instruction.
2165 Yes, this is a crock, but we have to do it. */
2166 struct Lisp_Vector
*volatile ptr1
= ptr
;
2169 if (size
& ARRAY_MARK_FLAG
) break; /* Already marked */
2170 ptr
->size
|= ARRAY_MARK_FLAG
; /* Else mark it */
2171 if (size
& PSEUDOVECTOR_FLAG
)
2172 size
&= PSEUDOVECTOR_SIZE_MASK
;
2173 for (i
= 0; i
< size
; i
++) /* and then mark its elements */
2174 mark_object (&ptr1
->contents
[i
]);
2180 /* See comment above under Lisp_Vector for why this is volatile. */
2181 register struct Lisp_Symbol
*volatile ptr
= XSYMBOL (obj
);
2182 struct Lisp_Symbol
*ptrx
;
2184 if (XMARKBIT (ptr
->plist
)) break;
2186 mark_object ((Lisp_Object
*) &ptr
->value
);
2187 mark_object (&ptr
->function
);
2188 mark_object (&ptr
->plist
);
2189 XSETTYPE (*(Lisp_Object
*) &ptr
->name
, Lisp_String
);
2190 mark_object (&ptr
->name
);
2191 /* Note that we do not mark the obarray of the symbol.
2192 It is safe not to do so because nothing accesses that
2193 slot except to check whether it is nil. */
2197 /* For the benefit of the last_marked log. */
2198 objptr
= (Lisp_Object
*)&XSYMBOL (obj
)->next
;
2199 ptrx
= ptr
; /* Use of ptrx avoids compiler bug on Sun */
2200 XSETSYMBOL (obj
, ptrx
);
2201 /* We can't goto loop here because *objptr doesn't contain an
2202 actual Lisp_Object with valid datatype field. */
2209 switch (XMISCTYPE (obj
))
2211 case Lisp_Misc_Marker
:
2212 XMARK (XMARKER (obj
)->chain
);
2213 /* DO NOT mark thru the marker's chain.
2214 The buffer's markers chain does not preserve markers from gc;
2215 instead, markers are removed from the chain when freed by gc. */
2218 case Lisp_Misc_Buffer_Local_Value
:
2219 case Lisp_Misc_Some_Buffer_Local_Value
:
2221 register struct Lisp_Buffer_Local_Value
*ptr
2222 = XBUFFER_LOCAL_VALUE (obj
);
2223 if (XMARKBIT (ptr
->realvalue
)) break;
2224 XMARK (ptr
->realvalue
);
2225 /* If the cdr is nil, avoid recursion for the car. */
2226 if (EQ (ptr
->cdr
, Qnil
))
2228 objptr
= &ptr
->realvalue
;
2231 mark_object (&ptr
->realvalue
);
2232 mark_object (&ptr
->buffer
);
2233 mark_object (&ptr
->frame
);
2234 /* See comment above under Lisp_Vector for why not use ptr here. */
2235 objptr
= &XBUFFER_LOCAL_VALUE (obj
)->cdr
;
2239 case Lisp_Misc_Intfwd
:
2240 case Lisp_Misc_Boolfwd
:
2241 case Lisp_Misc_Objfwd
:
2242 case Lisp_Misc_Buffer_Objfwd
:
2243 case Lisp_Misc_Kboard_Objfwd
:
2244 /* Don't bother with Lisp_Buffer_Objfwd,
2245 since all markable slots in current buffer marked anyway. */
2246 /* Don't need to do Lisp_Objfwd, since the places they point
2247 are protected with staticpro. */
2250 case Lisp_Misc_Overlay
:
2252 struct Lisp_Overlay
*ptr
= XOVERLAY (obj
);
2253 if (!XMARKBIT (ptr
->plist
))
2256 mark_object (&ptr
->start
);
2257 mark_object (&ptr
->end
);
2258 objptr
= &ptr
->plist
;
2271 register struct Lisp_Cons
*ptr
= XCONS (obj
);
2272 if (XMARKBIT (ptr
->car
)) break;
2274 /* If the cdr is nil, avoid recursion for the car. */
2275 if (EQ (ptr
->cdr
, Qnil
))
2280 mark_object (&ptr
->car
);
2281 /* See comment above under Lisp_Vector for why not use ptr here. */
2282 objptr
= &XCONS (obj
)->cdr
;
2286 #ifdef LISP_FLOAT_TYPE
2288 XMARK (XFLOAT (obj
)->type
);
2290 #endif /* LISP_FLOAT_TYPE */
2300 /* Mark the pointers in a buffer structure. */
2306 register struct buffer
*buffer
= XBUFFER (buf
);
2307 register Lisp_Object
*ptr
;
2308 Lisp_Object base_buffer
;
2310 /* This is the buffer's markbit */
2311 mark_object (&buffer
->name
);
2312 XMARK (buffer
->name
);
2314 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer
));
2316 if (CONSP (buffer
->undo_list
))
2319 tail
= buffer
->undo_list
;
2321 while (CONSP (tail
))
2323 register struct Lisp_Cons
*ptr
= XCONS (tail
);
2325 if (XMARKBIT (ptr
->car
))
2328 if (GC_CONSP (ptr
->car
)
2329 && ! XMARKBIT (XCONS (ptr
->car
)->car
)
2330 && GC_MARKERP (XCONS (ptr
->car
)->car
))
2332 XMARK (XCONS (ptr
->car
)->car
);
2333 mark_object (&XCONS (ptr
->car
)->cdr
);
2336 mark_object (&ptr
->car
);
2338 if (CONSP (ptr
->cdr
))
2344 mark_object (&XCONS (tail
)->cdr
);
2347 mark_object (&buffer
->undo_list
);
2350 mark_object (buffer
->syntax_table
);
2352 /* Mark the various string-pointers in the buffer object.
2353 Since the strings may be relocated, we must mark them
2354 in their actual slots. So gc_sweep must convert each slot
2355 back to an ordinary C pointer. */
2356 XSETSTRING (*(Lisp_Object
*)&buffer
->upcase_table
, buffer
->upcase_table
);
2357 mark_object ((Lisp_Object
*)&buffer
->upcase_table
);
2358 XSETSTRING (*(Lisp_Object
*)&buffer
->downcase_table
, buffer
->downcase_table
);
2359 mark_object ((Lisp_Object
*)&buffer
->downcase_table
);
2361 XSETSTRING (*(Lisp_Object
*)&buffer
->sort_table
, buffer
->sort_table
);
2362 mark_object ((Lisp_Object
*)&buffer
->sort_table
);
2363 XSETSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
, buffer
->folding_sort_table
);
2364 mark_object ((Lisp_Object
*)&buffer
->folding_sort_table
);
2367 for (ptr
= &buffer
->name
+ 1;
2368 (char *)ptr
< (char *)buffer
+ sizeof (struct buffer
);
2372 /* If this is an indirect buffer, mark its base buffer. */
2373 if (buffer
->base_buffer
&& !XMARKBIT (buffer
->base_buffer
->name
))
2375 XSETBUFFER (base_buffer
, buffer
->base_buffer
);
2376 mark_buffer (base_buffer
);
2381 /* Mark the pointers in the kboard objects. */
2388 for (kb
= all_kboards
; kb
; kb
= kb
->next_kboard
)
2390 if (kb
->kbd_macro_buffer
)
2391 for (p
= kb
->kbd_macro_buffer
; p
< kb
->kbd_macro_ptr
; p
++)
2393 mark_object (&kb
->Voverriding_terminal_local_map
);
2394 mark_object (&kb
->Vlast_command
);
2395 mark_object (&kb
->Vreal_last_command
);
2396 mark_object (&kb
->Vprefix_arg
);
2397 mark_object (&kb
->Vlast_prefix_arg
);
2398 mark_object (&kb
->kbd_queue
);
2399 mark_object (&kb
->defining_kbd_macro
);
2400 mark_object (&kb
->Vlast_kbd_macro
);
2401 mark_object (&kb
->Vsystem_key_alist
);
2402 mark_object (&kb
->system_key_syms
);
2403 mark_object (&kb
->Vdefault_minibuffer_frame
);
2407 /* Sweep: find all structures not marked, and free them. */
2412 total_string_size
= 0;
2415 /* Put all unmarked conses on free list */
2417 register struct cons_block
*cblk
;
2418 struct cons_block
**cprev
= &cons_block
;
2419 register int lim
= cons_block_index
;
2420 register int num_free
= 0, num_used
= 0;
2424 for (cblk
= cons_block
; cblk
; cblk
= *cprev
)
2428 for (i
= 0; i
< lim
; i
++)
2429 if (!XMARKBIT (cblk
->conses
[i
].car
))
2432 *(struct Lisp_Cons
**)&cblk
->conses
[i
].cdr
= cons_free_list
;
2433 cons_free_list
= &cblk
->conses
[i
];
2438 XUNMARK (cblk
->conses
[i
].car
);
2440 lim
= CONS_BLOCK_SIZE
;
2441 /* If this block contains only free conses and we have already
2442 seen more than two blocks worth of free conses then deallocate
2444 if (this_free
== CONS_BLOCK_SIZE
&& num_free
> CONS_BLOCK_SIZE
)
2446 *cprev
= cblk
->next
;
2447 /* Unhook from the free list. */
2448 cons_free_list
= *(struct Lisp_Cons
**) &cblk
->conses
[0].cdr
;
2454 num_free
+= this_free
;
2455 cprev
= &cblk
->next
;
2458 total_conses
= num_used
;
2459 total_free_conses
= num_free
;
2462 #ifdef LISP_FLOAT_TYPE
2463 /* Put all unmarked floats on free list */
2465 register struct float_block
*fblk
;
2466 struct float_block
**fprev
= &float_block
;
2467 register int lim
= float_block_index
;
2468 register int num_free
= 0, num_used
= 0;
2470 float_free_list
= 0;
2472 for (fblk
= float_block
; fblk
; fblk
= *fprev
)
2476 for (i
= 0; i
< lim
; i
++)
2477 if (!XMARKBIT (fblk
->floats
[i
].type
))
2480 *(struct Lisp_Float
**)&fblk
->floats
[i
].data
= float_free_list
;
2481 float_free_list
= &fblk
->floats
[i
];
2486 XUNMARK (fblk
->floats
[i
].type
);
2488 lim
= FLOAT_BLOCK_SIZE
;
2489 /* If this block contains only free floats and we have already
2490 seen more than two blocks worth of free floats then deallocate
2492 if (this_free
== FLOAT_BLOCK_SIZE
&& num_free
> FLOAT_BLOCK_SIZE
)
2494 *fprev
= fblk
->next
;
2495 /* Unhook from the free list. */
2496 float_free_list
= *(struct Lisp_Float
**) &fblk
->floats
[0].data
;
2502 num_free
+= this_free
;
2503 fprev
= &fblk
->next
;
2506 total_floats
= num_used
;
2507 total_free_floats
= num_free
;
2509 #endif /* LISP_FLOAT_TYPE */
2511 #ifdef USE_TEXT_PROPERTIES
2512 /* Put all unmarked intervals on free list */
2514 register struct interval_block
*iblk
;
2515 struct interval_block
**iprev
= &interval_block
;
2516 register int lim
= interval_block_index
;
2517 register int num_free
= 0, num_used
= 0;
2519 interval_free_list
= 0;
2521 for (iblk
= interval_block
; iblk
; iblk
= *iprev
)
2526 for (i
= 0; i
< lim
; i
++)
2528 if (! XMARKBIT (iblk
->intervals
[i
].plist
))
2530 iblk
->intervals
[i
].parent
= interval_free_list
;
2531 interval_free_list
= &iblk
->intervals
[i
];
2537 XUNMARK (iblk
->intervals
[i
].plist
);
2540 lim
= INTERVAL_BLOCK_SIZE
;
2541 /* If this block contains only free intervals and we have already
2542 seen more than two blocks worth of free intervals then
2543 deallocate this block. */
2544 if (this_free
== INTERVAL_BLOCK_SIZE
&& num_free
> INTERVAL_BLOCK_SIZE
)
2546 *iprev
= iblk
->next
;
2547 /* Unhook from the free list. */
2548 interval_free_list
= iblk
->intervals
[0].parent
;
2550 n_interval_blocks
--;
2554 num_free
+= this_free
;
2555 iprev
= &iblk
->next
;
2558 total_intervals
= num_used
;
2559 total_free_intervals
= num_free
;
2561 #endif /* USE_TEXT_PROPERTIES */
2563 /* Put all unmarked symbols on free list */
2565 register struct symbol_block
*sblk
;
2566 struct symbol_block
**sprev
= &symbol_block
;
2567 register int lim
= symbol_block_index
;
2568 register int num_free
= 0, num_used
= 0;
2570 symbol_free_list
= 0;
2572 for (sblk
= symbol_block
; sblk
; sblk
= *sprev
)
2576 for (i
= 0; i
< lim
; i
++)
2577 if (!XMARKBIT (sblk
->symbols
[i
].plist
))
2579 *(struct Lisp_Symbol
**)&sblk
->symbols
[i
].value
= symbol_free_list
;
2580 symbol_free_list
= &sblk
->symbols
[i
];
2586 sblk
->symbols
[i
].name
2587 = XSTRING (*(Lisp_Object
*) &sblk
->symbols
[i
].name
);
2588 XUNMARK (sblk
->symbols
[i
].plist
);
2590 lim
= SYMBOL_BLOCK_SIZE
;
2591 /* If this block contains only free symbols and we have already
2592 seen more than two blocks worth of free symbols then deallocate
2594 if (this_free
== SYMBOL_BLOCK_SIZE
&& num_free
> SYMBOL_BLOCK_SIZE
)
2596 *sprev
= sblk
->next
;
2597 /* Unhook from the free list. */
2598 symbol_free_list
= *(struct Lisp_Symbol
**)&sblk
->symbols
[0].value
;
2604 num_free
+= this_free
;
2605 sprev
= &sblk
->next
;
2608 total_symbols
= num_used
;
2609 total_free_symbols
= num_free
;
2613 /* Put all unmarked misc's on free list.
2614 For a marker, first unchain it from the buffer it points into. */
2616 register struct marker_block
*mblk
;
2617 struct marker_block
**mprev
= &marker_block
;
2618 register int lim
= marker_block_index
;
2619 register int num_free
= 0, num_used
= 0;
2621 marker_free_list
= 0;
2623 for (mblk
= marker_block
; mblk
; mblk
= *mprev
)
2627 EMACS_INT already_free
= -1;
2629 for (i
= 0; i
< lim
; i
++)
2631 Lisp_Object
*markword
;
2632 switch (mblk
->markers
[i
].u_marker
.type
)
2634 case Lisp_Misc_Marker
:
2635 markword
= &mblk
->markers
[i
].u_marker
.chain
;
2637 case Lisp_Misc_Buffer_Local_Value
:
2638 case Lisp_Misc_Some_Buffer_Local_Value
:
2639 markword
= &mblk
->markers
[i
].u_buffer_local_value
.realvalue
;
2641 case Lisp_Misc_Overlay
:
2642 markword
= &mblk
->markers
[i
].u_overlay
.plist
;
2644 case Lisp_Misc_Free
:
2645 /* If the object was already free, keep it
2646 on the free list. */
2647 markword
= (Lisp_Object
*) &already_free
;
2653 if (markword
&& !XMARKBIT (*markword
))
2656 if (mblk
->markers
[i
].u_marker
.type
== Lisp_Misc_Marker
)
2658 /* tem1 avoids Sun compiler bug */
2659 struct Lisp_Marker
*tem1
= &mblk
->markers
[i
].u_marker
;
2660 XSETMARKER (tem
, tem1
);
2661 unchain_marker (tem
);
2663 /* Set the type of the freed object to Lisp_Misc_Free.
2664 We could leave the type alone, since nobody checks it,
2665 but this might catch bugs faster. */
2666 mblk
->markers
[i
].u_marker
.type
= Lisp_Misc_Free
;
2667 mblk
->markers
[i
].u_free
.chain
= marker_free_list
;
2668 marker_free_list
= &mblk
->markers
[i
];
2675 XUNMARK (*markword
);
2678 lim
= MARKER_BLOCK_SIZE
;
2679 /* If this block contains only free markers and we have already
2680 seen more than two blocks worth of free markers then deallocate
2682 if (this_free
== MARKER_BLOCK_SIZE
&& num_free
> MARKER_BLOCK_SIZE
)
2684 *mprev
= mblk
->next
;
2685 /* Unhook from the free list. */
2686 marker_free_list
= mblk
->markers
[0].u_free
.chain
;
2692 num_free
+= this_free
;
2693 mprev
= &mblk
->next
;
2697 total_markers
= num_used
;
2698 total_free_markers
= num_free
;
2701 /* Free all unmarked buffers */
2703 register struct buffer
*buffer
= all_buffers
, *prev
= 0, *next
;
2706 if (!XMARKBIT (buffer
->name
))
2709 prev
->next
= buffer
->next
;
2711 all_buffers
= buffer
->next
;
2712 next
= buffer
->next
;
2718 XUNMARK (buffer
->name
);
2719 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer
));
2722 /* Each `struct Lisp_String *' was turned into a Lisp_Object
2723 for purposes of marking and relocation.
2724 Turn them back into C pointers now. */
2725 buffer
->upcase_table
2726 = XSTRING (*(Lisp_Object
*)&buffer
->upcase_table
);
2727 buffer
->downcase_table
2728 = XSTRING (*(Lisp_Object
*)&buffer
->downcase_table
);
2730 = XSTRING (*(Lisp_Object
*)&buffer
->sort_table
);
2731 buffer
->folding_sort_table
2732 = XSTRING (*(Lisp_Object
*)&buffer
->folding_sort_table
);
2735 prev
= buffer
, buffer
= buffer
->next
;
2739 #endif /* standalone */
2741 /* Free all unmarked vectors */
2743 register struct Lisp_Vector
*vector
= all_vectors
, *prev
= 0, *next
;
2744 total_vector_size
= 0;
2747 if (!(vector
->size
& ARRAY_MARK_FLAG
))
2750 prev
->next
= vector
->next
;
2752 all_vectors
= vector
->next
;
2753 next
= vector
->next
;
2760 vector
->size
&= ~ARRAY_MARK_FLAG
;
2761 if (vector
->size
& PSEUDOVECTOR_FLAG
)
2762 total_vector_size
+= (PSEUDOVECTOR_SIZE_MASK
& vector
->size
);
2764 total_vector_size
+= vector
->size
;
2765 prev
= vector
, vector
= vector
->next
;
2769 /* Free all "large strings" not marked with ARRAY_MARK_FLAG. */
2771 register struct string_block
*sb
= large_string_blocks
, *prev
= 0, *next
;
2772 struct Lisp_String
*s
;
2776 s
= (struct Lisp_String
*) &sb
->chars
[0];
2777 if (s
->size
& ARRAY_MARK_FLAG
)
2779 ((struct Lisp_String
*)(&sb
->chars
[0]))->size
2780 &= ~ARRAY_MARK_FLAG
& ~MARKBIT
;
2781 UNMARK_BALANCE_INTERVALS (s
->intervals
);
2782 total_string_size
+= ((struct Lisp_String
*)(&sb
->chars
[0]))->size
;
2783 prev
= sb
, sb
= sb
->next
;
2788 prev
->next
= sb
->next
;
2790 large_string_blocks
= sb
->next
;
2800 /* Compactify strings, relocate references, and free empty string blocks. */
2805 /* String block of old strings we are scanning. */
2806 register struct string_block
*from_sb
;
2807 /* A preceding string block (or maybe the same one)
2808 where we are copying the still-live strings to. */
2809 register struct string_block
*to_sb
;
2813 to_sb
= first_string_block
;
2816 /* Scan each existing string block sequentially, string by string. */
2817 for (from_sb
= first_string_block
; from_sb
; from_sb
= from_sb
->next
)
2820 /* POS is the index of the next string in the block. */
2821 while (pos
< from_sb
->pos
)
2823 register struct Lisp_String
*nextstr
2824 = (struct Lisp_String
*) &from_sb
->chars
[pos
];
2826 register struct Lisp_String
*newaddr
;
2827 register EMACS_INT size
= nextstr
->size
;
2828 EMACS_INT size_byte
= nextstr
->size_byte
;
2830 /* NEXTSTR is the old address of the next string.
2831 Just skip it if it isn't marked. */
2832 if (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2834 /* It is marked, so its size field is really a chain of refs.
2835 Find the end of the chain, where the actual size lives. */
2836 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2838 if (size
& DONT_COPY_FLAG
)
2839 size
^= MARKBIT
| DONT_COPY_FLAG
;
2840 size
= *(EMACS_INT
*)size
& ~MARKBIT
;
2846 total_string_size
+= size_byte
;
2848 /* If it won't fit in TO_SB, close it out,
2849 and move to the next sb. Keep doing so until
2850 TO_SB reaches a large enough, empty enough string block.
2851 We know that TO_SB cannot advance past FROM_SB here
2852 since FROM_SB is large enough to contain this string.
2853 Any string blocks skipped here
2854 will be patched out and freed later. */
2855 while (to_pos
+ STRING_FULLSIZE (size_byte
)
2856 > max (to_sb
->pos
, STRING_BLOCK_SIZE
))
2858 to_sb
->pos
= to_pos
;
2859 to_sb
= to_sb
->next
;
2862 /* Compute new address of this string
2863 and update TO_POS for the space being used. */
2864 newaddr
= (struct Lisp_String
*) &to_sb
->chars
[to_pos
];
2865 to_pos
+= STRING_FULLSIZE (size_byte
);
2867 /* Copy the string itself to the new place. */
2868 if (nextstr
!= newaddr
)
2869 bcopy (nextstr
, newaddr
, STRING_FULLSIZE (size_byte
));
2871 /* Go through NEXTSTR's chain of references
2872 and make each slot in the chain point to
2873 the new address of this string. */
2874 size
= newaddr
->size
;
2875 while (((EMACS_UINT
) size
& ~DONT_COPY_FLAG
) > STRING_BLOCK_SIZE
)
2877 register Lisp_Object
*objptr
;
2878 if (size
& DONT_COPY_FLAG
)
2879 size
^= MARKBIT
| DONT_COPY_FLAG
;
2880 objptr
= (Lisp_Object
*)size
;
2882 size
= XFASTINT (*objptr
) & ~MARKBIT
;
2883 if (XMARKBIT (*objptr
))
2885 XSETSTRING (*objptr
, newaddr
);
2889 XSETSTRING (*objptr
, newaddr
);
2891 /* Store the actual size in the size field. */
2892 newaddr
->size
= size
;
2894 #ifdef USE_TEXT_PROPERTIES
2895 /* Now that the string has been relocated, rebalance its
2896 interval tree, and update the tree's parent pointer. */
2897 if (! NULL_INTERVAL_P (newaddr
->intervals
))
2899 UNMARK_BALANCE_INTERVALS (newaddr
->intervals
);
2900 XSETSTRING (* (Lisp_Object
*) &newaddr
->intervals
->parent
,
2903 #endif /* USE_TEXT_PROPERTIES */
2905 else if (size_byte
< 0)
2908 pos
+= STRING_FULLSIZE (size_byte
);
2912 /* Close out the last string block still used and free any that follow. */
2913 to_sb
->pos
= to_pos
;
2914 current_string_block
= to_sb
;
2916 from_sb
= to_sb
->next
;
2920 to_sb
= from_sb
->next
;
2921 lisp_free (from_sb
);
2926 /* Free any empty string blocks further back in the chain.
2927 This loop will never free first_string_block, but it is very
2928 unlikely that that one will become empty, so why bother checking? */
2930 from_sb
= first_string_block
;
2931 while (to_sb
= from_sb
->next
)
2933 if (to_sb
->pos
== 0)
2935 if (from_sb
->next
= to_sb
->next
)
2936 from_sb
->next
->prev
= from_sb
;
2945 /* Debugging aids. */
2947 DEFUN ("memory-limit", Fmemory_limit
, Smemory_limit
, 0, 0, 0,
2948 "Return the address of the last byte Emacs has allocated, divided by 1024.\n\
2949 This may be helpful in debugging Emacs's memory usage.\n\
2950 We divide the value by 1024 to make sure it fits in a Lisp integer.")
2955 XSETINT (end
, (EMACS_INT
) sbrk (0) / 1024);
2960 DEFUN ("memory-use-counts", Fmemory_use_counts
, Smemory_use_counts
, 0, 0, 0,
2961 "Return a list of counters that measure how much consing there has been.\n\
2962 Each of these counters increments for a certain kind of object.\n\
2963 The counters wrap around from the largest positive integer to zero.\n\
2964 Garbage collection does not decrease them.\n\
2965 The elements of the value are as follows:\n\
2966 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS)\n\
2967 All are in units of 1 = one object consed\n\
2968 except for VECTOR-CELLS and STRING-CHARS, which count the total length of\n\
2970 MISCS include overlays, markers, and some internal types.\n\
2971 Frames, windows, buffers, and subprocesses count as vectors\n\
2972 (but the contents of a buffer's text do not count here).")
2975 Lisp_Object lisp_cons_cells_consed
;
2976 Lisp_Object lisp_floats_consed
;
2977 Lisp_Object lisp_vector_cells_consed
;
2978 Lisp_Object lisp_symbols_consed
;
2979 Lisp_Object lisp_string_chars_consed
;
2980 Lisp_Object lisp_misc_objects_consed
;
2981 Lisp_Object lisp_intervals_consed
;
2983 XSETINT (lisp_cons_cells_consed
,
2984 cons_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2985 XSETINT (lisp_floats_consed
,
2986 floats_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2987 XSETINT (lisp_vector_cells_consed
,
2988 vector_cells_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2989 XSETINT (lisp_symbols_consed
,
2990 symbols_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2991 XSETINT (lisp_string_chars_consed
,
2992 string_chars_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2993 XSETINT (lisp_misc_objects_consed
,
2994 misc_objects_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2995 XSETINT (lisp_intervals_consed
,
2996 intervals_consed
& ~(((EMACS_INT
) 1) << (VALBITS
- 1)));
2998 return Fcons (lisp_cons_cells_consed
,
2999 Fcons (lisp_floats_consed
,
3000 Fcons (lisp_vector_cells_consed
,
3001 Fcons (lisp_symbols_consed
,
3002 Fcons (lisp_string_chars_consed
,
3003 Fcons (lisp_misc_objects_consed
,
3004 Fcons (lisp_intervals_consed
,
3008 /* Initialization */
3013 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
3016 pure_size
= PURESIZE
;
3019 ignore_warnings
= 1;
3020 #ifdef DOUG_LEA_MALLOC
3021 mallopt (M_TRIM_THRESHOLD
, 128*1024); /* trim threshold */
3022 mallopt (M_MMAP_THRESHOLD
, 64*1024); /* mmap threshold */
3023 mallopt (M_MMAP_MAX
, MMAP_MAX_AREAS
); /* max. number of mmap'ed areas */
3029 #ifdef LISP_FLOAT_TYPE
3031 #endif /* LISP_FLOAT_TYPE */
3035 malloc_hysteresis
= 32;
3037 malloc_hysteresis
= 0;
3040 spare_memory
= (char *) malloc (SPARE_MEMORY
);
3042 ignore_warnings
= 0;
3045 consing_since_gc
= 0;
3046 gc_cons_threshold
= 100000 * sizeof (Lisp_Object
);
3047 #ifdef VIRT_ADDR_VARIES
3048 malloc_sbrk_unused
= 1<<22; /* A large number */
3049 malloc_sbrk_used
= 100000; /* as reasonable as any number */
3050 #endif /* VIRT_ADDR_VARIES */
3062 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold
,
3063 "*Number of bytes of consing between garbage collections.\n\
3064 Garbage collection can happen automatically once this many bytes have been\n\
3065 allocated since the last garbage collection. All data types count.\n\n\
3066 Garbage collection happens automatically only when `eval' is called.\n\n\
3067 By binding this temporarily to a large number, you can effectively\n\
3068 prevent garbage collection during a part of the program.");
3070 DEFVAR_INT ("pure-bytes-used", &pureptr
,
3071 "Number of bytes of sharable Lisp data allocated so far.");
3073 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed
,
3074 "Number of cons cells that have been consed so far.");
3076 DEFVAR_INT ("floats-consed", &floats_consed
,
3077 "Number of floats that have been consed so far.");
3079 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed
,
3080 "Number of vector cells that have been consed so far.");
3082 DEFVAR_INT ("symbols-consed", &symbols_consed
,
3083 "Number of symbols that have been consed so far.");
3085 DEFVAR_INT ("string-chars-consed", &string_chars_consed
,
3086 "Number of string characters that have been consed so far.");
3088 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed
,
3089 "Number of miscellaneous objects that have been consed so far.");
3091 DEFVAR_INT ("intervals-consed", &intervals_consed
,
3092 "Number of intervals that have been consed so far.");
3095 DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used
,
3096 "Number of bytes of unshared memory allocated in this session.");
3098 DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused
,
3099 "Number of bytes of unshared memory remaining available in this session.");
3102 DEFVAR_LISP ("purify-flag", &Vpurify_flag
,
3103 "Non-nil means loading Lisp code in order to dump an executable.\n\
3104 This means that certain objects should be allocated in shared (pure) space.");
3106 DEFVAR_INT ("undo-limit", &undo_limit
,
3107 "Keep no more undo information once it exceeds this size.\n\
3108 This limit is applied when garbage collection happens.\n\
3109 The size is counted as the number of bytes occupied,\n\
3110 which includes both saved text and other data.");
3113 DEFVAR_INT ("undo-strong-limit", &undo_strong_limit
,
3114 "Don't keep more than this much size of undo information.\n\
3115 A command which pushes past this size is itself forgotten.\n\
3116 This limit is applied when garbage collection happens.\n\
3117 The size is counted as the number of bytes occupied,\n\
3118 which includes both saved text and other data.");
3119 undo_strong_limit
= 30000;
3121 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages
,
3122 "Non-nil means display messages at start and end of garbage collection.");
3123 garbage_collection_messages
= 0;
3125 /* We build this in advance because if we wait until we need it, we might
3126 not be able to allocate the memory to hold it. */
3128 = Fcons (Qerror
, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil
));
3129 staticpro (&memory_signal_data
);
3131 staticpro (&Qgc_cons_threshold
);
3132 Qgc_cons_threshold
= intern ("gc-cons-threshold");
3134 staticpro (&Qchar_table_extra_slots
);
3135 Qchar_table_extra_slots
= intern ("char-table-extra-slots");
3140 defsubr (&Smake_byte_code
);
3141 defsubr (&Smake_list
);
3142 defsubr (&Smake_vector
);
3143 defsubr (&Smake_char_table
);
3144 defsubr (&Smake_string
);
3145 defsubr (&Smake_bool_vector
);
3146 defsubr (&Smake_symbol
);
3147 defsubr (&Smake_marker
);
3148 defsubr (&Spurecopy
);
3149 defsubr (&Sgarbage_collect
);
3150 defsubr (&Smemory_limit
);
3151 defsubr (&Smemory_use_counts
);