|
300
|
1 /* Storage allocation and gc for GNU Emacs Lisp interpreter.
|
57098
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2 Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
|
|
68350
|
3 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
|
|
300
|
4
|
|
|
5 This file is part of GNU Emacs.
|
|
|
6
|
|
|
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
|
|
1784
|
9 the Free Software Foundation; either version 2, or (at your option)
|
|
300
|
10 any later version.
|
|
|
11
|
|
|
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.
|
|
|
16
|
|
|
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
|
|
64084
|
19 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
|
20 Boston, MA 02110-1301, USA. */
|
|
300
|
21
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
22 #include <config.h>
|
|
28374
|
23 #include <stdio.h>
|
|
51723
|
24 #include <limits.h> /* For CHAR_BIT. */
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
25
|
|
47185
|
26 #ifdef ALLOC_DEBUG
|
|
|
27 #undef INLINE
|
|
|
28 #endif
|
|
|
29
|
|
13320
|
30 /* Note that this declares bzero on OSF/1. How dumb. */
|
|
27142
|
31
|
|
3003
|
32 #include <signal.h>
|
|
300
|
33
|
|
58818
|
34 #ifdef HAVE_GTK_AND_PTHREAD
|
|
|
35 #include <pthread.h>
|
|
|
36 #endif
|
|
|
37
|
|
26164
|
38 /* This file is part of the core Lisp implementation, and thus must
|
|
|
39 deal with the real data structures. If the Lisp implementation is
|
|
|
40 replaced, this file likely will not be used. */
|
|
27142
|
41
|
|
26164
|
42 #undef HIDE_LISP_IMPLEMENTATION
|
|
300
|
43 #include "lisp.h"
|
|
36435
|
44 #include "process.h"
|
|
1300
|
45 #include "intervals.h"
|
|
356
|
46 #include "puresize.h"
|
|
300
|
47 #include "buffer.h"
|
|
|
48 #include "window.h"
|
|
31102
|
49 #include "keyboard.h"
|
|
764
|
50 #include "frame.h"
|
|
2439
|
51 #include "blockinput.h"
|
21084
371ed7bdfd2b
(Fmake_string): Handle the case INIT is a multibyte character correctly.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
52 #include "charset.h"
|
|
638
|
53 #include "syssignal.h"
|
|
27738
|
54 #include <setjmp.h>
|
|
638
|
55
|
|
52547
|
56 /* GC_MALLOC_CHECK defined means perform validity checks of malloc'd
|
|
|
57 memory. Can do this only if using gmalloc.c. */
|
|
|
58
|
|
|
59 #if defined SYSTEM_MALLOC || defined DOUG_LEA_MALLOC
|
|
|
60 #undef GC_MALLOC_CHECK
|
|
|
61 #endif
|
|
|
62
|
|
30784
|
63 #ifdef HAVE_UNISTD_H
|
|
|
64 #include <unistd.h>
|
|
|
65 #else
|
|
|
66 extern POINTER_TYPE *sbrk ();
|
|
|
67 #endif
|
|
12096
|
68
|
|
67216
|
69 #ifdef HAVE_FCNTL_H
|
|
|
70 #define INCLUDED_FCNTL
|
|
|
71 #include <fcntl.h>
|
|
|
72 #endif
|
|
|
73 #ifndef O_WRONLY
|
|
|
74 #define O_WRONLY 1
|
|
|
75 #endif
|
|
|
76
|
|
17345
|
77 #ifdef DOUG_LEA_MALLOC
|
|
27142
|
78
|
|
17345
|
79 #include <malloc.h>
|
|
31892
|
80 /* malloc.h #defines this as size_t, at least in glibc2. */
|
|
|
81 #ifndef __malloc_size_t
|
|
17345
|
82 #define __malloc_size_t int
|
|
31892
|
83 #endif
|
|
23973
|
84
|
|
27142
|
85 /* Specify maximum number of areas to mmap. It would be nice to use a
|
|
|
86 value that explicitly means "no limit". */
|
|
|
87
|
|
23973
|
88 #define MMAP_MAX_AREAS 100000000
|
|
|
89
|
|
27142
|
90 #else /* not DOUG_LEA_MALLOC */
|
|
|
91
|
|
10673
|
92 /* The following come from gmalloc.c. */
|
|
|
93
|
|
|
94 #define __malloc_size_t size_t
|
|
|
95 extern __malloc_size_t _bytes_used;
|
|
31892
|
96 extern __malloc_size_t __malloc_extra_blocks;
|
|
27142
|
97
|
|
|
98 #endif /* not DOUG_LEA_MALLOC */
|
|
10673
|
99
|
|
58818
|
100 #if ! defined (SYSTEM_MALLOC) && defined (HAVE_GTK_AND_PTHREAD)
|
|
|
101
|
58831
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
102 /* When GTK uses the file chooser dialog, different backends can be loaded
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
103 dynamically. One such a backend is the Gnome VFS backend that gets loaded
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
104 if you run Gnome. That backend creates several threads and also allocates
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
105 memory with malloc.
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
106
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
107 If Emacs sets malloc hooks (! SYSTEM_MALLOC) and the emacs_blocked_*
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
108 functions below are called from malloc, there is a chance that one
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
109 of these threads preempts the Emacs main thread and the hook variables
|
|
58986
|
110 end up in an inconsistent state. So we have a mutex to prevent that (note
|
58831
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
111 that the backend handles concurrent access to malloc within its own threads
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
112 but Emacs code running in the main thread is not included in that control).
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
113
|
|
59359
|
114 When UNBLOCK_INPUT is called, reinvoke_input_signal may be called. If this
|
58831
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
115 happens in one of the backend threads we will have two threads that tries
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
116 to run Emacs code at once, and the code is not prepared for that.
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
117 To prevent that, we only call BLOCK/UNBLOCK from the main thread. */
|
408c5135b0a2
* alloc.c: Add comment about the reason for (UN)BLOCK_INPUT_ALLOC.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
118
|
|
58818
|
119 static pthread_mutex_t alloc_mutex;
|
|
|
120
|
|
|
121 #define BLOCK_INPUT_ALLOC \
|
|
|
122 do \
|
|
|
123 { \
|
|
|
124 pthread_mutex_lock (&alloc_mutex); \
|
|
|
125 if (pthread_self () == main_thread) \
|
|
|
126 BLOCK_INPUT; \
|
|
|
127 } \
|
|
|
128 while (0)
|
|
|
129 #define UNBLOCK_INPUT_ALLOC \
|
|
|
130 do \
|
|
|
131 { \
|
|
|
132 if (pthread_self () == main_thread) \
|
|
|
133 UNBLOCK_INPUT; \
|
|
|
134 pthread_mutex_unlock (&alloc_mutex); \
|
|
|
135 } \
|
|
|
136 while (0)
|
|
|
137
|
|
|
138 #else /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
|
|
|
139
|
|
|
140 #define BLOCK_INPUT_ALLOC BLOCK_INPUT
|
|
|
141 #define UNBLOCK_INPUT_ALLOC UNBLOCK_INPUT
|
|
|
142
|
|
|
143 #endif /* SYSTEM_MALLOC || not HAVE_GTK_AND_PTHREAD */
|
|
|
144
|
|
10673
|
145 /* Value of _bytes_used, when spare_memory was freed. */
|
|
27142
|
146
|
|
10673
|
147 static __malloc_size_t bytes_used_when_full;
|
|
|
148
|
|
66547
|
149 static __malloc_size_t bytes_used_when_reconsidered;
|
|
|
150
|
|
27142
|
151 /* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
|
|
|
152 to a struct Lisp_String. */
|
|
|
153
|
|
51985
|
154 #define MARK_STRING(S) ((S)->size |= ARRAY_MARK_FLAG)
|
|
|
155 #define UNMARK_STRING(S) ((S)->size &= ~ARRAY_MARK_FLAG)
|
|
59657
|
156 #define STRING_MARKED_P(S) (((S)->size & ARRAY_MARK_FLAG) != 0)
|
|
27142
|
157
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
158 #define VECTOR_MARK(V) ((V)->size |= ARRAY_MARK_FLAG)
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
159 #define VECTOR_UNMARK(V) ((V)->size &= ~ARRAY_MARK_FLAG)
|
|
59657
|
160 #define VECTOR_MARKED_P(V) (((V)->size & ARRAY_MARK_FLAG) != 0)
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
161
|
|
27142
|
162 /* Value is the number of bytes/chars of S, a pointer to a struct
|
|
|
163 Lisp_String. This must be used instead of STRING_BYTES (S) or
|
|
|
164 S->size during GC, because S->size contains the mark bit for
|
|
|
165 strings. */
|
|
|
166
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
167 #define GC_STRING_BYTES(S) (STRING_BYTES (S))
|
|
51985
|
168 #define GC_STRING_CHARS(S) ((S)->size & ~ARRAY_MARK_FLAG)
|
|
27142
|
169
|
|
|
170 /* Number of bytes of consing done since the last gc. */
|
|
|
171
|
|
300
|
172 int consing_since_gc;
|
|
|
173
|
|
12748
|
174 /* Count the amount of consing of various sorts of space. */
|
|
27142
|
175
|
43713
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
176 EMACS_INT cons_cells_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
177 EMACS_INT floats_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
178 EMACS_INT vector_cells_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
179 EMACS_INT symbols_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
180 EMACS_INT string_chars_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
181 EMACS_INT misc_objects_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
182 EMACS_INT intervals_consed;
|
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
183 EMACS_INT strings_consed;
|
|
27142
|
184
|
|
64611
|
185 /* Minimum number of bytes of consing since GC before next GC. */
|
|
|
186
|
|
|
187 EMACS_INT gc_cons_threshold;
|
|
|
188
|
|
|
189 /* Similar minimum, computed from Vgc_cons_percentage. */
|
|
|
190
|
|
|
191 EMACS_INT gc_relative_threshold;
|
|
|
192
|
64267
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
193 static Lisp_Object Vgc_cons_percentage;
|
|
300
|
194
|
|
66530
|
195 /* Minimum number of bytes of consing since GC before next GC,
|
|
|
196 when memory is full. */
|
|
|
197
|
|
|
198 EMACS_INT memory_full_cons_threshold;
|
|
|
199
|
|
27142
|
200 /* Nonzero during GC. */
|
|
|
201
|
|
300
|
202 int gc_in_progress;
|
|
|
203
|
|
50745
|
204 /* Nonzero means abort if try to GC.
|
|
|
205 This is for code which is written on the assumption that
|
|
|
206 no GC will happen, so as to verify that assumption. */
|
|
|
207
|
|
|
208 int abort_on_gc;
|
|
|
209
|
|
14959
|
210 /* Nonzero means display messages at beginning and end of GC. */
|
|
27142
|
211
|
|
14959
|
212 int garbage_collection_messages;
|
|
|
213
|
|
300
|
214 #ifndef VIRT_ADDR_VARIES
|
|
|
215 extern
|
|
|
216 #endif /* VIRT_ADDR_VARIES */
|
|
27142
|
217 int malloc_sbrk_used;
|
|
300
|
218
|
|
|
219 #ifndef VIRT_ADDR_VARIES
|
|
|
220 extern
|
|
|
221 #endif /* VIRT_ADDR_VARIES */
|
|
27142
|
222 int malloc_sbrk_unused;
|
|
300
|
223
|
|
27738
|
224 /* Number of live and free conses etc. */
|
|
|
225
|
|
|
226 static int total_conses, total_markers, total_symbols, total_vector_size;
|
|
|
227 static int total_free_conses, total_free_markers, total_free_symbols;
|
|
|
228 static int total_free_floats, total_floats;
|
|
19332
|
229
|
|
27142
|
230 /* Points to memory space allocated as "spare", to be freed if we run
|
|
66530
|
231 out of memory. We keep one large block, four cons-blocks, and
|
|
|
232 two string blocks. */
|
|
|
233
|
|
|
234 char *spare_memory[7];
|
|
|
235
|
|
|
236 /* Amount of spare memory to keep in large reserve block. */
|
|
27142
|
237
|
|
10673
|
238 #define SPARE_MEMORY (1 << 14)
|
|
|
239
|
|
|
240 /* Number of extra blocks malloc should get when it needs more core. */
|
|
27142
|
241
|
|
10673
|
242 static int malloc_hysteresis;
|
|
|
243
|
|
27142
|
244 /* Non-nil means defun should do purecopy on the function definition. */
|
|
|
245
|
|
300
|
246 Lisp_Object Vpurify_flag;
|
|
|
247
|
|
46305
|
248 /* Non-nil means we are handling a memory-full error. */
|
|
|
249
|
|
|
250 Lisp_Object Vmemory_full;
|
|
|
251
|
|
300
|
252 #ifndef HAVE_SHM
|
|
27142
|
253
|
|
57137
|
254 /* Initialize it to a nonzero value to force it into data space
|
|
|
255 (rather than bss space). That way unexec will remap it into text
|
|
|
256 space (pure), on some systems. We have not implemented the
|
|
|
257 remapping on more recent systems because this is less important
|
|
|
258 nowadays than in the days of small memories and timesharing. */
|
51908
cb3976b5e59f
(pure, staticvec): Initialize these arrays to nonzero, so that they're
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
259
|
cb3976b5e59f
(pure, staticvec): Initialize these arrays to nonzero, so that they're
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
260 EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = {1,};
|
|
300
|
261 #define PUREBEG (char *) pure
|
|
27142
|
262
|
|
39572
|
263 #else /* HAVE_SHM */
|
|
27142
|
264
|
|
300
|
265 #define pure PURE_SEG_BITS /* Use shared memory segment */
|
|
|
266 #define PUREBEG (char *)PURE_SEG_BITS
|
|
356
|
267
|
|
39572
|
268 #endif /* HAVE_SHM */
|
|
|
269
|
|
|
270 /* Pointer to the pure area, and its size. */
|
|
|
271
|
|
|
272 static char *purebeg;
|
|
|
273 static size_t pure_size;
|
|
|
274
|
|
|
275 /* Number of bytes of pure storage used before pure storage overflowed.
|
|
|
276 If this is non-zero, this implies that an overflow occurred. */
|
|
|
277
|
|
|
278 static size_t pure_bytes_used_before_overflow;
|
|
300
|
279
|
|
27738
|
280 /* Value is non-zero if P points into pure space. */
|
|
|
281
|
|
|
282 #define PURE_POINTER_P(P) \
|
|
|
283 (((PNTR_COMPARISON_TYPE) (P) \
|
|
39572
|
284 < (PNTR_COMPARISON_TYPE) ((char *) purebeg + pure_size)) \
|
|
27738
|
285 && ((PNTR_COMPARISON_TYPE) (P) \
|
|
39572
|
286 >= (PNTR_COMPARISON_TYPE) purebeg))
|
|
27738
|
287
|
|
27142
|
288 /* Index in pure at which next pure object will be allocated.. */
|
|
|
289
|
43713
f92c4d87863a
Change defvar_int def and vars to use EMACS_INT instead of just int.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
290 EMACS_INT pure_bytes_used;
|
|
300
|
291
|
|
27142
|
292 /* If nonzero, this is a warning delivered by malloc and not yet
|
|
|
293 displayed. */
|
|
|
294
|
|
300
|
295 char *pending_malloc_warning;
|
|
|
296
|
6116
64417bbbb128
(memory_full): Use new variable memory_signal_data with precomputed value
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
297 /* Pre-computed signal argument for use when memory is exhausted. */
|
|
27142
|
298
|
|
46305
|
299 Lisp_Object Vmemory_signal_data;
|
6116
64417bbbb128
(memory_full): Use new variable memory_signal_data with precomputed value
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
300
|
|
300
|
301 /* Maximum amount of C stack to save when a GC happens. */
|
|
|
302
|
|
|
303 #ifndef MAX_SAVE_STACK
|
|
|
304 #define MAX_SAVE_STACK 16000
|
|
|
305 #endif
|
|
|
306
|
|
|
307 /* Buffer in which we save a copy of the C stack at each GC. */
|
|
|
308
|
|
|
309 char *stack_copy;
|
|
|
310 int stack_copy_size;
|
|
|
311
|
|
27142
|
312 /* Non-zero means ignore malloc warnings. Set during initialization.
|
|
|
313 Currently not used. */
|
|
|
314
|
|
300
|
315 int ignore_warnings;
|
|
1318
|
316
|
|
13219
|
317 Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots;
|
|
11374
|
318
|
|
39572
|
319 /* Hook run after GC has finished. */
|
|
|
320
|
|
|
321 Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
|
|
|
322
|
|
49529
|
323 Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */
|
|
|
324 EMACS_INT gcs_done; /* accumulated GCs */
|
|
|
325
|
|
27142
|
326 static void mark_buffer P_ ((Lisp_Object));
|
|
51578
|
327 extern void mark_kboards P_ ((void));
|
|
55798
|
328 extern void mark_backtrace P_ ((void));
|
|
27142
|
329 static void gc_sweep P_ ((void));
|
|
25024
|
330 static void mark_glyph_matrix P_ ((struct glyph_matrix *));
|
|
|
331 static void mark_face_cache P_ ((struct face_cache *));
|
|
|
332
|
|
|
333 #ifdef HAVE_WINDOW_SYSTEM
|
|
59400
|
334 extern void mark_fringe_data P_ ((void));
|
|
25024
|
335 static void mark_image P_ ((struct image *));
|
|
|
336 static void mark_image_cache P_ ((struct frame *));
|
|
|
337 #endif /* HAVE_WINDOW_SYSTEM */
|
|
|
338
|
|
27142
|
339 static struct Lisp_String *allocate_string P_ ((void));
|
|
|
340 static void compact_small_strings P_ ((void));
|
|
|
341 static void free_large_strings P_ ((void));
|
|
|
342 static void sweep_strings P_ ((void));
|
|
20495
|
343
|
|
|
344 extern int message_enable_multibyte;
|
|
27738
|
345
|
|
|
346 /* When scanning the C stack for live Lisp objects, Emacs keeps track
|
|
|
347 of what memory allocated via lisp_malloc is intended for what
|
|
|
348 purpose. This enumeration specifies the type of memory. */
|
|
|
349
|
|
|
350 enum mem_type
|
|
|
351 {
|
|
|
352 MEM_TYPE_NON_LISP,
|
|
|
353 MEM_TYPE_BUFFER,
|
|
|
354 MEM_TYPE_CONS,
|
|
|
355 MEM_TYPE_STRING,
|
|
|
356 MEM_TYPE_MISC,
|
|
|
357 MEM_TYPE_SYMBOL,
|
|
|
358 MEM_TYPE_FLOAT,
|
|
36435
|
359 /* Keep the following vector-like types together, with
|
|
|
360 MEM_TYPE_WINDOW being the last, and MEM_TYPE_VECTOR the
|
|
|
361 first. Or change the code of live_vector_p, for instance. */
|
|
|
362 MEM_TYPE_VECTOR,
|
|
|
363 MEM_TYPE_PROCESS,
|
|
|
364 MEM_TYPE_HASH_TABLE,
|
|
|
365 MEM_TYPE_FRAME,
|
|
|
366 MEM_TYPE_WINDOW
|
|
27738
|
367 };
|
|
|
368
|
|
66530
|
369 static POINTER_TYPE *lisp_align_malloc P_ ((size_t, enum mem_type));
|
|
|
370 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
|
|
66662
|
371 void refill_memory_reserve ();
|
|
|
372
|
|
66530
|
373
|
|
32692
|
374 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
|
|
27746
|
375
|
|
|
376 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
377 #include <stdio.h> /* For fprintf. */
|
|
|
378 #endif
|
|
|
379
|
|
|
380 /* A unique object in pure space used to make some Lisp objects
|
|
|
381 on free lists recognizable in O(1). */
|
|
|
382
|
|
|
383 Lisp_Object Vdead;
|
|
|
384
|
|
32692
|
385 #ifdef GC_MALLOC_CHECK
|
|
|
386
|
|
|
387 enum mem_type allocated_mem_type;
|
|
|
388 int dont_register_blocks;
|
|
|
389
|
|
|
390 #endif /* GC_MALLOC_CHECK */
|
|
|
391
|
|
|
392 /* A node in the red-black tree describing allocated memory containing
|
|
|
393 Lisp data. Each such block is recorded with its start and end
|
|
|
394 address when it is allocated, and removed from the tree when it
|
|
|
395 is freed.
|
|
|
396
|
|
|
397 A red-black tree is a balanced binary tree with the following
|
|
|
398 properties:
|
|
|
399
|
|
|
400 1. Every node is either red or black.
|
|
|
401 2. Every leaf is black.
|
|
|
402 3. If a node is red, then both of its children are black.
|
|
|
403 4. Every simple path from a node to a descendant leaf contains
|
|
|
404 the same number of black nodes.
|
|
|
405 5. The root is always black.
|
|
|
406
|
|
|
407 When nodes are inserted into the tree, or deleted from the tree,
|
|
|
408 the tree is "fixed" so that these properties are always true.
|
|
|
409
|
|
|
410 A red-black tree with N internal nodes has height at most 2
|
|
|
411 log(N+1). Searches, insertions and deletions are done in O(log N).
|
|
|
412 Please see a text book about data structures for a detailed
|
|
|
413 description of red-black trees. Any book worth its salt should
|
|
|
414 describe them. */
|
|
|
415
|
|
|
416 struct mem_node
|
|
|
417 {
|
|
48907
|
418 /* Children of this node. These pointers are never NULL. When there
|
|
|
419 is no child, the value is MEM_NIL, which points to a dummy node. */
|
|
|
420 struct mem_node *left, *right;
|
|
|
421
|
|
|
422 /* The parent of this node. In the root node, this is NULL. */
|
|
|
423 struct mem_node *parent;
|
|
32692
|
424
|
|
|
425 /* Start and end of allocated region. */
|
|
|
426 void *start, *end;
|
|
|
427
|
|
|
428 /* Node color. */
|
|
|
429 enum {MEM_BLACK, MEM_RED} color;
|
|
49600
|
430
|
|
32692
|
431 /* Memory type. */
|
|
|
432 enum mem_type type;
|
|
|
433 };
|
|
|
434
|
|
|
435 /* Base address of stack. Set in main. */
|
|
|
436
|
|
|
437 Lisp_Object *stack_base;
|
|
|
438
|
|
|
439 /* Root of the tree describing allocated Lisp memory. */
|
|
|
440
|
|
|
441 static struct mem_node *mem_root;
|
|
|
442
|
|
36435
|
443 /* Lowest and highest known address in the heap. */
|
|
|
444
|
|
|
445 static void *min_heap_address, *max_heap_address;
|
|
|
446
|
|
32692
|
447 /* Sentinel node of the tree. */
|
|
|
448
|
|
|
449 static struct mem_node mem_z;
|
|
|
450 #define MEM_NIL &mem_z
|
|
|
451
|
|
30914
|
452 static POINTER_TYPE *lisp_malloc P_ ((size_t, enum mem_type));
|
|
36435
|
453 static struct Lisp_Vector *allocate_vectorlike P_ ((EMACS_INT, enum mem_type));
|
|
30784
|
454 static void lisp_free P_ ((POINTER_TYPE *));
|
|
27738
|
455 static void mark_stack P_ ((void));
|
|
|
456 static int live_vector_p P_ ((struct mem_node *, void *));
|
|
|
457 static int live_buffer_p P_ ((struct mem_node *, void *));
|
|
|
458 static int live_string_p P_ ((struct mem_node *, void *));
|
|
|
459 static int live_cons_p P_ ((struct mem_node *, void *));
|
|
|
460 static int live_symbol_p P_ ((struct mem_node *, void *));
|
|
|
461 static int live_float_p P_ ((struct mem_node *, void *));
|
|
|
462 static int live_misc_p P_ ((struct mem_node *, void *));
|
|
28365
|
463 static void mark_maybe_object P_ ((Lisp_Object));
|
|
27738
|
464 static void mark_memory P_ ((void *, void *));
|
|
|
465 static void mem_init P_ ((void));
|
|
|
466 static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
|
|
|
467 static void mem_insert_fixup P_ ((struct mem_node *));
|
|
|
468 static void mem_rotate_left P_ ((struct mem_node *));
|
|
|
469 static void mem_rotate_right P_ ((struct mem_node *));
|
|
|
470 static void mem_delete P_ ((struct mem_node *));
|
|
|
471 static void mem_delete_fixup P_ ((struct mem_node *));
|
|
|
472 static INLINE struct mem_node *mem_find P_ ((void *));
|
|
66530
|
473
|
|
27738
|
474
|
|
|
475 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
|
|
|
476 static void check_gcpros P_ ((void));
|
|
|
477 #endif
|
|
|
478
|
|
32692
|
479 #endif /* GC_MARK_STACK || GC_MALLOC_CHECK */
|
|
27738
|
480
|
|
32594
|
481 /* Recording what needs to be marked for gc. */
|
|
|
482
|
|
|
483 struct gcpro *gcprolist;
|
|
|
484
|
51908
cb3976b5e59f
(pure, staticvec): Initialize these arrays to nonzero, so that they're
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
485 /* Addresses of staticpro'd variables. Initialize it to a nonzero
|
cb3976b5e59f
(pure, staticvec): Initialize these arrays to nonzero, so that they're
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
486 value; otherwise some compilers put it into BSS. */
|
|
32594
|
487
|
|
43313
|
488 #define NSTATICS 1280
|
51908
cb3976b5e59f
(pure, staticvec): Initialize these arrays to nonzero, so that they're
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
489 Lisp_Object *staticvec[NSTATICS] = {&Vpurify_flag};
|
|
32594
|
490
|
|
|
491 /* Index of next unused slot in staticvec. */
|
|
|
492
|
|
|
493 int staticidx = 0;
|
|
|
494
|
|
|
495 static POINTER_TYPE *pure_alloc P_ ((size_t, int));
|
|
|
496
|
|
|
497
|
|
|
498 /* Value is SZ rounded up to the next multiple of ALIGNMENT.
|
|
|
499 ALIGNMENT must be a power of 2. */
|
|
|
500
|
|
51723
|
501 #define ALIGN(ptr, ALIGNMENT) \
|
|
|
502 ((POINTER_TYPE *) ((((EMACS_UINT)(ptr)) + (ALIGNMENT) - 1) \
|
|
|
503 & ~((ALIGNMENT) - 1)))
|
|
32594
|
504
|
|
36435
|
505
|
|
300
|
506
|
|
27738
|
507 /************************************************************************
|
|
|
508 Malloc
|
|
|
509 ************************************************************************/
|
|
|
510
|
|
47185
|
511 /* Function malloc calls this if it finds we are near exhausting storage. */
|
|
20375
|
512
|
|
|
513 void
|
|
300
|
514 malloc_warning (str)
|
|
|
515 char *str;
|
|
|
516 {
|
|
|
517 pending_malloc_warning = str;
|
|
|
518 }
|
|
|
519
|
|
27738
|
520
|
|
47185
|
521 /* Display an already-pending malloc warning. */
|
|
27738
|
522
|
|
20375
|
523 void
|
|
300
|
524 display_malloc_warning ()
|
|
|
525 {
|
|
47185
|
526 call3 (intern ("display-warning"),
|
|
|
527 intern ("alloc"),
|
|
|
528 build_string (pending_malloc_warning),
|
|
|
529 intern ("emergency"));
|
|
300
|
530 pending_malloc_warning = 0;
|
|
|
531 }
|
|
|
532
|
|
27738
|
533
|
|
17345
|
534 #ifdef DOUG_LEA_MALLOC
|
|
66547
|
535 # define BYTES_USED (mallinfo ().uordblks)
|
|
17345
|
536 #else
|
|
17831
|
537 # define BYTES_USED _bytes_used
|
|
17345
|
538 #endif
|
65832
5159ee08b219
(refill_memory_reserve): Conditionalize the body, not the function's existence.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
539
|
|
10673
|
540 /* Called if we can't allocate relocatable space for a buffer. */
|
|
|
541
|
|
|
542 void
|
|
|
543 buffer_memory_full ()
|
|
|
544 {
|
|
27142
|
545 /* If buffers use the relocating allocator, no need to free
|
|
|
546 spare_memory, because we may have plenty of malloc space left
|
|
|
547 that we could get, and if we don't, the malloc that fails will
|
|
|
548 itself cause spare_memory to be freed. If buffers don't use the
|
|
|
549 relocating allocator, treat this like any other failing
|
|
|
550 malloc. */
|
|
10673
|
551
|
|
|
552 #ifndef REL_ALLOC
|
|
|
553 memory_full ();
|
|
|
554 #endif
|
|
|
555
|
|
27142
|
556 /* This used to call error, but if we've run out of memory, we could
|
|
|
557 get infinite recursion trying to build the string. */
|
6116
64417bbbb128
(memory_full): Use new variable memory_signal_data with precomputed value
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
558 while (1)
|
|
46305
|
559 Fsignal (Qnil, Vmemory_signal_data);
|
|
300
|
560 }
|
|
|
561
|
|
27738
|
562
|
|
58631
|
563 #ifdef XMALLOC_OVERRUN_CHECK
|
|
|
564
|
|
58707
|
565 /* Check for overrun in malloc'ed buffers by wrapping a 16 byte header
|
|
|
566 and a 16 byte trailer around each block.
|
|
|
567
|
|
|
568 The header consists of 12 fixed bytes + a 4 byte integer contaning the
|
|
|
569 original block size, while the trailer consists of 16 fixed bytes.
|
|
|
570
|
|
|
571 The header is used to detect whether this block has been allocated
|
|
|
572 through these functions -- as it seems that some low-level libc
|
|
|
573 functions may bypass the malloc hooks.
|
|
|
574 */
|
|
|
575
|
|
|
576
|
|
58631
|
577 #define XMALLOC_OVERRUN_CHECK_SIZE 16
|
|
58707
|
578
|
|
58631
|
579 static char xmalloc_overrun_check_header[XMALLOC_OVERRUN_CHECK_SIZE-4] =
|
|
|
580 { 0x9a, 0x9b, 0xae, 0xaf,
|
|
|
581 0xbf, 0xbe, 0xce, 0xcf,
|
|
|
582 0xea, 0xeb, 0xec, 0xed };
|
|
|
583
|
|
|
584 static char xmalloc_overrun_check_trailer[XMALLOC_OVERRUN_CHECK_SIZE] =
|
|
|
585 { 0xaa, 0xab, 0xac, 0xad,
|
|
|
586 0xba, 0xbb, 0xbc, 0xbd,
|
|
|
587 0xca, 0xcb, 0xcc, 0xcd,
|
|
|
588 0xda, 0xdb, 0xdc, 0xdd };
|
|
|
589
|
|
58707
|
590 /* Macros to insert and extract the block size in the header. */
|
|
|
591
|
|
|
592 #define XMALLOC_PUT_SIZE(ptr, size) \
|
|
|
593 (ptr[-1] = (size & 0xff), \
|
|
|
594 ptr[-2] = ((size >> 8) & 0xff), \
|
|
|
595 ptr[-3] = ((size >> 16) & 0xff), \
|
|
|
596 ptr[-4] = ((size >> 24) & 0xff))
|
|
|
597
|
|
|
598 #define XMALLOC_GET_SIZE(ptr) \
|
|
|
599 (size_t)((unsigned)(ptr[-1]) | \
|
|
|
600 ((unsigned)(ptr[-2]) << 8) | \
|
|
|
601 ((unsigned)(ptr[-3]) << 16) | \
|
|
|
602 ((unsigned)(ptr[-4]) << 24))
|
|
|
603
|
|
|
604
|
|
59083
|
605 /* The call depth in overrun_check functions. For example, this might happen:
|
|
|
606 xmalloc()
|
|
|
607 overrun_check_malloc()
|
|
|
608 -> malloc -> (via hook)_-> emacs_blocked_malloc
|
|
|
609 -> overrun_check_malloc
|
|
|
610 call malloc (hooks are NULL, so real malloc is called).
|
|
|
611 malloc returns 10000.
|
|
|
612 add overhead, return 10016.
|
|
|
613 <- (back in overrun_check_malloc)
|
|
59082
|
614 add overhead again, return 10032
|
|
59083
|
615 xmalloc returns 10032.
|
|
59082
|
616
|
|
|
617 (time passes).
|
|
|
618
|
|
59083
|
619 xfree(10032)
|
|
|
620 overrun_check_free(10032)
|
|
|
621 decrease overhed
|
|
|
622 free(10016) <- crash, because 10000 is the original pointer. */
|
|
59082
|
623
|
|
|
624 static int check_depth;
|
|
|
625
|
|
58707
|
626 /* Like malloc, but wraps allocated block with header and trailer. */
|
|
|
627
|
|
58631
|
628 POINTER_TYPE *
|
|
|
629 overrun_check_malloc (size)
|
|
|
630 size_t size;
|
|
|
631 {
|
|
58707
|
632 register unsigned char *val;
|
|
59082
|
633 size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
|
|
|
634
|
|
|
635 val = (unsigned char *) malloc (size + overhead);
|
|
|
636 if (val && check_depth == 1)
|
|
58631
|
637 {
|
|
|
638 bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
|
|
|
639 val += XMALLOC_OVERRUN_CHECK_SIZE;
|
|
58707
|
640 XMALLOC_PUT_SIZE(val, size);
|
|
58631
|
641 bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
|
|
|
642 }
|
|
59082
|
643 --check_depth;
|
|
58631
|
644 return (POINTER_TYPE *)val;
|
|
|
645 }
|
|
|
646
|
|
58707
|
647
|
|
|
648 /* Like realloc, but checks old block for overrun, and wraps new block
|
|
|
649 with header and trailer. */
|
|
|
650
|
|
58631
|
651 POINTER_TYPE *
|
|
|
652 overrun_check_realloc (block, size)
|
|
|
653 POINTER_TYPE *block;
|
|
|
654 size_t size;
|
|
|
655 {
|
|
58707
|
656 register unsigned char *val = (unsigned char *)block;
|
|
59082
|
657 size_t overhead = ++check_depth == 1 ? XMALLOC_OVERRUN_CHECK_SIZE*2 : 0;
|
|
58631
|
658
|
|
|
659 if (val
|
|
59082
|
660 && check_depth == 1
|
|
58631
|
661 && bcmp (xmalloc_overrun_check_header,
|
|
|
662 val - XMALLOC_OVERRUN_CHECK_SIZE,
|
|
|
663 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
|
|
|
664 {
|
|
58707
|
665 size_t osize = XMALLOC_GET_SIZE (val);
|
|
58631
|
666 if (bcmp (xmalloc_overrun_check_trailer,
|
|
|
667 val + osize,
|
|
|
668 XMALLOC_OVERRUN_CHECK_SIZE))
|
|
|
669 abort ();
|
|
58707
|
670 bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
|
|
58631
|
671 val -= XMALLOC_OVERRUN_CHECK_SIZE;
|
|
58707
|
672 bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
|
|
58631
|
673 }
|
|
|
674
|
|
59082
|
675 val = (unsigned char *) realloc ((POINTER_TYPE *)val, size + overhead);
|
|
|
676
|
|
|
677 if (val && check_depth == 1)
|
|
58631
|
678 {
|
|
|
679 bcopy (xmalloc_overrun_check_header, val, XMALLOC_OVERRUN_CHECK_SIZE - 4);
|
|
|
680 val += XMALLOC_OVERRUN_CHECK_SIZE;
|
|
58707
|
681 XMALLOC_PUT_SIZE(val, size);
|
|
58631
|
682 bcopy (xmalloc_overrun_check_trailer, val + size, XMALLOC_OVERRUN_CHECK_SIZE);
|
|
|
683 }
|
|
59082
|
684 --check_depth;
|
|
58631
|
685 return (POINTER_TYPE *)val;
|
|
|
686 }
|
|
|
687
|
|
58707
|
688 /* Like free, but checks block for overrun. */
|
|
|
689
|
|
58631
|
690 void
|
|
|
691 overrun_check_free (block)
|
|
|
692 POINTER_TYPE *block;
|
|
|
693 {
|
|
58707
|
694 unsigned char *val = (unsigned char *)block;
|
|
58631
|
695
|
|
59082
|
696 ++check_depth;
|
|
58631
|
697 if (val
|
|
59082
|
698 && check_depth == 1
|
|
58631
|
699 && bcmp (xmalloc_overrun_check_header,
|
|
|
700 val - XMALLOC_OVERRUN_CHECK_SIZE,
|
|
|
701 XMALLOC_OVERRUN_CHECK_SIZE - 4) == 0)
|
|
|
702 {
|
|
58707
|
703 size_t osize = XMALLOC_GET_SIZE (val);
|
|
58631
|
704 if (bcmp (xmalloc_overrun_check_trailer,
|
|
|
705 val + osize,
|
|
|
706 XMALLOC_OVERRUN_CHECK_SIZE))
|
|
|
707 abort ();
|
|
59400
|
708 #ifdef XMALLOC_CLEAR_FREE_MEMORY
|
|
|
709 val -= XMALLOC_OVERRUN_CHECK_SIZE;
|
|
|
710 memset (val, 0xff, osize + XMALLOC_OVERRUN_CHECK_SIZE*2);
|
|
|
711 #else
|
|
58707
|
712 bzero (val + osize, XMALLOC_OVERRUN_CHECK_SIZE);
|
|
58631
|
713 val -= XMALLOC_OVERRUN_CHECK_SIZE;
|
|
58707
|
714 bzero (val, XMALLOC_OVERRUN_CHECK_SIZE);
|
|
59400
|
715 #endif
|
|
58631
|
716 }
|
|
|
717
|
|
|
718 free (val);
|
|
59082
|
719 --check_depth;
|
|
58631
|
720 }
|
|
|
721
|
|
|
722 #undef malloc
|
|
|
723 #undef realloc
|
|
|
724 #undef free
|
|
|
725 #define malloc overrun_check_malloc
|
|
|
726 #define realloc overrun_check_realloc
|
|
|
727 #define free overrun_check_free
|
|
|
728 #endif
|
|
|
729
|
|
58707
|
730
|
|
|
731 /* Like malloc but check for no memory and block interrupt input.. */
|
|
|
732
|
|
29781
|
733 POINTER_TYPE *
|
|
300
|
734 xmalloc (size)
|
|
30557
|
735 size_t size;
|
|
300
|
736 {
|
|
29781
|
737 register POINTER_TYPE *val;
|
|
300
|
738
|
|
2439
|
739 BLOCK_INPUT;
|
|
29781
|
740 val = (POINTER_TYPE *) malloc (size);
|
|
2439
|
741 UNBLOCK_INPUT;
|
|
300
|
742
|
|
27142
|
743 if (!val && size)
|
|
|
744 memory_full ();
|
|
300
|
745 return val;
|
|
|
746 }
|
|
|
747
|
|
27738
|
748
|
|
|
749 /* Like realloc but check for no memory and block interrupt input.. */
|
|
|
750
|
|
29781
|
751 POINTER_TYPE *
|
|
300
|
752 xrealloc (block, size)
|
|
29781
|
753 POINTER_TYPE *block;
|
|
30557
|
754 size_t size;
|
|
300
|
755 {
|
|
29781
|
756 register POINTER_TYPE *val;
|
|
300
|
757
|
|
2439
|
758 BLOCK_INPUT;
|
|
590
|
759 /* We must call malloc explicitly when BLOCK is 0, since some
|
|
|
760 reallocs don't do this. */
|
|
|
761 if (! block)
|
|
29781
|
762 val = (POINTER_TYPE *) malloc (size);
|
|
600
|
763 else
|
|
29781
|
764 val = (POINTER_TYPE *) realloc (block, size);
|
|
2439
|
765 UNBLOCK_INPUT;
|
|
300
|
766
|
|
|
767 if (!val && size) memory_full ();
|
|
|
768 return val;
|
|
|
769 }
|
|
2439
|
770
|
|
27738
|
771
|
|
52276
|
772 /* Like free but block interrupt input. */
|
|
27738
|
773
|
|
2439
|
774 void
|
|
|
775 xfree (block)
|
|
29781
|
776 POINTER_TYPE *block;
|
|
2439
|
777 {
|
|
|
778 BLOCK_INPUT;
|
|
|
779 free (block);
|
|
|
780 UNBLOCK_INPUT;
|
|
66530
|
781 /* We don't call refill_memory_reserve here
|
|
|
782 because that duplicates doing so in emacs_blocked_free
|
|
|
783 and the criterion should go there. */
|
|
2439
|
784 }
|
|
|
785
|
|
27738
|
786
|
|
28411
|
787 /* Like strdup, but uses xmalloc. */
|
|
|
788
|
|
|
789 char *
|
|
|
790 xstrdup (s)
|
|
46459
|
791 const char *s;
|
|
28411
|
792 {
|
|
30557
|
793 size_t len = strlen (s) + 1;
|
|
28411
|
794 char *p = (char *) xmalloc (len);
|
|
|
795 bcopy (s, p, len);
|
|
|
796 return p;
|
|
|
797 }
|
|
|
798
|
|
|
799
|
|
56187
|
800 /* Unwind for SAFE_ALLOCA */
|
|
|
801
|
|
|
802 Lisp_Object
|
|
|
803 safe_alloca_unwind (arg)
|
|
|
804 Lisp_Object arg;
|
|
|
805 {
|
|
56202
|
806 register struct Lisp_Save_Value *p = XSAVE_VALUE (arg);
|
|
|
807
|
|
|
808 p->dogc = 0;
|
|
|
809 xfree (p->pointer);
|
|
|
810 p->pointer = 0;
|
|
56239
|
811 free_misc (arg);
|
|
56187
|
812 return Qnil;
|
|
|
813 }
|
|
|
814
|
|
|
815
|
|
27738
|
816 /* Like malloc but used for allocating Lisp data. NBYTES is the
|
|
|
817 number of bytes to allocate, TYPE describes the intended use of the
|
|
|
818 allcated memory block (for strings, for conses, ...). */
|
|
|
819
|
|
58631
|
820 #ifndef USE_LSB_TAG
|
|
50468
|
821 static void *lisp_malloc_loser;
|
|
58631
|
822 #endif
|
|
50468
|
823
|
|
30557
|
824 static POINTER_TYPE *
|
|
27738
|
825 lisp_malloc (nbytes, type)
|
|
30557
|
826 size_t nbytes;
|
|
27738
|
827 enum mem_type type;
|
|
23958
|
828 {
|
|
27738
|
829 register void *val;
|
|
23958
|
830
|
|
|
831 BLOCK_INPUT;
|
|
32692
|
832
|
|
|
833 #ifdef GC_MALLOC_CHECK
|
|
|
834 allocated_mem_type = type;
|
|
|
835 #endif
|
|
49600
|
836
|
|
27738
|
837 val = (void *) malloc (nbytes);
|
|
28411
|
838
|
|
53650
|
839 #ifndef USE_LSB_TAG
|
|
50468
|
840 /* If the memory just allocated cannot be addressed thru a Lisp
|
|
|
841 object's pointer, and it needs to be,
|
|
|
842 that's equivalent to running out of memory. */
|
|
|
843 if (val && type != MEM_TYPE_NON_LISP)
|
|
|
844 {
|
|
|
845 Lisp_Object tem;
|
|
|
846 XSETCONS (tem, (char *) val + nbytes - 1);
|
|
|
847 if ((char *) XCONS (tem) != (char *) val + nbytes - 1)
|
|
|
848 {
|
|
|
849 lisp_malloc_loser = val;
|
|
|
850 free (val);
|
|
|
851 val = 0;
|
|
|
852 }
|
|
|
853 }
|
|
53650
|
854 #endif
|
|
50468
|
855
|
|
32692
|
856 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
|
|
28411
|
857 if (val && type != MEM_TYPE_NON_LISP)
|
|
27738
|
858 mem_insert (val, (char *) val + nbytes, type);
|
|
|
859 #endif
|
|
49600
|
860
|
|
28411
|
861 UNBLOCK_INPUT;
|
|
|
862 if (!val && nbytes)
|
|
|
863 memory_full ();
|
|
23958
|
864 return val;
|
|
|
865 }
|
|
|
866
|
|
27738
|
867 /* Free BLOCK. This must be called to free memory allocated with a
|
|
|
868 call to lisp_malloc. */
|
|
|
869
|
|
30784
|
870 static void
|
|
23958
|
871 lisp_free (block)
|
|
30557
|
872 POINTER_TYPE *block;
|
|
23958
|
873 {
|
|
|
874 BLOCK_INPUT;
|
|
|
875 free (block);
|
|
32692
|
876 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
|
|
27738
|
877 mem_delete (mem_find (block));
|
|
|
878 #endif
|
|
23958
|
879 UNBLOCK_INPUT;
|
|
|
880 }
|
|
27738
|
881
|
|
51723
|
882 /* Allocation of aligned blocks of memory to store Lisp data. */
|
|
|
883 /* The entry point is lisp_align_malloc which returns blocks of at most */
|
|
|
884 /* BLOCK_BYTES and guarantees they are aligned on a BLOCK_ALIGN boundary. */
|
|
|
885
|
|
|
886
|
|
|
887 /* BLOCK_ALIGN has to be a power of 2. */
|
|
|
888 #define BLOCK_ALIGN (1 << 10)
|
|
|
889
|
|
|
890 /* Padding to leave at the end of a malloc'd block. This is to give
|
|
|
891 malloc a chance to minimize the amount of memory wasted to alignment.
|
|
|
892 It should be tuned to the particular malloc library used.
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
893 On glibc-2.3.2, malloc never tries to align, so a padding of 0 is best.
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
894 posix_memalign on the other hand would ideally prefer a value of 4
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
895 because otherwise, there's 1020 bytes wasted between each ablocks.
|
|
60143
|
896 In Emacs, testing shows that those 1020 can most of the time be
|
|
|
897 efficiently used by malloc to place other objects, so a value of 0 can
|
|
|
898 still preferable unless you have a lot of aligned blocks and virtually
|
|
|
899 nothing else. */
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
900 #define BLOCK_PADDING 0
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
901 #define BLOCK_BYTES \
|
|
60143
|
902 (BLOCK_ALIGN - sizeof (struct ablock *) - BLOCK_PADDING)
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
903
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
904 /* Internal data structures and constants. */
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
905
|
|
51723
|
906 #define ABLOCKS_SIZE 16
|
|
|
907
|
|
|
908 /* An aligned block of memory. */
|
|
|
909 struct ablock
|
|
|
910 {
|
|
|
911 union
|
|
|
912 {
|
|
|
913 char payload[BLOCK_BYTES];
|
|
|
914 struct ablock *next_free;
|
|
|
915 } x;
|
|
|
916 /* `abase' is the aligned base of the ablocks. */
|
|
|
917 /* It is overloaded to hold the virtual `busy' field that counts
|
|
|
918 the number of used ablock in the parent ablocks.
|
|
|
919 The first ablock has the `busy' field, the others have the `abase'
|
|
|
920 field. To tell the difference, we assume that pointers will have
|
|
|
921 integer values larger than 2 * ABLOCKS_SIZE. The lowest bit of `busy'
|
|
|
922 is used to tell whether the real base of the parent ablocks is `abase'
|
|
|
923 (if not, the word before the first ablock holds a pointer to the
|
|
|
924 real base). */
|
|
|
925 struct ablocks *abase;
|
|
|
926 /* The padding of all but the last ablock is unused. The padding of
|
|
|
927 the last ablock in an ablocks is not allocated. */
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
928 #if BLOCK_PADDING
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
929 char padding[BLOCK_PADDING];
|
|
51758
|
930 #endif
|
|
51723
|
931 };
|
|
|
932
|
|
|
933 /* A bunch of consecutive aligned blocks. */
|
|
|
934 struct ablocks
|
|
|
935 {
|
|
|
936 struct ablock blocks[ABLOCKS_SIZE];
|
|
|
937 };
|
|
|
938
|
|
|
939 /* Size of the block requested from malloc or memalign. */
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
940 #define ABLOCKS_BYTES (sizeof (struct ablocks) - BLOCK_PADDING)
|
|
51723
|
941
|
|
|
942 #define ABLOCK_ABASE(block) \
|
|
|
943 (((unsigned long) (block)->abase) <= (1 + 2 * ABLOCKS_SIZE) \
|
|
|
944 ? (struct ablocks *)(block) \
|
|
|
945 : (block)->abase)
|
|
|
946
|
|
|
947 /* Virtual `busy' field. */
|
|
|
948 #define ABLOCKS_BUSY(abase) ((abase)->blocks[0].abase)
|
|
|
949
|
|
|
950 /* Pointer to the (not necessarily aligned) malloc block. */
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
951 #ifdef HAVE_POSIX_MEMALIGN
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
952 #define ABLOCKS_BASE(abase) (abase)
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
953 #else
|
|
51723
|
954 #define ABLOCKS_BASE(abase) \
|
|
52453
|
955 (1 & (long) ABLOCKS_BUSY (abase) ? abase : ((void**)abase)[-1])
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
956 #endif
|
|
51723
|
957
|
|
|
958 /* The list of free ablock. */
|
|
|
959 static struct ablock *free_ablock;
|
|
|
960
|
|
|
961 /* Allocate an aligned block of nbytes.
|
|
|
962 Alignment is on a multiple of BLOCK_ALIGN and `nbytes' has to be
|
|
|
963 smaller or equal to BLOCK_BYTES. */
|
|
|
964 static POINTER_TYPE *
|
|
|
965 lisp_align_malloc (nbytes, type)
|
|
|
966 size_t nbytes;
|
|
|
967 enum mem_type type;
|
|
|
968 {
|
|
|
969 void *base, *val;
|
|
|
970 struct ablocks *abase;
|
|
|
971
|
|
|
972 eassert (nbytes <= BLOCK_BYTES);
|
|
|
973
|
|
|
974 BLOCK_INPUT;
|
|
|
975
|
|
|
976 #ifdef GC_MALLOC_CHECK
|
|
|
977 allocated_mem_type = type;
|
|
|
978 #endif
|
|
|
979
|
|
|
980 if (!free_ablock)
|
|
|
981 {
|
|
52276
|
982 int i;
|
|
|
983 EMACS_INT aligned; /* int gets warning casting to 64-bit pointer. */
|
|
51723
|
984
|
|
|
985 #ifdef DOUG_LEA_MALLOC
|
|
|
986 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
|
|
|
987 because mapped region contents are not preserved in
|
|
|
988 a dumped Emacs. */
|
|
|
989 mallopt (M_MMAP_MAX, 0);
|
|
|
990 #endif
|
|
|
991
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
992 #ifdef HAVE_POSIX_MEMALIGN
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
993 {
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
994 int err = posix_memalign (&base, BLOCK_ALIGN, ABLOCKS_BYTES);
|
55836
a05a653f63af
(lisp_align_malloc): Check for base == 0 regardless of HAVE_POSIX_MEMALIGN.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
995 if (err)
|
a05a653f63af
(lisp_align_malloc): Check for base == 0 regardless of HAVE_POSIX_MEMALIGN.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
996 base = NULL;
|
a05a653f63af
(lisp_align_malloc): Check for base == 0 regardless of HAVE_POSIX_MEMALIGN.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
997 abase = base;
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
998 }
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
999 #else
|
|
51723
|
1000 base = malloc (ABLOCKS_BYTES);
|
|
|
1001 abase = ALIGN (base, BLOCK_ALIGN);
|
55836
a05a653f63af
(lisp_align_malloc): Check for base == 0 regardless of HAVE_POSIX_MEMALIGN.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1002 #endif
|
a05a653f63af
(lisp_align_malloc): Check for base == 0 regardless of HAVE_POSIX_MEMALIGN.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
1003
|
|
52837
|
1004 if (base == 0)
|
|
|
1005 {
|
|
|
1006 UNBLOCK_INPUT;
|
|
|
1007 memory_full ();
|
|
|
1008 }
|
|
51723
|
1009
|
|
|
1010 aligned = (base == abase);
|
|
|
1011 if (!aligned)
|
|
|
1012 ((void**)abase)[-1] = base;
|
|
|
1013
|
|
|
1014 #ifdef DOUG_LEA_MALLOC
|
|
|
1015 /* Back to a reasonable maximum of mmap'ed areas. */
|
|
|
1016 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
|
|
|
1017 #endif
|
|
|
1018
|
|
53650
|
1019 #ifndef USE_LSB_TAG
|
|
52256
|
1020 /* If the memory just allocated cannot be addressed thru a Lisp
|
|
|
1021 object's pointer, and it needs to be, that's equivalent to
|
|
|
1022 running out of memory. */
|
|
|
1023 if (type != MEM_TYPE_NON_LISP)
|
|
|
1024 {
|
|
|
1025 Lisp_Object tem;
|
|
|
1026 char *end = (char *) base + ABLOCKS_BYTES - 1;
|
|
|
1027 XSETCONS (tem, end);
|
|
|
1028 if ((char *) XCONS (tem) != end)
|
|
|
1029 {
|
|
|
1030 lisp_malloc_loser = base;
|
|
|
1031 free (base);
|
|
|
1032 UNBLOCK_INPUT;
|
|
|
1033 memory_full ();
|
|
|
1034 }
|
|
|
1035 }
|
|
53650
|
1036 #endif
|
|
52256
|
1037
|
|
51723
|
1038 /* Initialize the blocks and put them on the free list.
|
|
|
1039 Is `base' was not properly aligned, we can't use the last block. */
|
|
|
1040 for (i = 0; i < (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1); i++)
|
|
|
1041 {
|
|
|
1042 abase->blocks[i].abase = abase;
|
|
|
1043 abase->blocks[i].x.next_free = free_ablock;
|
|
|
1044 free_ablock = &abase->blocks[i];
|
|
|
1045 }
|
|
52453
|
1046 ABLOCKS_BUSY (abase) = (struct ablocks *) (long) aligned;
|
|
51723
|
1047
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1048 eassert (0 == ((EMACS_UINT)abase) % BLOCK_ALIGN);
|
|
51723
|
1049 eassert (ABLOCK_ABASE (&abase->blocks[3]) == abase); /* 3 is arbitrary */
|
|
|
1050 eassert (ABLOCK_ABASE (&abase->blocks[0]) == abase);
|
|
|
1051 eassert (ABLOCKS_BASE (abase) == base);
|
|
52453
|
1052 eassert (aligned == (long) ABLOCKS_BUSY (abase));
|
|
51723
|
1053 }
|
|
|
1054
|
|
|
1055 abase = ABLOCK_ABASE (free_ablock);
|
|
52453
|
1056 ABLOCKS_BUSY (abase) = (struct ablocks *) (2 + (long) ABLOCKS_BUSY (abase));
|
|
51723
|
1057 val = free_ablock;
|
|
|
1058 free_ablock = free_ablock->x.next_free;
|
|
|
1059
|
|
|
1060 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
|
|
|
1061 if (val && type != MEM_TYPE_NON_LISP)
|
|
|
1062 mem_insert (val, (char *) val + nbytes, type);
|
|
|
1063 #endif
|
|
|
1064
|
|
|
1065 UNBLOCK_INPUT;
|
|
|
1066 if (!val && nbytes)
|
|
|
1067 memory_full ();
|
|
|
1068
|
|
|
1069 eassert (0 == ((EMACS_UINT)val) % BLOCK_ALIGN);
|
|
|
1070 return val;
|
|
|
1071 }
|
|
|
1072
|
|
|
1073 static void
|
|
|
1074 lisp_align_free (block)
|
|
|
1075 POINTER_TYPE *block;
|
|
|
1076 {
|
|
|
1077 struct ablock *ablock = block;
|
|
|
1078 struct ablocks *abase = ABLOCK_ABASE (ablock);
|
|
|
1079
|
|
|
1080 BLOCK_INPUT;
|
|
|
1081 #if GC_MARK_STACK && !defined GC_MALLOC_CHECK
|
|
|
1082 mem_delete (mem_find (block));
|
|
|
1083 #endif
|
|
|
1084 /* Put on free list. */
|
|
|
1085 ablock->x.next_free = free_ablock;
|
|
|
1086 free_ablock = ablock;
|
|
|
1087 /* Update busy count. */
|
|
52453
|
1088 ABLOCKS_BUSY (abase) = (struct ablocks *) (-2 + (long) ABLOCKS_BUSY (abase));
|
|
55634
|
1089
|
|
52453
|
1090 if (2 > (long) ABLOCKS_BUSY (abase))
|
|
51723
|
1091 { /* All the blocks are free. */
|
|
52453
|
1092 int i = 0, aligned = (long) ABLOCKS_BUSY (abase);
|
|
51723
|
1093 struct ablock **tem = &free_ablock;
|
|
|
1094 struct ablock *atop = &abase->blocks[aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1];
|
|
|
1095
|
|
|
1096 while (*tem)
|
|
|
1097 {
|
|
|
1098 if (*tem >= (struct ablock *) abase && *tem < atop)
|
|
|
1099 {
|
|
|
1100 i++;
|
|
|
1101 *tem = (*tem)->x.next_free;
|
|
|
1102 }
|
|
|
1103 else
|
|
|
1104 tem = &(*tem)->x.next_free;
|
|
|
1105 }
|
|
|
1106 eassert ((aligned & 1) == aligned);
|
|
|
1107 eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
|
|
68350
|
1108 #ifdef HAVE_POSIX_MEMALIGN
|
|
|
1109 eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
|
|
|
1110 #endif
|
|
51723
|
1111 free (ABLOCKS_BASE (abase));
|
|
|
1112 }
|
|
|
1113 UNBLOCK_INPUT;
|
|
|
1114 }
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1115
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1116 /* Return a new buffer structure allocated from the heap with
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1117 a call to lisp_malloc. */
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1118
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1119 struct buffer *
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1120 allocate_buffer ()
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1121 {
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1122 struct buffer *b
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1123 = (struct buffer *) lisp_malloc (sizeof (struct buffer),
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1124 MEM_TYPE_BUFFER);
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1125 return b;
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1126 }
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1127
|
|
2439
|
1128
|
|
59359
|
1129 #ifndef SYSTEM_MALLOC
|
|
|
1130
|
|
2439
|
1131 /* Arranging to disable input signals while we're in malloc.
|
|
|
1132
|
|
|
1133 This only works with GNU malloc. To help out systems which can't
|
|
|
1134 use GNU malloc, all the calls to malloc, realloc, and free
|
|
|
1135 elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT
|
|
59359
|
1136 pair; unfortunately, we have no idea what C library functions
|
|
2439
|
1137 might call malloc, so we can't really protect them unless you're
|
|
49529
|
1138 using GNU malloc. Fortunately, most of the major operating systems
|
|
|
1139 can use GNU malloc. */
|
|
2439
|
1140
|
|
59359
|
1141 #ifndef SYNC_INPUT
|
|
|
1142
|
|
30914
|
1143 #ifndef DOUG_LEA_MALLOC
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1144 extern void * (*__malloc_hook) P_ ((size_t, const void *));
|
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1145 extern void * (*__realloc_hook) P_ ((void *, size_t, const void *));
|
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1146 extern void (*__free_hook) P_ ((void *, const void *));
|
|
30914
|
1147 /* Else declared in malloc.h, perhaps with an extra arg. */
|
|
|
1148 #endif /* DOUG_LEA_MALLOC */
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1149 static void * (*old_malloc_hook) P_ ((size_t, const void *));
|
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1150 static void * (*old_realloc_hook) P_ ((void *, size_t, const void*));
|
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1151 static void (*old_free_hook) P_ ((void*, const void*));
|
|
2439
|
1152
|
|
10673
|
1153 /* This function is used as the hook for free to call. */
|
|
|
1154
|
|
2439
|
1155 static void
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1156 emacs_blocked_free (ptr, ptr2)
|
|
2439
|
1157 void *ptr;
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1158 const void *ptr2;
|
|
2439
|
1159 {
|
|
66530
|
1160 EMACS_INT bytes_used_now;
|
|
|
1161
|
|
58818
|
1162 BLOCK_INPUT_ALLOC;
|
|
32692
|
1163
|
|
|
1164 #ifdef GC_MALLOC_CHECK
|
|
32776
|
1165 if (ptr)
|
|
|
1166 {
|
|
|
1167 struct mem_node *m;
|
|
49600
|
1168
|
|
32776
|
1169 m = mem_find (ptr);
|
|
|
1170 if (m == MEM_NIL || m->start != ptr)
|
|
|
1171 {
|
|
|
1172 fprintf (stderr,
|
|
|
1173 "Freeing `%p' which wasn't allocated with malloc\n", ptr);
|
|
|
1174 abort ();
|
|
|
1175 }
|
|
|
1176 else
|
|
|
1177 {
|
|
|
1178 /* fprintf (stderr, "free %p...%p (%p)\n", m->start, m->end, ptr); */
|
|
|
1179 mem_delete (m);
|
|
|
1180 }
|
|
|
1181 }
|
|
32692
|
1182 #endif /* GC_MALLOC_CHECK */
|
|
49600
|
1183
|
|
2439
|
1184 __free_hook = old_free_hook;
|
|
|
1185 free (ptr);
|
|
49600
|
1186
|
|
10673
|
1187 /* If we released our reserve (due to running out of memory),
|
|
|
1188 and we have a fair amount free once again,
|
|
|
1189 try to set aside another reserve in case we run out once more. */
|
|
66530
|
1190 if (! NILP (Vmemory_full)
|
|
10673
|
1191 /* Verify there is enough space that even with the malloc
|
|
|
1192 hysteresis this call won't run out again.
|
|
|
1193 The code here is correct as long as SPARE_MEMORY
|
|
|
1194 is substantially larger than the block size malloc uses. */
|
|
|
1195 && (bytes_used_when_full
|
|
66547
|
1196 > ((bytes_used_when_reconsidered = BYTES_USED)
|
|
66541
|
1197 + max (malloc_hysteresis, 4) * SPARE_MEMORY)))
|
|
66530
|
1198 refill_memory_reserve ();
|
|
10673
|
1199
|
|
2507
|
1200 __free_hook = emacs_blocked_free;
|
|
58818
|
1201 UNBLOCK_INPUT_ALLOC;
|
|
2439
|
1202 }
|
|
|
1203
|
|
27738
|
1204
|
|
10673
|
1205 /* This function is the malloc hook that Emacs uses. */
|
|
|
1206
|
|
2439
|
1207 static void *
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1208 emacs_blocked_malloc (size, ptr)
|
|
30557
|
1209 size_t size;
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1210 const void *ptr;
|
|
2439
|
1211 {
|
|
|
1212 void *value;
|
|
|
1213
|
|
58818
|
1214 BLOCK_INPUT_ALLOC;
|
|
2439
|
1215 __malloc_hook = old_malloc_hook;
|
|
17831
|
1216 #ifdef DOUG_LEA_MALLOC
|
|
17345
|
1217 mallopt (M_TOP_PAD, malloc_hysteresis * 4096);
|
|
17831
|
1218 #else
|
|
17345
|
1219 __malloc_extra_blocks = malloc_hysteresis;
|
|
17831
|
1220 #endif
|
|
32692
|
1221
|
|
3581
|
1222 value = (void *) malloc (size);
|
|
32692
|
1223
|
|
|
1224 #ifdef GC_MALLOC_CHECK
|
|
|
1225 {
|
|
|
1226 struct mem_node *m = mem_find (value);
|
|
|
1227 if (m != MEM_NIL)
|
|
|
1228 {
|
|
|
1229 fprintf (stderr, "Malloc returned %p which is already in use\n",
|
|
|
1230 value);
|
|
|
1231 fprintf (stderr, "Region in use is %p...%p, %u bytes, type %d\n",
|
|
|
1232 m->start, m->end, (char *) m->end - (char *) m->start,
|
|
|
1233 m->type);
|
|
|
1234 abort ();
|
|
|
1235 }
|
|
|
1236
|
|
|
1237 if (!dont_register_blocks)
|
|
|
1238 {
|
|
|
1239 mem_insert (value, (char *) value + max (1, size), allocated_mem_type);
|
|
|
1240 allocated_mem_type = MEM_TYPE_NON_LISP;
|
|
|
1241 }
|
|
|
1242 }
|
|
|
1243 #endif /* GC_MALLOC_CHECK */
|
|
49600
|
1244
|
|
2507
|
1245 __malloc_hook = emacs_blocked_malloc;
|
|
58818
|
1246 UNBLOCK_INPUT_ALLOC;
|
|
2439
|
1247
|
|
32692
|
1248 /* fprintf (stderr, "%p malloc\n", value); */
|
|
2439
|
1249 return value;
|
|
|
1250 }
|
|
|
1251
|
|
27738
|
1252
|
|
|
1253 /* This function is the realloc hook that Emacs uses. */
|
|
|
1254
|
|
2439
|
1255 static void *
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1256 emacs_blocked_realloc (ptr, size, ptr2)
|
|
2439
|
1257 void *ptr;
|
|
30557
|
1258 size_t size;
|
65764
375ab086d366
* image.c (slurp_file, xbm_read_bitmap_data): Cast to the correct
Dan Nicolaescu <dann@ics.uci.edu>
diff
changeset
|
1259 const void *ptr2;
|
|
2439
|
1260 {
|
|
|
1261 void *value;
|
|
|
1262
|
|
58818
|
1263 BLOCK_INPUT_ALLOC;
|
|
2439
|
1264 __realloc_hook = old_realloc_hook;
|
|
32692
|
1265
|
|
|
1266 #ifdef GC_MALLOC_CHECK
|
|
|
1267 if (ptr)
|
|
|
1268 {
|
|
|
1269 struct mem_node *m = mem_find (ptr);
|
|
|
1270 if (m == MEM_NIL || m->start != ptr)
|
|
|
1271 {
|
|
|
1272 fprintf (stderr,
|
|
|
1273 "Realloc of %p which wasn't allocated with malloc\n",
|
|
|
1274 ptr);
|
|
|
1275 abort ();
|
|
|
1276 }
|
|
|
1277
|
|
|
1278 mem_delete (m);
|
|
|
1279 }
|
|
49600
|
1280
|
|
32692
|
1281 /* fprintf (stderr, "%p -> realloc\n", ptr); */
|
|
49600
|
1282
|
|
32692
|
1283 /* Prevent malloc from registering blocks. */
|
|
|
1284 dont_register_blocks = 1;
|
|
|
1285 #endif /* GC_MALLOC_CHECK */
|
|
|
1286
|
|
3581
|
1287 value = (void *) realloc (ptr, size);
|
|
32692
|
1288
|
|
|
1289 #ifdef GC_MALLOC_CHECK
|
|
|
1290 dont_register_blocks = 0;
|
|
|
1291
|
|
|
1292 {
|
|
|
1293 struct mem_node *m = mem_find (value);
|
|
|
1294 if (m != MEM_NIL)
|
|
|
1295 {
|
|
|
1296 fprintf (stderr, "Realloc returns memory that is already in use\n");
|
|
|
1297 abort ();
|
|
|
1298 }
|
|
|
1299
|
|
|
1300 /* Can't handle zero size regions in the red-black tree. */
|
|
|
1301 mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP);
|
|
|
1302 }
|
|
49600
|
1303
|
|
32692
|
1304 /* fprintf (stderr, "%p <- realloc\n", value); */
|
|
|
1305 #endif /* GC_MALLOC_CHECK */
|
|
49600
|
1306
|
|
2507
|
1307 __realloc_hook = emacs_blocked_realloc;
|
|
58818
|
1308 UNBLOCK_INPUT_ALLOC;
|
|
2439
|
1309
|
|
|
1310 return value;
|
|
|
1311 }
|
|
|
1312
|
|
27738
|
1313
|
|
58818
|
1314 #ifdef HAVE_GTK_AND_PTHREAD
|
|
|
1315 /* Called from Fdump_emacs so that when the dumped Emacs starts, it has a
|
|
|
1316 normal malloc. Some thread implementations need this as they call
|
|
|
1317 malloc before main. The pthread_self call in BLOCK_INPUT_ALLOC then
|
|
|
1318 calls malloc because it is the first call, and we have an endless loop. */
|
|
|
1319
|
|
|
1320 void
|
|
|
1321 reset_malloc_hooks ()
|
|
|
1322 {
|
|
|
1323 __free_hook = 0;
|
|
|
1324 __malloc_hook = 0;
|
|
|
1325 __realloc_hook = 0;
|
|
|
1326 }
|
|
|
1327 #endif /* HAVE_GTK_AND_PTHREAD */
|
|
|
1328
|
|
|
1329
|
|
27738
|
1330 /* Called from main to set up malloc to use our hooks. */
|
|
|
1331
|
|
2439
|
1332 void
|
|
|
1333 uninterrupt_malloc ()
|
|
|
1334 {
|
|
58818
|
1335 #ifdef HAVE_GTK_AND_PTHREAD
|
|
|
1336 pthread_mutexattr_t attr;
|
|
|
1337
|
|
|
1338 /* GLIBC has a faster way to do this, but lets keep it portable.
|
|
|
1339 This is according to the Single UNIX Specification. */
|
|
|
1340 pthread_mutexattr_init (&attr);
|
|
|
1341 pthread_mutexattr_settype (&attr, PTHREAD_MUTEX_RECURSIVE);
|
|
|
1342 pthread_mutex_init (&alloc_mutex, &attr);
|
|
|
1343 #endif /* HAVE_GTK_AND_PTHREAD */
|
|
|
1344
|
|
23958
|
1345 if (__free_hook != emacs_blocked_free)
|
|
|
1346 old_free_hook = __free_hook;
|
|
2507
|
1347 __free_hook = emacs_blocked_free;
|
|
2439
|
1348
|
|
23958
|
1349 if (__malloc_hook != emacs_blocked_malloc)
|
|
|
1350 old_malloc_hook = __malloc_hook;
|
|
2507
|
1351 __malloc_hook = emacs_blocked_malloc;
|
|
2439
|
1352
|
|
23958
|
1353 if (__realloc_hook != emacs_blocked_realloc)
|
|
|
1354 old_realloc_hook = __realloc_hook;
|
|
2507
|
1355 __realloc_hook = emacs_blocked_realloc;
|
|
2439
|
1356 }
|
|
27142
|
1357
|
|
59359
|
1358 #endif /* not SYNC_INPUT */
|
|
27142
|
1359 #endif /* not SYSTEM_MALLOC */
|
|
|
1360
|
|
|
1361
|
|
300
|
1362
|
|
27142
|
1363 /***********************************************************************
|
|
|
1364 Interval Allocation
|
|
|
1365 ***********************************************************************/
|
|
1908
|
1366
|
|
27738
|
1367 /* Number of intervals allocated in an interval_block structure.
|
|
|
1368 The 1020 is 1024 minus malloc overhead. */
|
|
|
1369
|
|
1300
|
1370 #define INTERVAL_BLOCK_SIZE \
|
|
|
1371 ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval))
|
|
|
1372
|
|
27738
|
1373 /* Intervals are allocated in chunks in form of an interval_block
|
|
|
1374 structure. */
|
|
|
1375
|
|
1300
|
1376 struct interval_block
|
|
27142
|
1377 {
|
|
53582
|
1378 /* Place `intervals' first, to preserve alignment. */
|
|
|
1379 struct interval intervals[INTERVAL_BLOCK_SIZE];
|
|
27142
|
1380 struct interval_block *next;
|
|
|
1381 };
|
|
1300
|
1382
|
|
27738
|
1383 /* Current interval block. Its `next' pointer points to older
|
|
|
1384 blocks. */
|
|
|
1385
|
|
1300
|
1386 struct interval_block *interval_block;
|
|
27738
|
1387
|
|
|
1388 /* Index in interval_block above of the next unused interval
|
|
|
1389 structure. */
|
|
|
1390
|
|
1300
|
1391 static int interval_block_index;
|
|
27738
|
1392
|
|
|
1393 /* Number of free and live intervals. */
|
|
|
1394
|
|
27142
|
1395 static int total_free_intervals, total_intervals;
|
|
1300
|
1396
|
|
27738
|
1397 /* List of free intervals. */
|
|
|
1398
|
|
1300
|
1399 INTERVAL interval_free_list;
|
|
|
1400
|
|
23958
|
1401 /* Total number of interval blocks now in use. */
|
|
27142
|
1402
|
|
23958
|
1403 int n_interval_blocks;
|
|
|
1404
|
|
27738
|
1405
|
|
|
1406 /* Initialize interval allocation. */
|
|
|
1407
|
|
1300
|
1408 static void
|
|
|
1409 init_intervals ()
|
|
|
1410 {
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1411 interval_block = NULL;
|
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1412 interval_block_index = INTERVAL_BLOCK_SIZE;
|
|
1300
|
1413 interval_free_list = 0;
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1414 n_interval_blocks = 0;
|
|
1300
|
1415 }
|
|
|
1416
|
|
27738
|
1417
|
|
|
1418 /* Return a new interval. */
|
|
1300
|
1419
|
|
|
1420 INTERVAL
|
|
|
1421 make_interval ()
|
|
|
1422 {
|
|
|
1423 INTERVAL val;
|
|
|
1424
|
|
68430
|
1425 /* eassert (!handling_signal); */
|
|
|
1426
|
|
|
1427 #ifndef SYNC_INPUT
|
|
|
1428 BLOCK_INPUT;
|
|
|
1429 #endif
|
|
68350
|
1430
|
|
1300
|
1431 if (interval_free_list)
|
|
|
1432 {
|
|
|
1433 val = interval_free_list;
|
28269
fd13be8ae190
Changes towards better type safety regarding intervals, primarily
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1434 interval_free_list = INTERVAL_PARENT (interval_free_list);
|
|
1300
|
1435 }
|
|
|
1436 else
|
|
|
1437 {
|
|
|
1438 if (interval_block_index == INTERVAL_BLOCK_SIZE)
|
|
|
1439 {
|
|
12529
|
1440 register struct interval_block *newi;
|
|
1300
|
1441
|
|
27738
|
1442 newi = (struct interval_block *) lisp_malloc (sizeof *newi,
|
|
|
1443 MEM_TYPE_NON_LISP);
|
|
23958
|
1444
|
|
1300
|
1445 newi->next = interval_block;
|
|
|
1446 interval_block = newi;
|
|
|
1447 interval_block_index = 0;
|
|
23958
|
1448 n_interval_blocks++;
|
|
1300
|
1449 }
|
|
|
1450 val = &interval_block->intervals[interval_block_index++];
|
|
|
1451 }
|
|
68430
|
1452
|
|
|
1453 #ifndef SYNC_INPUT
|
|
|
1454 UNBLOCK_INPUT;
|
|
|
1455 #endif
|
|
|
1456
|
|
1300
|
1457 consing_since_gc += sizeof (struct interval);
|
|
12748
|
1458 intervals_consed++;
|
|
1300
|
1459 RESET_INTERVAL (val);
|
|
51658
|
1460 val->gcmarkbit = 0;
|
|
1300
|
1461 return val;
|
|
|
1462 }
|
|
|
1463
|
|
27738
|
1464
|
|
|
1465 /* Mark Lisp objects in interval I. */
|
|
1300
|
1466
|
|
|
1467 static void
|
|
1957
|
1468 mark_interval (i, dummy)
|
|
1300
|
1469 register INTERVAL i;
|
|
1957
|
1470 Lisp_Object dummy;
|
|
1300
|
1471 {
|
|
51658
|
1472 eassert (!i->gcmarkbit); /* Intervals are never shared. */
|
|
|
1473 i->gcmarkbit = 1;
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1474 mark_object (i->plist);
|
|
1300
|
1475 }
|
|
|
1476
|
|
27738
|
1477
|
|
|
1478 /* Mark the interval tree rooted in TREE. Don't call this directly;
|
|
|
1479 use the macro MARK_INTERVAL_TREE instead. */
|
|
|
1480
|
|
1300
|
1481 static void
|
|
|
1482 mark_interval_tree (tree)
|
|
|
1483 register INTERVAL tree;
|
|
|
1484 {
|
|
4139
|
1485 /* No need to test if this tree has been marked already; this
|
|
|
1486 function is always called through the MARK_INTERVAL_TREE macro,
|
|
|
1487 which takes care of that. */
|
|
|
1488
|
|
39859
|
1489 traverse_intervals_noorder (tree, mark_interval, Qnil);
|
|
1300
|
1490 }
|
|
|
1491
|
|
27738
|
1492
|
|
|
1493 /* Mark the interval tree rooted in I. */
|
|
|
1494
|
|
4139
|
1495 #define MARK_INTERVAL_TREE(i) \
|
|
|
1496 do { \
|
|
51658
|
1497 if (!NULL_INTERVAL_P (i) && !i->gcmarkbit) \
|
|
4139
|
1498 mark_interval_tree (i); \
|
|
|
1499 } while (0)
|
|
1300
|
1500
|
|
27738
|
1501
|
|
27142
|
1502 #define UNMARK_BALANCE_INTERVALS(i) \
|
|
|
1503 do { \
|
|
|
1504 if (! NULL_INTERVAL_P (i)) \
|
|
51658
|
1505 (i) = balance_intervals (i); \
|
|
27142
|
1506 } while (0)
|
|
1300
|
1507
|
28469
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1508
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1509 /* Number support. If NO_UNION_TYPE isn't in effect, we
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1510 can't create number objects in macros. */
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1511 #ifndef make_number
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1512 Lisp_Object
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1513 make_number (n)
|
|
60896
|
1514 EMACS_INT n;
|
28469
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1515 {
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1516 Lisp_Object obj;
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1517 obj.s.val = n;
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1518 obj.s.type = Lisp_Int;
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1519 return obj;
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1520 }
|
f66f2b4d5eb7
* alloc.c (MARK_STRING, UNMARK_STRING, STRING_MARKED_P): Expand non-union-type
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1521 #endif
|
|
1300
|
1522
|
|
27142
|
1523 /***********************************************************************
|
|
|
1524 String Allocation
|
|
|
1525 ***********************************************************************/
|
|
|
1526
|
|
|
1527 /* Lisp_Strings are allocated in string_block structures. When a new
|
|
|
1528 string_block is allocated, all the Lisp_Strings it contains are
|
|
41831
|
1529 added to a free-list string_free_list. When a new Lisp_String is
|
|
27142
|
1530 needed, it is taken from that list. During the sweep phase of GC,
|
|
|
1531 string_blocks that are entirely free are freed, except two which
|
|
|
1532 we keep.
|
|
|
1533
|
|
|
1534 String data is allocated from sblock structures. Strings larger
|
|
|
1535 than LARGE_STRING_BYTES, get their own sblock, data for smaller
|
|
|
1536 strings is sub-allocated out of sblocks of size SBLOCK_SIZE.
|
|
|
1537
|
|
|
1538 Sblocks consist internally of sdata structures, one for each
|
|
|
1539 Lisp_String. The sdata structure points to the Lisp_String it
|
|
|
1540 belongs to. The Lisp_String points back to the `u.data' member of
|
|
|
1541 its sdata structure.
|
|
|
1542
|
|
|
1543 When a Lisp_String is freed during GC, it is put back on
|
|
|
1544 string_free_list, and its `data' member and its sdata's `string'
|
|
|
1545 pointer is set to null. The size of the string is recorded in the
|
|
|
1546 `u.nbytes' member of the sdata. So, sdata structures that are no
|
|
|
1547 longer used, can be easily recognized, and it's easy to compact the
|
|
|
1548 sblocks of small strings which we do in compact_small_strings. */
|
|
|
1549
|
|
|
1550 /* Size in bytes of an sblock structure used for small strings. This
|
|
|
1551 is 8192 minus malloc overhead. */
|
|
|
1552
|
|
|
1553 #define SBLOCK_SIZE 8188
|
|
|
1554
|
|
|
1555 /* Strings larger than this are considered large strings. String data
|
|
|
1556 for large strings is allocated from individual sblocks. */
|
|
|
1557
|
|
|
1558 #define LARGE_STRING_BYTES 1024
|
|
|
1559
|
|
|
1560 /* Structure describing string memory sub-allocated from an sblock.
|
|
|
1561 This is where the contents of Lisp strings are stored. */
|
|
|
1562
|
|
|
1563 struct sdata
|
|
|
1564 {
|
|
|
1565 /* Back-pointer to the string this sdata belongs to. If null, this
|
|
|
1566 structure is free, and the NBYTES member of the union below
|
|
27738
|
1567 contains the string's byte size (the same value that STRING_BYTES
|
|
27142
|
1568 would return if STRING were non-null). If non-null, STRING_BYTES
|
|
|
1569 (STRING) is the size of the data, and DATA contains the string's
|
|
|
1570 contents. */
|
|
|
1571 struct Lisp_String *string;
|
|
|
1572
|
|
31897
|
1573 #ifdef GC_CHECK_STRING_BYTES
|
|
49600
|
1574
|
|
31897
|
1575 EMACS_INT nbytes;
|
|
|
1576 unsigned char data[1];
|
|
49600
|
1577
|
|
31897
|
1578 #define SDATA_NBYTES(S) (S)->nbytes
|
|
|
1579 #define SDATA_DATA(S) (S)->data
|
|
49600
|
1580
|
|
31897
|
1581 #else /* not GC_CHECK_STRING_BYTES */
|
|
|
1582
|
|
27142
|
1583 union
|
|
|
1584 {
|
|
|
1585 /* When STRING in non-null. */
|
|
|
1586 unsigned char data[1];
|
|
|
1587
|
|
|
1588 /* When STRING is null. */
|
|
|
1589 EMACS_INT nbytes;
|
|
|
1590 } u;
|
|
49600
|
1591
|
|
31897
|
1592
|
|
|
1593 #define SDATA_NBYTES(S) (S)->u.nbytes
|
|
|
1594 #define SDATA_DATA(S) (S)->u.data
|
|
|
1595
|
|
|
1596 #endif /* not GC_CHECK_STRING_BYTES */
|
|
27142
|
1597 };
|
|
|
1598
|
|
31897
|
1599
|
|
27142
|
1600 /* Structure describing a block of memory which is sub-allocated to
|
|
|
1601 obtain string data memory for strings. Blocks for small strings
|
|
|
1602 are of fixed size SBLOCK_SIZE. Blocks for large strings are made
|
|
|
1603 as large as needed. */
|
|
|
1604
|
|
|
1605 struct sblock
|
|
|
1606 {
|
|
|
1607 /* Next in list. */
|
|
|
1608 struct sblock *next;
|
|
|
1609
|
|
|
1610 /* Pointer to the next free sdata block. This points past the end
|
|
|
1611 of the sblock if there isn't any space left in this block. */
|
|
|
1612 struct sdata *next_free;
|
|
|
1613
|
|
|
1614 /* Start of data. */
|
|
|
1615 struct sdata first_data;
|
|
|
1616 };
|
|
|
1617
|
|
|
1618 /* Number of Lisp strings in a string_block structure. The 1020 is
|
|
|
1619 1024 minus malloc overhead. */
|
|
|
1620
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1621 #define STRING_BLOCK_SIZE \
|
|
27142
|
1622 ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String))
|
|
|
1623
|
|
|
1624 /* Structure describing a block from which Lisp_String structures
|
|
|
1625 are allocated. */
|
|
|
1626
|
|
|
1627 struct string_block
|
|
|
1628 {
|
|
53582
|
1629 /* Place `strings' first, to preserve alignment. */
|
|
|
1630 struct Lisp_String strings[STRING_BLOCK_SIZE];
|
|
27142
|
1631 struct string_block *next;
|
|
|
1632 };
|
|
|
1633
|
|
|
1634 /* Head and tail of the list of sblock structures holding Lisp string
|
|
|
1635 data. We always allocate from current_sblock. The NEXT pointers
|
|
|
1636 in the sblock structures go from oldest_sblock to current_sblock. */
|
|
|
1637
|
|
|
1638 static struct sblock *oldest_sblock, *current_sblock;
|
|
|
1639
|
|
|
1640 /* List of sblocks for large strings. */
|
|
|
1641
|
|
|
1642 static struct sblock *large_sblocks;
|
|
|
1643
|
|
|
1644 /* List of string_block structures, and how many there are. */
|
|
|
1645
|
|
|
1646 static struct string_block *string_blocks;
|
|
|
1647 static int n_string_blocks;
|
|
|
1648
|
|
|
1649 /* Free-list of Lisp_Strings. */
|
|
|
1650
|
|
|
1651 static struct Lisp_String *string_free_list;
|
|
|
1652
|
|
|
1653 /* Number of live and free Lisp_Strings. */
|
|
|
1654
|
|
|
1655 static int total_strings, total_free_strings;
|
|
|
1656
|
|
|
1657 /* Number of bytes used by live strings. */
|
|
|
1658
|
|
|
1659 static int total_string_size;
|
|
|
1660
|
|
|
1661 /* Given a pointer to a Lisp_String S which is on the free-list
|
|
|
1662 string_free_list, return a pointer to its successor in the
|
|
|
1663 free-list. */
|
|
|
1664
|
|
|
1665 #define NEXT_FREE_LISP_STRING(S) (*(struct Lisp_String **) (S))
|
|
|
1666
|
|
|
1667 /* Return a pointer to the sdata structure belonging to Lisp string S.
|
|
|
1668 S must be live, i.e. S->data must not be null. S->data is actually
|
|
|
1669 a pointer to the `u.data' member of its sdata structure; the
|
|
|
1670 structure starts at a constant offset in front of that. */
|
|
49600
|
1671
|
|
31897
|
1672 #ifdef GC_CHECK_STRING_BYTES
|
|
|
1673
|
|
|
1674 #define SDATA_OF_STRING(S) \
|
|
|
1675 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *) \
|
|
|
1676 - sizeof (EMACS_INT)))
|
|
|
1677
|
|
|
1678 #else /* not GC_CHECK_STRING_BYTES */
|
|
|
1679
|
|
27142
|
1680 #define SDATA_OF_STRING(S) \
|
|
|
1681 ((struct sdata *) ((S)->data - sizeof (struct Lisp_String *)))
|
|
|
1682
|
|
31897
|
1683 #endif /* not GC_CHECK_STRING_BYTES */
|
|
|
1684
|
|
58631
|
1685
|
|
|
1686 #ifdef GC_CHECK_STRING_OVERRUN
|
|
58707
|
1687
|
|
|
1688 /* We check for overrun in string data blocks by appending a small
|
|
|
1689 "cookie" after each allocated string data block, and check for the
|
|
62681
|
1690 presence of this cookie during GC. */
|
|
58707
|
1691
|
|
|
1692 #define GC_STRING_OVERRUN_COOKIE_SIZE 4
|
|
|
1693 static char string_overrun_cookie[GC_STRING_OVERRUN_COOKIE_SIZE] =
|
|
|
1694 { 0xde, 0xad, 0xbe, 0xef };
|
|
|
1695
|
|
58631
|
1696 #else
|
|
58707
|
1697 #define GC_STRING_OVERRUN_COOKIE_SIZE 0
|
|
58631
|
1698 #endif
|
|
|
1699
|
|
27142
|
1700 /* Value is the size of an sdata structure large enough to hold NBYTES
|
|
|
1701 bytes of string data. The value returned includes a terminating
|
|
|
1702 NUL byte, the size of the sdata structure, and padding. */
|
|
|
1703
|
|
31897
|
1704 #ifdef GC_CHECK_STRING_BYTES
|
|
|
1705
|
|
|
1706 #define SDATA_SIZE(NBYTES) \
|
|
|
1707 ((sizeof (struct Lisp_String *) \
|
|
|
1708 + (NBYTES) + 1 \
|
|
|
1709 + sizeof (EMACS_INT) \
|
|
|
1710 + sizeof (EMACS_INT) - 1) \
|
|
|
1711 & ~(sizeof (EMACS_INT) - 1))
|
|
|
1712
|
|
|
1713 #else /* not GC_CHECK_STRING_BYTES */
|
|
|
1714
|
|
27142
|
1715 #define SDATA_SIZE(NBYTES) \
|
|
|
1716 ((sizeof (struct Lisp_String *) \
|
|
|
1717 + (NBYTES) + 1 \
|
|
|
1718 + sizeof (EMACS_INT) - 1) \
|
|
|
1719 & ~(sizeof (EMACS_INT) - 1))
|
|
|
1720
|
|
31897
|
1721 #endif /* not GC_CHECK_STRING_BYTES */
|
|
27142
|
1722
|
|
58707
|
1723 /* Extra bytes to allocate for each string. */
|
|
|
1724
|
|
|
1725 #define GC_STRING_EXTRA (GC_STRING_OVERRUN_COOKIE_SIZE)
|
|
|
1726
|
|
27142
|
1727 /* Initialize string allocation. Called from init_alloc_once. */
|
|
|
1728
|
|
|
1729 void
|
|
|
1730 init_strings ()
|
|
|
1731 {
|
|
|
1732 total_strings = total_free_strings = total_string_size = 0;
|
|
|
1733 oldest_sblock = current_sblock = large_sblocks = NULL;
|
|
|
1734 string_blocks = NULL;
|
|
|
1735 n_string_blocks = 0;
|
|
|
1736 string_free_list = NULL;
|
|
|
1737 }
|
|
|
1738
|
|
|
1739
|
|
32587
|
1740 #ifdef GC_CHECK_STRING_BYTES
|
|
|
1741
|
|
|
1742 static int check_string_bytes_count;
|
|
|
1743
|
|
35183
|
1744 void check_string_bytes P_ ((int));
|
|
|
1745 void check_sblock P_ ((struct sblock *));
|
|
|
1746
|
|
|
1747 #define CHECK_STRING_BYTES(S) STRING_BYTES (S)
|
|
|
1748
|
|
|
1749
|
|
|
1750 /* Like GC_STRING_BYTES, but with debugging check. */
|
|
|
1751
|
|
|
1752 int
|
|
|
1753 string_bytes (s)
|
|
|
1754 struct Lisp_String *s;
|
|
|
1755 {
|
|
51985
|
1756 int nbytes = (s->size_byte < 0 ? s->size & ~ARRAY_MARK_FLAG : s->size_byte);
|
|
35183
|
1757 if (!PURE_POINTER_P (s)
|
|
|
1758 && s->data
|
|
|
1759 && nbytes != SDATA_NBYTES (SDATA_OF_STRING (s)))
|
|
|
1760 abort ();
|
|
|
1761 return nbytes;
|
|
|
1762 }
|
|
49600
|
1763
|
|
49529
|
1764 /* Check validity of Lisp strings' string_bytes member in B. */
|
|
35183
|
1765
|
|
32587
|
1766 void
|
|
35183
|
1767 check_sblock (b)
|
|
|
1768 struct sblock *b;
|
|
32587
|
1769 {
|
|
35183
|
1770 struct sdata *from, *end, *from_end;
|
|
49600
|
1771
|
|
35183
|
1772 end = b->next_free;
|
|
49600
|
1773
|
|
35183
|
1774 for (from = &b->first_data; from < end; from = from_end)
|
|
32587
|
1775 {
|
|
35183
|
1776 /* Compute the next FROM here because copying below may
|
|
|
1777 overwrite data we need to compute it. */
|
|
|
1778 int nbytes;
|
|
49600
|
1779
|
|
35183
|
1780 /* Check that the string size recorded in the string is the
|
|
|
1781 same as the one recorded in the sdata structure. */
|
|
|
1782 if (from->string)
|
|
|
1783 CHECK_STRING_BYTES (from->string);
|
|
49600
|
1784
|
|
35183
|
1785 if (from->string)
|
|
|
1786 nbytes = GC_STRING_BYTES (from->string);
|
|
|
1787 else
|
|
|
1788 nbytes = SDATA_NBYTES (from);
|
|
49600
|
1789
|
|
35183
|
1790 nbytes = SDATA_SIZE (nbytes);
|
|
58631
|
1791 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
|
|
35183
|
1792 }
|
|
|
1793 }
|
|
|
1794
|
|
|
1795
|
|
|
1796 /* Check validity of Lisp strings' string_bytes member. ALL_P
|
|
|
1797 non-zero means check all strings, otherwise check only most
|
|
|
1798 recently allocated strings. Used for hunting a bug. */
|
|
|
1799
|
|
|
1800 void
|
|
|
1801 check_string_bytes (all_p)
|
|
|
1802 int all_p;
|
|
|
1803 {
|
|
|
1804 if (all_p)
|
|
32587
|
1805 {
|
|
35183
|
1806 struct sblock *b;
|
|
|
1807
|
|
|
1808 for (b = large_sblocks; b; b = b->next)
|
|
32587
|
1809 {
|
|
35183
|
1810 struct Lisp_String *s = b->first_data.string;
|
|
|
1811 if (s)
|
|
|
1812 CHECK_STRING_BYTES (s);
|
|
32587
|
1813 }
|
|
49600
|
1814
|
|
35183
|
1815 for (b = oldest_sblock; b; b = b->next)
|
|
|
1816 check_sblock (b);
|
|
32587
|
1817 }
|
|
35183
|
1818 else
|
|
|
1819 check_sblock (current_sblock);
|
|
32587
|
1820 }
|
|
|
1821
|
|
|
1822 #endif /* GC_CHECK_STRING_BYTES */
|
|
|
1823
|
|
58631
|
1824 #ifdef GC_CHECK_STRING_FREE_LIST
|
|
|
1825
|
|
58707
|
1826 /* Walk through the string free list looking for bogus next pointers.
|
|
|
1827 This may catch buffer overrun from a previous string. */
|
|
|
1828
|
|
58631
|
1829 static void
|
|
|
1830 check_string_free_list ()
|
|
|
1831 {
|
|
|
1832 struct Lisp_String *s;
|
|
|
1833
|
|
|
1834 /* Pop a Lisp_String off the free-list. */
|
|
|
1835 s = string_free_list;
|
|
|
1836 while (s != NULL)
|
|
|
1837 {
|
|
|
1838 if ((unsigned)s < 1024)
|
|
|
1839 abort();
|
|
|
1840 s = NEXT_FREE_LISP_STRING (s);
|
|
|
1841 }
|
|
|
1842 }
|
|
|
1843 #else
|
|
|
1844 #define check_string_free_list()
|
|
|
1845 #endif
|
|
32587
|
1846
|
|
27142
|
1847 /* Return a new Lisp_String. */
|
|
|
1848
|
|
|
1849 static struct Lisp_String *
|
|
|
1850 allocate_string ()
|
|
|
1851 {
|
|
|
1852 struct Lisp_String *s;
|
|
|
1853
|
|
68430
|
1854 /* eassert (!handling_signal); */
|
|
|
1855
|
|
|
1856 #ifndef SYNC_INPUT
|
|
|
1857 BLOCK_INPUT;
|
|
|
1858 #endif
|
|
68350
|
1859
|
|
27142
|
1860 /* If the free-list is empty, allocate a new string_block, and
|
|
|
1861 add all the Lisp_Strings in it to the free-list. */
|
|
|
1862 if (string_free_list == NULL)
|
|
|
1863 {
|
|
|
1864 struct string_block *b;
|
|
|
1865 int i;
|
|
|
1866
|
|
27738
|
1867 b = (struct string_block *) lisp_malloc (sizeof *b, MEM_TYPE_STRING);
|
|
27142
|
1868 bzero (b, sizeof *b);
|
|
|
1869 b->next = string_blocks;
|
|
|
1870 string_blocks = b;
|
|
|
1871 ++n_string_blocks;
|
|
|
1872
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1873 for (i = STRING_BLOCK_SIZE - 1; i >= 0; --i)
|
|
27142
|
1874 {
|
|
|
1875 s = b->strings + i;
|
|
|
1876 NEXT_FREE_LISP_STRING (s) = string_free_list;
|
|
|
1877 string_free_list = s;
|
|
|
1878 }
|
|
|
1879
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1880 total_free_strings += STRING_BLOCK_SIZE;
|
|
27142
|
1881 }
|
|
|
1882
|
|
58707
|
1883 check_string_free_list ();
|
|
58631
|
1884
|
|
27142
|
1885 /* Pop a Lisp_String off the free-list. */
|
|
|
1886 s = string_free_list;
|
|
|
1887 string_free_list = NEXT_FREE_LISP_STRING (s);
|
|
|
1888
|
|
68430
|
1889 #ifndef SYNC_INPUT
|
|
|
1890 UNBLOCK_INPUT;
|
|
|
1891 #endif
|
|
|
1892
|
|
27142
|
1893 /* Probably not strictly necessary, but play it safe. */
|
|
|
1894 bzero (s, sizeof *s);
|
|
|
1895
|
|
|
1896 --total_free_strings;
|
|
|
1897 ++total_strings;
|
|
|
1898 ++strings_consed;
|
|
|
1899 consing_since_gc += sizeof *s;
|
|
|
1900
|
|
32587
|
1901 #ifdef GC_CHECK_STRING_BYTES
|
|
35660
|
1902 if (!noninteractive
|
44890
01b93e5e53a7
Patch for building Emacs on Mac OS X. April 26, 2002. See ChangeLog,
Andrew Choi <akochoi@shaw.ca>
diff
changeset
|
1903 #ifdef MAC_OS8
|
|
35660
|
1904 && current_sblock
|
|
|
1905 #endif
|
|
|
1906 )
|
|
32587
|
1907 {
|
|
35183
|
1908 if (++check_string_bytes_count == 200)
|
|
|
1909 {
|
|
|
1910 check_string_bytes_count = 0;
|
|
|
1911 check_string_bytes (1);
|
|
|
1912 }
|
|
|
1913 else
|
|
|
1914 check_string_bytes (0);
|
|
32587
|
1915 }
|
|
35183
|
1916 #endif /* GC_CHECK_STRING_BYTES */
|
|
32587
|
1917
|
|
27142
|
1918 return s;
|
|
|
1919 }
|
|
|
1920
|
|
|
1921
|
|
|
1922 /* Set up Lisp_String S for holding NCHARS characters, NBYTES bytes,
|
|
|
1923 plus a NUL byte at the end. Allocate an sdata structure for S, and
|
|
|
1924 set S->data to its `u.data' member. Store a NUL byte at the end of
|
|
|
1925 S->data. Set S->size to NCHARS and S->size_byte to NBYTES. Free
|
|
|
1926 S->data if it was initially non-null. */
|
|
|
1927
|
|
|
1928 void
|
|
|
1929 allocate_string_data (s, nchars, nbytes)
|
|
|
1930 struct Lisp_String *s;
|
|
|
1931 int nchars, nbytes;
|
|
|
1932 {
|
|
30293
|
1933 struct sdata *data, *old_data;
|
|
27142
|
1934 struct sblock *b;
|
|
30293
|
1935 int needed, old_nbytes;
|
|
27142
|
1936
|
|
|
1937 /* Determine the number of bytes needed to store NBYTES bytes
|
|
|
1938 of string data. */
|
|
|
1939 needed = SDATA_SIZE (nbytes);
|
|
68430
|
1940 old_data = s->data ? SDATA_OF_STRING (s) : NULL;
|
|
|
1941 old_nbytes = GC_STRING_BYTES (s);
|
|
|
1942
|
|
|
1943 #ifndef SYNC_INPUT
|
|
|
1944 BLOCK_INPUT;
|
|
|
1945 #endif
|
|
27142
|
1946
|
|
|
1947 if (nbytes > LARGE_STRING_BYTES)
|
|
|
1948 {
|
|
30557
|
1949 size_t size = sizeof *b - sizeof (struct sdata) + needed;
|
|
27142
|
1950
|
|
|
1951 #ifdef DOUG_LEA_MALLOC
|
|
31576
|
1952 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
|
|
|
1953 because mapped region contents are not preserved in
|
|
51318
|
1954 a dumped Emacs.
|
|
|
1955
|
|
|
1956 In case you think of allowing it in a dumped Emacs at the
|
|
|
1957 cost of not being able to re-dump, there's another reason:
|
|
|
1958 mmap'ed data typically have an address towards the top of the
|
|
|
1959 address space, which won't fit into an EMACS_INT (at least on
|
|
|
1960 32-bit systems with the current tagging scheme). --fx */
|
|
61225
|
1961 BLOCK_INPUT;
|
|
27142
|
1962 mallopt (M_MMAP_MAX, 0);
|
|
61225
|
1963 UNBLOCK_INPUT;
|
|
27142
|
1964 #endif
|
|
|
1965
|
|
58631
|
1966 b = (struct sblock *) lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP);
|
|
49600
|
1967
|
|
27142
|
1968 #ifdef DOUG_LEA_MALLOC
|
|
|
1969 /* Back to a reasonable maximum of mmap'ed areas. */
|
|
61225
|
1970 BLOCK_INPUT;
|
|
27142
|
1971 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
|
|
61225
|
1972 UNBLOCK_INPUT;
|
|
27142
|
1973 #endif
|
|
49600
|
1974
|
|
27142
|
1975 b->next_free = &b->first_data;
|
|
|
1976 b->first_data.string = NULL;
|
|
|
1977 b->next = large_sblocks;
|
|
|
1978 large_sblocks = b;
|
|
|
1979 }
|
|
|
1980 else if (current_sblock == NULL
|
|
|
1981 || (((char *) current_sblock + SBLOCK_SIZE
|
|
|
1982 - (char *) current_sblock->next_free)
|
|
58631
|
1983 < (needed + GC_STRING_EXTRA)))
|
|
27142
|
1984 {
|
|
|
1985 /* Not enough room in the current sblock. */
|
|
27738
|
1986 b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
|
|
27142
|
1987 b->next_free = &b->first_data;
|
|
|
1988 b->first_data.string = NULL;
|
|
|
1989 b->next = NULL;
|
|
|
1990
|
|
|
1991 if (current_sblock)
|
|
|
1992 current_sblock->next = b;
|
|
|
1993 else
|
|
|
1994 oldest_sblock = b;
|
|
|
1995 current_sblock = b;
|
|
|
1996 }
|
|
|
1997 else
|
|
|
1998 b = current_sblock;
|
|
30293
|
1999
|
|
27142
|
2000 data = b->next_free;
|
68369
3422c551ad06
* alloc.c (allocate_string_data): Update next_free immediately, to
Chong Yidong <cyd@stupidchicken.com>
diff
changeset
|
2001 b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);
|
3422c551ad06
* alloc.c (allocate_string_data): Update next_free immediately, to
Chong Yidong <cyd@stupidchicken.com>
diff
changeset
|
2002
|
|
68430
|
2003 #ifndef SYNC_INPUT
|
|
|
2004 UNBLOCK_INPUT;
|
|
|
2005 #endif
|
|
|
2006
|
|
27142
|
2007 data->string = s;
|
|
31897
|
2008 s->data = SDATA_DATA (data);
|
|
|
2009 #ifdef GC_CHECK_STRING_BYTES
|
|
|
2010 SDATA_NBYTES (data) = nbytes;
|
|
|
2011 #endif
|
|
27142
|
2012 s->size = nchars;
|
|
|
2013 s->size_byte = nbytes;
|
|
|
2014 s->data[nbytes] = '\0';
|
|
58631
|
2015 #ifdef GC_CHECK_STRING_OVERRUN
|
|
58707
|
2016 bcopy (string_overrun_cookie, (char *) data + needed,
|
|
|
2017 GC_STRING_OVERRUN_COOKIE_SIZE);
|
|
58631
|
2018 #endif
|
|
49600
|
2019
|
|
30293
|
2020 /* If S had already data assigned, mark that as free by setting its
|
|
|
2021 string back-pointer to null, and recording the size of the data
|
|
30317
|
2022 in it. */
|
|
30293
|
2023 if (old_data)
|
|
|
2024 {
|
|
31897
|
2025 SDATA_NBYTES (old_data) = old_nbytes;
|
|
30293
|
2026 old_data->string = NULL;
|
|
|
2027 }
|
|
|
2028
|
|
27142
|
2029 consing_since_gc += needed;
|
|
|
2030 }
|
|
|
2031
|
|
|
2032
|
|
|
2033 /* Sweep and compact strings. */
|
|
|
2034
|
|
|
2035 static void
|
|
|
2036 sweep_strings ()
|
|
|
2037 {
|
|
|
2038 struct string_block *b, *next;
|
|
|
2039 struct string_block *live_blocks = NULL;
|
|
49600
|
2040
|
|
27142
|
2041 string_free_list = NULL;
|
|
|
2042 total_strings = total_free_strings = 0;
|
|
|
2043 total_string_size = 0;
|
|
|
2044
|
|
|
2045 /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
|
|
|
2046 for (b = string_blocks; b; b = next)
|
|
|
2047 {
|
|
|
2048 int i, nfree = 0;
|
|
|
2049 struct Lisp_String *free_list_before = string_free_list;
|
|
|
2050
|
|
|
2051 next = b->next;
|
|
|
2052
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2053 for (i = 0; i < STRING_BLOCK_SIZE; ++i)
|
|
27142
|
2054 {
|
|
|
2055 struct Lisp_String *s = b->strings + i;
|
|
|
2056
|
|
|
2057 if (s->data)
|
|
|
2058 {
|
|
|
2059 /* String was not on free-list before. */
|
|
|
2060 if (STRING_MARKED_P (s))
|
|
|
2061 {
|
|
|
2062 /* String is live; unmark it and its intervals. */
|
|
|
2063 UNMARK_STRING (s);
|
|
49600
|
2064
|
|
27142
|
2065 if (!NULL_INTERVAL_P (s->intervals))
|
|
|
2066 UNMARK_BALANCE_INTERVALS (s->intervals);
|
|
|
2067
|
|
|
2068 ++total_strings;
|
|
|
2069 total_string_size += STRING_BYTES (s);
|
|
|
2070 }
|
|
|
2071 else
|
|
|
2072 {
|
|
|
2073 /* String is dead. Put it on the free-list. */
|
|
|
2074 struct sdata *data = SDATA_OF_STRING (s);
|
|
|
2075
|
|
|
2076 /* Save the size of S in its sdata so that we know
|
|
|
2077 how large that is. Reset the sdata's string
|
|
|
2078 back-pointer so that we know it's free. */
|
|
31897
|
2079 #ifdef GC_CHECK_STRING_BYTES
|
|
|
2080 if (GC_STRING_BYTES (s) != SDATA_NBYTES (data))
|
|
|
2081 abort ();
|
|
|
2082 #else
|
|
27142
|
2083 data->u.nbytes = GC_STRING_BYTES (s);
|
|
31897
|
2084 #endif
|
|
27142
|
2085 data->string = NULL;
|
|
|
2086
|
|
|
2087 /* Reset the strings's `data' member so that we
|
|
|
2088 know it's free. */
|
|
|
2089 s->data = NULL;
|
|
|
2090
|
|
|
2091 /* Put the string on the free-list. */
|
|
|
2092 NEXT_FREE_LISP_STRING (s) = string_free_list;
|
|
|
2093 string_free_list = s;
|
|
|
2094 ++nfree;
|
|
|
2095 }
|
|
|
2096 }
|
|
|
2097 else
|
|
|
2098 {
|
|
|
2099 /* S was on the free-list before. Put it there again. */
|
|
|
2100 NEXT_FREE_LISP_STRING (s) = string_free_list;
|
|
|
2101 string_free_list = s;
|
|
|
2102 ++nfree;
|
|
|
2103 }
|
|
|
2104 }
|
|
|
2105
|
|
27738
|
2106 /* Free blocks that contain free Lisp_Strings only, except
|
|
27142
|
2107 the first two of them. */
|
51907
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2108 if (nfree == STRING_BLOCK_SIZE
|
4073a8ee4fc0
(BLOCK_PADDING): Rename from ABLOCKS_PADDING. Update users.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
2109 && total_free_strings > STRING_BLOCK_SIZE)
|
|
27142
|
2110 {
|
|
|
2111 lisp_free (b);
|
|
|
2112 --n_string_blocks;
|
|
|
2113 string_free_list = free_list_before;
|
|
|
2114 }
|
|
|
2115 else
|
|
|
2116 {
|
|
|
2117 total_free_strings += nfree;
|
|
|
2118 b->next = live_blocks;
|
|
|
2119 live_blocks = b;
|
|
|
2120 }
|
|
|
2121 }
|
|
|
2122
|
|
58707
|
2123 check_string_free_list ();
|
|
58631
|
2124
|
|
27142
|
2125 string_blocks = live_blocks;
|
|
|
2126 free_large_strings ();
|
|
|
2127 compact_small_strings ();
|
|
58631
|
2128
|
|
58707
|
2129 check_string_free_list ();
|
|
27142
|
2130 }
|
|
|
2131
|
|
|
2132
|
|
|
2133 /* Free dead large strings. */
|
|
|
2134
|
|
|
2135 static void
|
|
|
2136 free_large_strings ()
|
|
|
2137 {
|
|
|
2138 struct sblock *b, *next;
|
|
|
2139 struct sblock *live_blocks = NULL;
|
|
49600
|
2140
|
|
27142
|
2141 for (b = large_sblocks; b; b = next)
|
|
|
2142 {
|
|
|
2143 next = b->next;
|
|
|
2144
|
|
|
2145 if (b->first_data.string == NULL)
|
|
|
2146 lisp_free (b);
|
|
|
2147 else
|
|
|
2148 {
|
|
|
2149 b->next = live_blocks;
|
|
|
2150 live_blocks = b;
|
|
|
2151 }
|
|
|
2152 }
|
|
|
2153
|
|
|
2154 large_sblocks = live_blocks;
|
|
|
2155 }
|
|
|
2156
|
|
|
2157
|
|
|
2158 /* Compact data of small strings. Free sblocks that don't contain
|
|
|
2159 data of live strings after compaction. */
|
|
|
2160
|
|
|
2161 static void
|
|
|
2162 compact_small_strings ()
|
|
|
2163 {
|
|
|
2164 struct sblock *b, *tb, *next;
|
|
|
2165 struct sdata *from, *to, *end, *tb_end;
|
|
|
2166 struct sdata *to_end, *from_end;
|
|
|
2167
|
|
|
2168 /* TB is the sblock we copy to, TO is the sdata within TB we copy
|
|
|
2169 to, and TB_END is the end of TB. */
|
|
|
2170 tb = oldest_sblock;
|
|
|
2171 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
|
|
|
2172 to = &tb->first_data;
|
|
|
2173
|
|
|
2174 /* Step through the blocks from the oldest to the youngest. We
|
|
|
2175 expect that old blocks will stabilize over time, so that less
|
|
|
2176 copying will happen this way. */
|
|
|
2177 for (b = oldest_sblock; b; b = b->next)
|
|
|
2178 {
|
|
|
2179 end = b->next_free;
|
|
|
2180 xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
|
|
49600
|
2181
|
|
27142
|
2182 for (from = &b->first_data; from < end; from = from_end)
|
|
|
2183 {
|
|
|
2184 /* Compute the next FROM here because copying below may
|
|
|
2185 overwrite data we need to compute it. */
|
|
|
2186 int nbytes;
|
|
|
2187
|
|
31897
|
2188 #ifdef GC_CHECK_STRING_BYTES
|
|
|
2189 /* Check that the string size recorded in the string is the
|
|
|
2190 same as the one recorded in the sdata structure. */
|
|
|
2191 if (from->string
|
|
|
2192 && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from))
|
|
|
2193 abort ();
|
|
|
2194 #endif /* GC_CHECK_STRING_BYTES */
|
|
49600
|
2195
|
|
27142
|
2196 if (from->string)
|
|
|
2197 nbytes = GC_STRING_BYTES (from->string);
|
|
|
2198 else
|
|
31897
|
2199 nbytes = SDATA_NBYTES (from);
|
|
49600
|
2200
|
|
58631
|
2201 if (nbytes > LARGE_STRING_BYTES)
|
|
|
2202 abort ();
|
|
|
2203
|
|
27142
|
2204 nbytes = SDATA_SIZE (nbytes);
|
|
58631
|
2205 from_end = (struct sdata *) ((char *) from + nbytes + GC_STRING_EXTRA);
|
|
|
2206
|
|
|
2207 #ifdef GC_CHECK_STRING_OVERRUN
|
|
58707
|
2208 if (bcmp (string_overrun_cookie,
|
|
|
2209 ((char *) from_end) - GC_STRING_OVERRUN_COOKIE_SIZE,
|
|
|
2210 GC_STRING_OVERRUN_COOKIE_SIZE))
|
|
58631
|
2211 abort ();
|
|
|
2212 #endif
|
|
49600
|
2213
|
|
27142
|
2214 /* FROM->string non-null means it's alive. Copy its data. */
|
|
|
2215 if (from->string)
|
|
|
2216 {
|
|
|
2217 /* If TB is full, proceed with the next sblock. */
|
|
58631
|
2218 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
|
|
27142
|
2219 if (to_end > tb_end)
|
|
|
2220 {
|
|
|
2221 tb->next_free = to;
|
|
|
2222 tb = tb->next;
|
|
|
2223 tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
|
|
|
2224 to = &tb->first_data;
|
|
58631
|
2225 to_end = (struct sdata *) ((char *) to + nbytes + GC_STRING_EXTRA);
|
|
27142
|
2226 }
|
|
49600
|
2227
|
|
27142
|
2228 /* Copy, and update the string's `data' pointer. */
|
|
|
2229 if (from != to)
|
|
|
2230 {
|
|
30823
|
2231 xassert (tb != b || to <= from);
|
|
58631
|
2232 safe_bcopy ((char *) from, (char *) to, nbytes + GC_STRING_EXTRA);
|
|
31897
|
2233 to->string->data = SDATA_DATA (to);
|
|
27142
|
2234 }
|
|
|
2235
|
|
|
2236 /* Advance past the sdata we copied to. */
|
|
|
2237 to = to_end;
|
|
|
2238 }
|
|
|
2239 }
|
|
|
2240 }
|
|
|
2241
|
|
|
2242 /* The rest of the sblocks following TB don't contain live data, so
|
|
|
2243 we can free them. */
|
|
|
2244 for (b = tb->next; b; b = next)
|
|
|
2245 {
|
|
|
2246 next = b->next;
|
|
|
2247 lisp_free (b);
|
|
|
2248 }
|
|
|
2249
|
|
|
2250 tb->next_free = to;
|
|
|
2251 tb->next = NULL;
|
|
|
2252 current_sblock = tb;
|
|
|
2253 }
|
|
|
2254
|
|
|
2255
|
|
|
2256 DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
|
|
55745
|
2257 doc: /* Return a newly created string of length LENGTH, with INIT in each element.
|
|
|
2258 LENGTH must be an integer.
|
|
|
2259 INIT must be an integer that represents a character. */)
|
|
39988
|
2260 (length, init)
|
|
27142
|
2261 Lisp_Object length, init;
|
|
|
2262 {
|
|
|
2263 register Lisp_Object val;
|
|
|
2264 register unsigned char *p, *end;
|
|
|
2265 int c, nbytes;
|
|
|
2266
|
|
40656
|
2267 CHECK_NATNUM (length);
|
|
|
2268 CHECK_NUMBER (init);
|
|
27142
|
2269
|
|
|
2270 c = XINT (init);
|
|
|
2271 if (SINGLE_BYTE_CHAR_P (c))
|
|
|
2272 {
|
|
|
2273 nbytes = XINT (length);
|
|
|
2274 val = make_uninit_string (nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2275 p = SDATA (val);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2276 end = p + SCHARS (val);
|
|
27142
|
2277 while (p != end)
|
|
|
2278 *p++ = c;
|
|
|
2279 }
|
|
|
2280 else
|
|
|
2281 {
|
33800
7f148cfbd1f7
(Fmake_string): Use MAX_MULTIBYTE_LENGTH, instead of hard coded `4'.
Kenichi Handa <handa@m17n.org>
diff
changeset
|
2282 unsigned char str[MAX_MULTIBYTE_LENGTH];
|
|
27142
|
2283 int len = CHAR_STRING (c, str);
|
|
|
2284
|
|
|
2285 nbytes = len * XINT (length);
|
|
|
2286 val = make_uninit_multibyte_string (XINT (length), nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2287 p = SDATA (val);
|
|
27142
|
2288 end = p + nbytes;
|
|
|
2289 while (p != end)
|
|
|
2290 {
|
|
|
2291 bcopy (str, p, len);
|
|
|
2292 p += len;
|
|
|
2293 }
|
|
|
2294 }
|
|
49600
|
2295
|
|
27142
|
2296 *p = 0;
|
|
|
2297 return val;
|
|
|
2298 }
|
|
|
2299
|
|
|
2300
|
|
|
2301 DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
|
|
68741
|
2302 doc: /* Return a new bool-vector of length LENGTH, using INIT for each element.
|
|
39988
|
2303 LENGTH must be a number. INIT matters only in whether it is t or nil. */)
|
|
|
2304 (length, init)
|
|
27142
|
2305 Lisp_Object length, init;
|
|
|
2306 {
|
|
|
2307 register Lisp_Object val;
|
|
|
2308 struct Lisp_Bool_Vector *p;
|
|
|
2309 int real_init, i;
|
|
|
2310 int length_in_chars, length_in_elts, bits_per_value;
|
|
|
2311
|
|
40656
|
2312 CHECK_NATNUM (length);
|
|
27142
|
2313
|
|
55159
|
2314 bits_per_value = sizeof (EMACS_INT) * BOOL_VECTOR_BITS_PER_CHAR;
|
|
27142
|
2315
|
|
|
2316 length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
|
|
55159
|
2317 length_in_chars = ((XFASTINT (length) + BOOL_VECTOR_BITS_PER_CHAR - 1)
|
|
|
2318 / BOOL_VECTOR_BITS_PER_CHAR);
|
|
27142
|
2319
|
|
|
2320 /* We must allocate one more elements than LENGTH_IN_ELTS for the
|
|
|
2321 slot `size' of the struct Lisp_Bool_Vector. */
|
|
|
2322 val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
|
|
|
2323 p = XBOOL_VECTOR (val);
|
|
49600
|
2324
|
|
27142
|
2325 /* Get rid of any bits that would cause confusion. */
|
|
|
2326 p->vector_size = 0;
|
|
|
2327 XSETBOOL_VECTOR (val, p);
|
|
|
2328 p->size = XFASTINT (length);
|
|
49600
|
2329
|
|
27142
|
2330 real_init = (NILP (init) ? 0 : -1);
|
|
|
2331 for (i = 0; i < length_in_chars ; i++)
|
|
|
2332 p->data[i] = real_init;
|
|
49600
|
2333
|
|
27142
|
2334 /* Clear the extraneous bits in the last byte. */
|
|
55159
|
2335 if (XINT (length) != length_in_chars * BOOL_VECTOR_BITS_PER_CHAR)
|
|
27142
|
2336 XBOOL_VECTOR (val)->data[length_in_chars - 1]
|
|
55159
|
2337 &= (1 << (XINT (length) % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
|
|
27142
|
2338
|
|
|
2339 return val;
|
|
|
2340 }
|
|
|
2341
|
|
|
2342
|
|
|
2343 /* Make a string from NBYTES bytes at CONTENTS, and compute the number
|
|
|
2344 of characters from the contents. This string may be unibyte or
|
|
|
2345 multibyte, depending on the contents. */
|
|
|
2346
|
|
|
2347 Lisp_Object
|
|
|
2348 make_string (contents, nbytes)
|
|
46459
|
2349 const char *contents;
|
|
27142
|
2350 int nbytes;
|
|
|
2351 {
|
|
|
2352 register Lisp_Object val;
|
|
28997
|
2353 int nchars, multibyte_nbytes;
|
|
|
2354
|
|
|
2355 parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
|
|
|
2356 if (nbytes == nchars || nbytes != multibyte_nbytes)
|
|
|
2357 /* CONTENTS contains no multibyte sequences or contains an invalid
|
|
|
2358 multibyte sequence. We must make unibyte string. */
|
|
33623
|
2359 val = make_unibyte_string (contents, nbytes);
|
|
|
2360 else
|
|
|
2361 val = make_multibyte_string (contents, nchars, nbytes);
|
|
27142
|
2362 return val;
|
|
|
2363 }
|
|
|
2364
|
|
|
2365
|
|
|
2366 /* Make an unibyte string from LENGTH bytes at CONTENTS. */
|
|
|
2367
|
|
|
2368 Lisp_Object
|
|
|
2369 make_unibyte_string (contents, length)
|
|
46459
|
2370 const char *contents;
|
|
27142
|
2371 int length;
|
|
|
2372 {
|
|
|
2373 register Lisp_Object val;
|
|
|
2374 val = make_uninit_string (length);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2375 bcopy (contents, SDATA (val), length);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2376 STRING_SET_UNIBYTE (val);
|
|
27142
|
2377 return val;
|
|
|
2378 }
|
|
|
2379
|
|
|
2380
|
|
|
2381 /* Make a multibyte string from NCHARS characters occupying NBYTES
|
|
|
2382 bytes at CONTENTS. */
|
|
|
2383
|
|
|
2384 Lisp_Object
|
|
|
2385 make_multibyte_string (contents, nchars, nbytes)
|
|
46459
|
2386 const char *contents;
|
|
27142
|
2387 int nchars, nbytes;
|
|
|
2388 {
|
|
|
2389 register Lisp_Object val;
|
|
|
2390 val = make_uninit_multibyte_string (nchars, nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2391 bcopy (contents, SDATA (val), nbytes);
|
|
27142
|
2392 return val;
|
|
|
2393 }
|
|
|
2394
|
|
|
2395
|
|
|
2396 /* Make a string from NCHARS characters occupying NBYTES bytes at
|
|
|
2397 CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
|
|
|
2398
|
|
|
2399 Lisp_Object
|
|
|
2400 make_string_from_bytes (contents, nchars, nbytes)
|
|
50274
|
2401 const char *contents;
|
|
27142
|
2402 int nchars, nbytes;
|
|
|
2403 {
|
|
|
2404 register Lisp_Object val;
|
|
|
2405 val = make_uninit_multibyte_string (nchars, nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2406 bcopy (contents, SDATA (val), nbytes);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2407 if (SBYTES (val) == SCHARS (val))
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2408 STRING_SET_UNIBYTE (val);
|
|
27142
|
2409 return val;
|
|
|
2410 }
|
|
|
2411
|
|
|
2412
|
|
|
2413 /* Make a string from NCHARS characters occupying NBYTES bytes at
|
|
|
2414 CONTENTS. The argument MULTIBYTE controls whether to label the
|
|
50200
|
2415 string as multibyte. If NCHARS is negative, it counts the number of
|
|
|
2416 characters by itself. */
|
|
27142
|
2417
|
|
|
2418 Lisp_Object
|
|
|
2419 make_specified_string (contents, nchars, nbytes, multibyte)
|
|
50274
|
2420 const char *contents;
|
|
27142
|
2421 int nchars, nbytes;
|
|
|
2422 int multibyte;
|
|
|
2423 {
|
|
|
2424 register Lisp_Object val;
|
|
50200
|
2425
|
|
|
2426 if (nchars < 0)
|
|
|
2427 {
|
|
|
2428 if (multibyte)
|
|
|
2429 nchars = multibyte_chars_in_text (contents, nbytes);
|
|
|
2430 else
|
|
|
2431 nchars = nbytes;
|
|
|
2432 }
|
|
27142
|
2433 val = make_uninit_multibyte_string (nchars, nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2434 bcopy (contents, SDATA (val), nbytes);
|
|
27142
|
2435 if (!multibyte)
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2436 STRING_SET_UNIBYTE (val);
|
|
27142
|
2437 return val;
|
|
|
2438 }
|
|
|
2439
|
|
|
2440
|
|
|
2441 /* Make a string from the data at STR, treating it as multibyte if the
|
|
|
2442 data warrants. */
|
|
|
2443
|
|
|
2444 Lisp_Object
|
|
|
2445 build_string (str)
|
|
46459
|
2446 const char *str;
|
|
27142
|
2447 {
|
|
|
2448 return make_string (str, strlen (str));
|
|
|
2449 }
|
|
|
2450
|
|
|
2451
|
|
|
2452 /* Return an unibyte Lisp_String set up to hold LENGTH characters
|
|
|
2453 occupying LENGTH bytes. */
|
|
|
2454
|
|
|
2455 Lisp_Object
|
|
|
2456 make_uninit_string (length)
|
|
|
2457 int length;
|
|
|
2458 {
|
|
|
2459 Lisp_Object val;
|
|
|
2460 val = make_uninit_multibyte_string (length, length);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2461 STRING_SET_UNIBYTE (val);
|
|
27142
|
2462 return val;
|
|
|
2463 }
|
|
|
2464
|
|
|
2465
|
|
|
2466 /* Return a multibyte Lisp_String set up to hold NCHARS characters
|
|
|
2467 which occupy NBYTES bytes. */
|
|
|
2468
|
|
|
2469 Lisp_Object
|
|
|
2470 make_uninit_multibyte_string (nchars, nbytes)
|
|
|
2471 int nchars, nbytes;
|
|
|
2472 {
|
|
|
2473 Lisp_Object string;
|
|
|
2474 struct Lisp_String *s;
|
|
|
2475
|
|
|
2476 if (nchars < 0)
|
|
|
2477 abort ();
|
|
|
2478
|
|
|
2479 s = allocate_string ();
|
|
|
2480 allocate_string_data (s, nchars, nbytes);
|
|
|
2481 XSETSTRING (string, s);
|
|
|
2482 string_chars_consed += nbytes;
|
|
|
2483 return string;
|
|
|
2484 }
|
|
|
2485
|
|
|
2486
|
|
|
2487
|
|
|
2488 /***********************************************************************
|
|
|
2489 Float Allocation
|
|
|
2490 ***********************************************************************/
|
|
1908
|
2491
|
|
300
|
2492 /* We store float cells inside of float_blocks, allocating a new
|
|
27142
|
2493 float_block with malloc whenever necessary. Float cells reclaimed
|
|
|
2494 by GC are put on a free list to be reallocated before allocating
|
|
51723
|
2495 any new float cells from the latest float_block. */
|
|
300
|
2496
|
|
53582
|
2497 #define FLOAT_BLOCK_SIZE \
|
|
|
2498 (((BLOCK_BYTES - sizeof (struct float_block *) \
|
|
|
2499 /* The compiler might add padding at the end. */ \
|
|
|
2500 - (sizeof (struct Lisp_Float) - sizeof (int))) * CHAR_BIT) \
|
|
51723
|
2501 / (sizeof (struct Lisp_Float) * CHAR_BIT + 1))
|
|
|
2502
|
|
|
2503 #define GETMARKBIT(block,n) \
|
|
|
2504 (((block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
|
|
|
2505 >> ((n) % (sizeof(int) * CHAR_BIT))) \
|
|
|
2506 & 1)
|
|
|
2507
|
|
|
2508 #define SETMARKBIT(block,n) \
|
|
|
2509 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
|
|
|
2510 |= 1 << ((n) % (sizeof(int) * CHAR_BIT))
|
|
|
2511
|
|
|
2512 #define UNSETMARKBIT(block,n) \
|
|
|
2513 (block)->gcmarkbits[(n) / (sizeof(int) * CHAR_BIT)] \
|
|
|
2514 &= ~(1 << ((n) % (sizeof(int) * CHAR_BIT)))
|
|
|
2515
|
|
|
2516 #define FLOAT_BLOCK(fptr) \
|
|
|
2517 ((struct float_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
|
|
|
2518
|
|
|
2519 #define FLOAT_INDEX(fptr) \
|
|
|
2520 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Float))
|
|
300
|
2521
|
|
|
2522 struct float_block
|
|
27142
|
2523 {
|
|
51723
|
2524 /* Place `floats' at the beginning, to ease up FLOAT_INDEX's job. */
|
|
27142
|
2525 struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
|
|
51723
|
2526 int gcmarkbits[1 + FLOAT_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
|
|
|
2527 struct float_block *next;
|
|
27142
|
2528 };
|
|
300
|
2529
|
|
51723
|
2530 #define FLOAT_MARKED_P(fptr) \
|
|
|
2531 GETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
|
|
|
2532
|
|
|
2533 #define FLOAT_MARK(fptr) \
|
|
|
2534 SETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
|
|
|
2535
|
|
|
2536 #define FLOAT_UNMARK(fptr) \
|
|
|
2537 UNSETMARKBIT (FLOAT_BLOCK (fptr), FLOAT_INDEX ((fptr)))
|
|
|
2538
|
|
27738
|
2539 /* Current float_block. */
|
|
|
2540
|
|
300
|
2541 struct float_block *float_block;
|
|
27738
|
2542
|
|
|
2543 /* Index of first unused Lisp_Float in the current float_block. */
|
|
|
2544
|
|
300
|
2545 int float_block_index;
|
|
|
2546
|
|
23958
|
2547 /* Total number of float blocks now in use. */
|
|
27142
|
2548
|
|
23958
|
2549 int n_float_blocks;
|
|
|
2550
|
|
27738
|
2551 /* Free-list of Lisp_Floats. */
|
|
|
2552
|
|
300
|
2553 struct Lisp_Float *float_free_list;
|
|
|
2554
|
|
27738
|
2555
|
|
39297
|
2556 /* Initialize float allocation. */
|
|
27738
|
2557
|
|
300
|
2558 void
|
|
|
2559 init_float ()
|
|
|
2560 {
|
|
51938
|
2561 float_block = NULL;
|
|
|
2562 float_block_index = FLOAT_BLOCK_SIZE; /* Force alloc of new float_block. */
|
|
300
|
2563 float_free_list = 0;
|
|
51938
|
2564 n_float_blocks = 0;
|
|
300
|
2565 }
|
|
|
2566
|
|
27738
|
2567
|
|
|
2568 /* Explicitly free a float cell by putting it on the free-list. */
|
|
27142
|
2569
|
|
21514
|
2570 void
|
|
300
|
2571 free_float (ptr)
|
|
|
2572 struct Lisp_Float *ptr;
|
|
|
2573 {
|
|
66889
|
2574 ptr->u.chain = float_free_list;
|
|
300
|
2575 float_free_list = ptr;
|
|
|
2576 }
|
|
|
2577
|
|
27738
|
2578
|
|
|
2579 /* Return a new float object with value FLOAT_VALUE. */
|
|
|
2580
|
|
300
|
2581 Lisp_Object
|
|
|
2582 make_float (float_value)
|
|
|
2583 double float_value;
|
|
|
2584 {
|
|
|
2585 register Lisp_Object val;
|
|
|
2586
|
|
68430
|
2587 /* eassert (!handling_signal); */
|
|
|
2588
|
|
|
2589 #ifndef SYNC_INPUT
|
|
|
2590 BLOCK_INPUT;
|
|
|
2591 #endif
|
|
68350
|
2592
|
|
300
|
2593 if (float_free_list)
|
|
|
2594 {
|
19666
81957e8b80e2
(free_float, free_cons): Don't use the same field for chaining as for marking.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2595 /* We use the data field for chaining the free list
|
81957e8b80e2
(free_float, free_cons): Don't use the same field for chaining as for marking.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2596 so that we won't use the same field that has the mark bit. */
|
|
9261
|
2597 XSETFLOAT (val, float_free_list);
|
|
66889
|
2598 float_free_list = float_free_list->u.chain;
|
|
300
|
2599 }
|
|
|
2600 else
|
|
|
2601 {
|
|
|
2602 if (float_block_index == FLOAT_BLOCK_SIZE)
|
|
|
2603 {
|
|
12529
|
2604 register struct float_block *new;
|
|
|
2605
|
|
51723
|
2606 new = (struct float_block *) lisp_align_malloc (sizeof *new,
|
|
|
2607 MEM_TYPE_FLOAT);
|
|
300
|
2608 new->next = float_block;
|
|
53093
|
2609 bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
|
|
300
|
2610 float_block = new;
|
|
|
2611 float_block_index = 0;
|
|
23958
|
2612 n_float_blocks++;
|
|
300
|
2613 }
|
|
53093
|
2614 XSETFLOAT (val, &float_block->floats[float_block_index]);
|
|
|
2615 float_block_index++;
|
|
300
|
2616 }
|
|
49600
|
2617
|
|
68430
|
2618 #ifndef SYNC_INPUT
|
|
|
2619 UNBLOCK_INPUT;
|
|
|
2620 #endif
|
|
|
2621
|
|
25645
|
2622 XFLOAT_DATA (val) = float_value;
|
|
53093
|
2623 eassert (!FLOAT_MARKED_P (XFLOAT (val)));
|
|
300
|
2624 consing_since_gc += sizeof (struct Lisp_Float);
|
|
12748
|
2625 floats_consed++;
|
|
300
|
2626 return val;
|
|
|
2627 }
|
|
|
2628
|
|
27142
|
2629
|
|
300
|
2630
|
|
27142
|
2631 /***********************************************************************
|
|
|
2632 Cons Allocation
|
|
|
2633 ***********************************************************************/
|
|
|
2634
|
|
300
|
2635 /* We store cons cells inside of cons_blocks, allocating a new
|
|
|
2636 cons_block with malloc whenever necessary. Cons cells reclaimed by
|
|
|
2637 GC are put on a free list to be reallocated before allocating
|
|
51938
|
2638 any new cons cells from the latest cons_block. */
|
|
300
|
2639
|
|
|
2640 #define CONS_BLOCK_SIZE \
|
|
51938
|
2641 (((BLOCK_BYTES - sizeof (struct cons_block *)) * CHAR_BIT) \
|
|
|
2642 / (sizeof (struct Lisp_Cons) * CHAR_BIT + 1))
|
|
|
2643
|
|
|
2644 #define CONS_BLOCK(fptr) \
|
|
|
2645 ((struct cons_block *)(((EMACS_UINT)(fptr)) & ~(BLOCK_ALIGN - 1)))
|
|
|
2646
|
|
|
2647 #define CONS_INDEX(fptr) \
|
|
|
2648 ((((EMACS_UINT)(fptr)) & (BLOCK_ALIGN - 1)) / sizeof (struct Lisp_Cons))
|
|
300
|
2649
|
|
|
2650 struct cons_block
|
|
27142
|
2651 {
|
|
51938
|
2652 /* Place `conses' at the beginning, to ease up CONS_INDEX's job. */
|
|
27142
|
2653 struct Lisp_Cons conses[CONS_BLOCK_SIZE];
|
|
51938
|
2654 int gcmarkbits[1 + CONS_BLOCK_SIZE / (sizeof(int) * CHAR_BIT)];
|
|
|
2655 struct cons_block *next;
|
|
27142
|
2656 };
|
|
300
|
2657
|
|
51938
|
2658 #define CONS_MARKED_P(fptr) \
|
|
|
2659 GETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
|
|
|
2660
|
|
|
2661 #define CONS_MARK(fptr) \
|
|
|
2662 SETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
|
|
|
2663
|
|
|
2664 #define CONS_UNMARK(fptr) \
|
|
|
2665 UNSETMARKBIT (CONS_BLOCK (fptr), CONS_INDEX ((fptr)))
|
|
|
2666
|
|
27738
|
2667 /* Current cons_block. */
|
|
|
2668
|
|
300
|
2669 struct cons_block *cons_block;
|
|
27738
|
2670
|
|
|
2671 /* Index of first unused Lisp_Cons in the current block. */
|
|
|
2672
|
|
300
|
2673 int cons_block_index;
|
|
|
2674
|
|
27738
|
2675 /* Free-list of Lisp_Cons structures. */
|
|
|
2676
|
|
300
|
2677 struct Lisp_Cons *cons_free_list;
|
|
|
2678
|
|
23958
|
2679 /* Total number of cons blocks now in use. */
|
|
27142
|
2680
|
|
23958
|
2681 int n_cons_blocks;
|
|
|
2682
|
|
27738
|
2683
|
|
|
2684 /* Initialize cons allocation. */
|
|
|
2685
|
|
300
|
2686 void
|
|
|
2687 init_cons ()
|
|
|
2688 {
|
|
51938
|
2689 cons_block = NULL;
|
|
|
2690 cons_block_index = CONS_BLOCK_SIZE; /* Force alloc of new cons_block. */
|
|
300
|
2691 cons_free_list = 0;
|
|
51938
|
2692 n_cons_blocks = 0;
|
|
300
|
2693 }
|
|
|
2694
|
|
27738
|
2695
|
|
|
2696 /* Explicitly free a cons cell by putting it on the free-list. */
|
|
20375
|
2697
|
|
|
2698 void
|
|
300
|
2699 free_cons (ptr)
|
|
|
2700 struct Lisp_Cons *ptr;
|
|
|
2701 {
|
|
66889
|
2702 ptr->u.chain = cons_free_list;
|
|
27738
|
2703 #if GC_MARK_STACK
|
|
|
2704 ptr->car = Vdead;
|
|
|
2705 #endif
|
|
300
|
2706 cons_free_list = ptr;
|
|
|
2707 }
|
|
|
2708
|
|
|
2709 DEFUN ("cons", Fcons, Scons, 2, 2, 0,
|
|
40107
|
2710 doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
|
|
39988
|
2711 (car, cdr)
|
|
300
|
2712 Lisp_Object car, cdr;
|
|
|
2713 {
|
|
|
2714 register Lisp_Object val;
|
|
|
2715
|
|
68430
|
2716 /* eassert (!handling_signal); */
|
|
|
2717
|
|
|
2718 #ifndef SYNC_INPUT
|
|
|
2719 BLOCK_INPUT;
|
|
|
2720 #endif
|
|
68350
|
2721
|
|
300
|
2722 if (cons_free_list)
|
|
|
2723 {
|
19666
81957e8b80e2
(free_float, free_cons): Don't use the same field for chaining as for marking.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2724 /* We use the cdr for chaining the free list
|
81957e8b80e2
(free_float, free_cons): Don't use the same field for chaining as for marking.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
2725 so that we won't use the same field that has the mark bit. */
|
|
9261
|
2726 XSETCONS (val, cons_free_list);
|
|
66889
|
2727 cons_free_list = cons_free_list->u.chain;
|
|
300
|
2728 }
|
|
|
2729 else
|
|
|
2730 {
|
|
|
2731 if (cons_block_index == CONS_BLOCK_SIZE)
|
|
|
2732 {
|
|
12529
|
2733 register struct cons_block *new;
|
|
51938
|
2734 new = (struct cons_block *) lisp_align_malloc (sizeof *new,
|
|
|
2735 MEM_TYPE_CONS);
|
|
53093
|
2736 bzero ((char *) new->gcmarkbits, sizeof new->gcmarkbits);
|
|
300
|
2737 new->next = cons_block;
|
|
|
2738 cons_block = new;
|
|
|
2739 cons_block_index = 0;
|
|
23958
|
2740 n_cons_blocks++;
|
|
300
|
2741 }
|
|
53093
|
2742 XSETCONS (val, &cons_block->conses[cons_block_index]);
|
|
|
2743 cons_block_index++;
|
|
300
|
2744 }
|
|
49600
|
2745
|
|
68430
|
2746 #ifndef SYNC_INPUT
|
|
|
2747 UNBLOCK_INPUT;
|
|
|
2748 #endif
|
|
|
2749
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2750 XSETCAR (val, car);
|
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2751 XSETCDR (val, cdr);
|
|
53093
|
2752 eassert (!CONS_MARKED_P (XCONS (val)));
|
|
300
|
2753 consing_since_gc += sizeof (struct Lisp_Cons);
|
|
12748
|
2754 cons_cells_consed++;
|
|
300
|
2755 return val;
|
|
|
2756 }
|
|
27142
|
2757
|
|
56539
|
2758 /* Get an error now if there's any junk in the cons free list. */
|
|
|
2759 void
|
|
|
2760 check_cons_list ()
|
|
|
2761 {
|
|
58631
|
2762 #ifdef GC_CHECK_CONS_LIST
|
|
56539
|
2763 struct Lisp_Cons *tail = cons_free_list;
|
|
|
2764
|
|
|
2765 while (tail)
|
|
66889
|
2766 tail = tail->u.chain;
|
|
56539
|
2767 #endif
|
|
|
2768 }
|
|
27738
|
2769
|
|
20849
|
2770 /* Make a list of 2, 3, 4 or 5 specified objects. */
|
|
|
2771
|
|
|
2772 Lisp_Object
|
|
|
2773 list2 (arg1, arg2)
|
|
|
2774 Lisp_Object arg1, arg2;
|
|
|
2775 {
|
|
|
2776 return Fcons (arg1, Fcons (arg2, Qnil));
|
|
|
2777 }
|
|
|
2778
|
|
27738
|
2779
|
|
20849
|
2780 Lisp_Object
|
|
|
2781 list3 (arg1, arg2, arg3)
|
|
|
2782 Lisp_Object arg1, arg2, arg3;
|
|
|
2783 {
|
|
|
2784 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Qnil)));
|
|
|
2785 }
|
|
|
2786
|
|
27738
|
2787
|
|
20849
|
2788 Lisp_Object
|
|
|
2789 list4 (arg1, arg2, arg3, arg4)
|
|
|
2790 Lisp_Object arg1, arg2, arg3, arg4;
|
|
|
2791 {
|
|
|
2792 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4, Qnil))));
|
|
|
2793 }
|
|
|
2794
|
|
27738
|
2795
|
|
20849
|
2796 Lisp_Object
|
|
|
2797 list5 (arg1, arg2, arg3, arg4, arg5)
|
|
|
2798 Lisp_Object arg1, arg2, arg3, arg4, arg5;
|
|
|
2799 {
|
|
|
2800 return Fcons (arg1, Fcons (arg2, Fcons (arg3, Fcons (arg4,
|
|
|
2801 Fcons (arg5, Qnil)))));
|
|
|
2802 }
|
|
300
|
2803
|
|
27738
|
2804
|
|
300
|
2805 DEFUN ("list", Flist, Slist, 0, MANY, 0,
|
|
40977
|
2806 doc: /* Return a newly created list with specified arguments as elements.
|
|
40113
|
2807 Any number of arguments, even zero arguments, are allowed.
|
|
|
2808 usage: (list &rest OBJECTS) */)
|
|
39988
|
2809 (nargs, args)
|
|
300
|
2810 int nargs;
|
|
|
2811 register Lisp_Object *args;
|
|
|
2812 {
|
|
13610
|
2813 register Lisp_Object val;
|
|
|
2814 val = Qnil;
|
|
300
|
2815
|
|
13610
|
2816 while (nargs > 0)
|
|
|
2817 {
|
|
|
2818 nargs--;
|
|
|
2819 val = Fcons (args[nargs], val);
|
|
|
2820 }
|
|
300
|
2821 return val;
|
|
|
2822 }
|
|
|
2823
|
|
27738
|
2824
|
|
300
|
2825 DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0,
|
|
40107
|
2826 doc: /* Return a newly created list of length LENGTH, with each element being INIT. */)
|
|
39988
|
2827 (length, init)
|
|
300
|
2828 register Lisp_Object length, init;
|
|
|
2829 {
|
|
|
2830 register Lisp_Object val;
|
|
|
2831 register int size;
|
|
|
2832
|
|
40656
|
2833 CHECK_NATNUM (length);
|
9953
e0672d4cf470
(Fmake_list, Fmake_vector, Fmake_string): Use CHECK_NATNUM instead of its
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
2834 size = XFASTINT (length);
|
|
300
|
2835
|
|
|
2836 val = Qnil;
|
|
35762
|
2837 while (size > 0)
|
|
|
2838 {
|
|
|
2839 val = Fcons (init, val);
|
|
|
2840 --size;
|
|
|
2841
|
|
|
2842 if (size > 0)
|
|
|
2843 {
|
|
|
2844 val = Fcons (init, val);
|
|
|
2845 --size;
|
|
49600
|
2846
|
|
35762
|
2847 if (size > 0)
|
|
|
2848 {
|
|
|
2849 val = Fcons (init, val);
|
|
|
2850 --size;
|
|
49600
|
2851
|
|
35762
|
2852 if (size > 0)
|
|
|
2853 {
|
|
|
2854 val = Fcons (init, val);
|
|
|
2855 --size;
|
|
49600
|
2856
|
|
35762
|
2857 if (size > 0)
|
|
|
2858 {
|
|
|
2859 val = Fcons (init, val);
|
|
|
2860 --size;
|
|
|
2861 }
|
|
|
2862 }
|
|
|
2863 }
|
|
|
2864 }
|
|
|
2865
|
|
|
2866 QUIT;
|
|
|
2867 }
|
|
49600
|
2868
|
|
300
|
2869 return val;
|
|
|
2870 }
|
|
27142
|
2871
|
|
|
2872
|
|
300
|
2873
|
|
27142
|
2874 /***********************************************************************
|
|
|
2875 Vector Allocation
|
|
|
2876 ***********************************************************************/
|
|
300
|
2877
|
|
27738
|
2878 /* Singly-linked list of all vectors. */
|
|
|
2879
|
|
300
|
2880 struct Lisp_Vector *all_vectors;
|
|
|
2881
|
|
27142
|
2882 /* Total number of vector-like objects now in use. */
|
|
|
2883
|
|
23958
|
2884 int n_vectors;
|
|
|
2885
|
|
27738
|
2886
|
|
|
2887 /* Value is a pointer to a newly allocated Lisp_Vector structure
|
|
|
2888 with room for LEN Lisp_Objects. */
|
|
|
2889
|
|
36435
|
2890 static struct Lisp_Vector *
|
|
|
2891 allocate_vectorlike (len, type)
|
|
9968
|
2892 EMACS_INT len;
|
|
36435
|
2893 enum mem_type type;
|
|
9968
|
2894 {
|
|
|
2895 struct Lisp_Vector *p;
|
|
30557
|
2896 size_t nbytes;
|
|
9968
|
2897
|
|
17345
|
2898 #ifdef DOUG_LEA_MALLOC
|
|
31576
|
2899 /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
|
|
|
2900 because mapped region contents are not preserved in
|
|
|
2901 a dumped Emacs. */
|
|
53555
|
2902 BLOCK_INPUT;
|
|
17345
|
2903 mallopt (M_MMAP_MAX, 0);
|
|
53555
|
2904 UNBLOCK_INPUT;
|
|
17345
|
2905 #endif
|
|
49600
|
2906
|
|
68350
|
2907 /* This gets triggered by code which I haven't bothered to fix. --Stef */
|
|
|
2908 /* eassert (!handling_signal); */
|
|
|
2909
|
|
27738
|
2910 nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
|
|
36435
|
2911 p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);
|
|
49600
|
2912
|
|
17345
|
2913 #ifdef DOUG_LEA_MALLOC
|
|
27738
|
2914 /* Back to a reasonable maximum of mmap'ed areas. */
|
|
53555
|
2915 BLOCK_INPUT;
|
|
23973
|
2916 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
|
|
53555
|
2917 UNBLOCK_INPUT;
|
|
17345
|
2918 #endif
|
|
49600
|
2919
|
|
27738
|
2920 consing_since_gc += nbytes;
|
|
12748
|
2921 vector_cells_consed += len;
|
|
9968
|
2922
|
|
68430
|
2923 #ifndef SYNC_INPUT
|
|
|
2924 BLOCK_INPUT;
|
|
|
2925 #endif
|
|
|
2926
|
|
9968
|
2927 p->next = all_vectors;
|
|
|
2928 all_vectors = p;
|
|
68430
|
2929
|
|
|
2930 #ifndef SYNC_INPUT
|
|
|
2931 UNBLOCK_INPUT;
|
|
|
2932 #endif
|
|
|
2933
|
|
27738
|
2934 ++n_vectors;
|
|
9968
|
2935 return p;
|
|
|
2936 }
|
|
|
2937
|
|
27738
|
2938
|
|
36435
|
2939 /* Allocate a vector with NSLOTS slots. */
|
|
|
2940
|
|
|
2941 struct Lisp_Vector *
|
|
|
2942 allocate_vector (nslots)
|
|
|
2943 EMACS_INT nslots;
|
|
|
2944 {
|
|
|
2945 struct Lisp_Vector *v = allocate_vectorlike (nslots, MEM_TYPE_VECTOR);
|
|
|
2946 v->size = nslots;
|
|
|
2947 return v;
|
|
|
2948 }
|
|
|
2949
|
|
|
2950
|
|
|
2951 /* Allocate other vector-like structures. */
|
|
|
2952
|
|
|
2953 struct Lisp_Hash_Table *
|
|
|
2954 allocate_hash_table ()
|
|
|
2955 {
|
|
|
2956 EMACS_INT len = VECSIZE (struct Lisp_Hash_Table);
|
|
|
2957 struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE);
|
|
|
2958 EMACS_INT i;
|
|
49600
|
2959
|
|
36435
|
2960 v->size = len;
|
|
|
2961 for (i = 0; i < len; ++i)
|
|
|
2962 v->contents[i] = Qnil;
|
|
49600
|
2963
|
|
36435
|
2964 return (struct Lisp_Hash_Table *) v;
|
|
|
2965 }
|
|
|
2966
|
|
|
2967
|
|
|
2968 struct window *
|
|
|
2969 allocate_window ()
|
|
|
2970 {
|
|
|
2971 EMACS_INT len = VECSIZE (struct window);
|
|
|
2972 struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW);
|
|
|
2973 EMACS_INT i;
|
|
49600
|
2974
|
|
36435
|
2975 for (i = 0; i < len; ++i)
|
|
|
2976 v->contents[i] = Qnil;
|
|
|
2977 v->size = len;
|
|
49600
|
2978
|
|
36435
|
2979 return (struct window *) v;
|
|
|
2980 }
|
|
|
2981
|
|
|
2982
|
|
|
2983 struct frame *
|
|
|
2984 allocate_frame ()
|
|
|
2985 {
|
|
|
2986 EMACS_INT len = VECSIZE (struct frame);
|
|
|
2987 struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME);
|
|
|
2988 EMACS_INT i;
|
|
49600
|
2989
|
|
36435
|
2990 for (i = 0; i < len; ++i)
|
|
|
2991 v->contents[i] = make_number (0);
|
|
|
2992 v->size = len;
|
|
|
2993 return (struct frame *) v;
|
|
|
2994 }
|
|
|
2995
|
|
|
2996
|
|
|
2997 struct Lisp_Process *
|
|
|
2998 allocate_process ()
|
|
|
2999 {
|
|
|
3000 EMACS_INT len = VECSIZE (struct Lisp_Process);
|
|
|
3001 struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS);
|
|
|
3002 EMACS_INT i;
|
|
49600
|
3003
|
|
36435
|
3004 for (i = 0; i < len; ++i)
|
|
|
3005 v->contents[i] = Qnil;
|
|
|
3006 v->size = len;
|
|
49600
|
3007
|
|
36435
|
3008 return (struct Lisp_Process *) v;
|
|
|
3009 }
|
|
|
3010
|
|
|
3011
|
|
|
3012 struct Lisp_Vector *
|
|
|
3013 allocate_other_vector (len)
|
|
|
3014 EMACS_INT len;
|
|
|
3015 {
|
|
|
3016 struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR);
|
|
|
3017 EMACS_INT i;
|
|
49600
|
3018
|
|
36435
|
3019 for (i = 0; i < len; ++i)
|
|
|
3020 v->contents[i] = Qnil;
|
|
|
3021 v->size = len;
|
|
49600
|
3022
|
|
36435
|
3023 return v;
|
|
|
3024 }
|
|
|
3025
|
|
|
3026
|
|
300
|
3027 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
|
|
40107
|
3028 doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
|
|
39988
|
3029 See also the function `vector'. */)
|
|
|
3030 (length, init)
|
|
300
|
3031 register Lisp_Object length, init;
|
|
|
3032 {
|
|
9968
|
3033 Lisp_Object vector;
|
|
|
3034 register EMACS_INT sizei;
|
|
|
3035 register int index;
|
|
300
|
3036 register struct Lisp_Vector *p;
|
|
|
3037
|
|
40656
|
3038 CHECK_NATNUM (length);
|
9953
e0672d4cf470
(Fmake_list, Fmake_vector, Fmake_string): Use CHECK_NATNUM instead of its
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
3039 sizei = XFASTINT (length);
|
|
300
|
3040
|
|
36435
|
3041 p = allocate_vector (sizei);
|
|
300
|
3042 for (index = 0; index < sizei; index++)
|
|
|
3043 p->contents[index] = init;
|
|
|
3044
|
|
9968
|
3045 XSETVECTOR (vector, p);
|
|
300
|
3046 return vector;
|
|
|
3047 }
|
|
|
3048
|
|
27738
|
3049
|
|
13219
|
3050 DEFUN ("make-char-table", Fmake_char_table, Smake_char_table, 1, 2, 0,
|
|
40107
|
3051 doc: /* Return a newly created char-table, with purpose PURPOSE.
|
|
39914
|
3052 Each element is initialized to INIT, which defaults to nil.
|
|
|
3053 PURPOSE should be a symbol which has a `char-table-extra-slots' property.
|
|
39988
|
3054 The property's value should be an integer between 0 and 10. */)
|
|
|
3055 (purpose, init)
|
|
13219
|
3056 register Lisp_Object purpose, init;
|
|
13141
|
3057 {
|
|
|
3058 Lisp_Object vector;
|
|
13219
|
3059 Lisp_Object n;
|
|
40656
|
3060 CHECK_SYMBOL (purpose);
|
|
17328
|
3061 n = Fget (purpose, Qchar_table_extra_slots);
|
|
40656
|
3062 CHECK_NUMBER (n);
|
|
13141
|
3063 if (XINT (n) < 0 || XINT (n) > 10)
|
|
|
3064 args_out_of_range (n, Qnil);
|
|
|
3065 /* Add 2 to the size for the defalt and parent slots. */
|
|
|
3066 vector = Fmake_vector (make_number (CHAR_TABLE_STANDARD_SLOTS + XINT (n)),
|
|
|
3067 init);
|
|
17328
|
3068 XCHAR_TABLE (vector)->top = Qt;
|
|
13150
|
3069 XCHAR_TABLE (vector)->parent = Qnil;
|
|
13219
|
3070 XCHAR_TABLE (vector)->purpose = purpose;
|
|
13141
|
3071 XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
|
|
|
3072 return vector;
|
|
|
3073 }
|
|
|
3074
|
|
27738
|
3075
|
|
61685
|
3076 /* Return a newly created sub char table with slots initialized by INIT.
|
|
17328
|
3077 Since a sub char table does not appear as a top level Emacs Lisp
|
|
|
3078 object, we don't need a Lisp interface to make it. */
|
|
|
3079
|
|
|
3080 Lisp_Object
|
|
61685
|
3081 make_sub_char_table (init)
|
|
|
3082 Lisp_Object init;
|
|
17328
|
3083 {
|
|
|
3084 Lisp_Object vector
|
|
61685
|
3085 = Fmake_vector (make_number (SUB_CHAR_TABLE_STANDARD_SLOTS), init);
|
|
17328
|
3086 XCHAR_TABLE (vector)->top = Qnil;
|
|
61685
|
3087 XCHAR_TABLE (vector)->defalt = Qnil;
|
|
17328
|
3088 XSETCHAR_TABLE (vector, XCHAR_TABLE (vector));
|
|
|
3089 return vector;
|
|
|
3090 }
|
|
|
3091
|
|
27738
|
3092
|
|
300
|
3093 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
|
|
40977
|
3094 doc: /* Return a newly created vector with specified arguments as elements.
|
|
40113
|
3095 Any number of arguments, even zero arguments, are allowed.
|
|
|
3096 usage: (vector &rest OBJECTS) */)
|
|
39988
|
3097 (nargs, args)
|
|
300
|
3098 register int nargs;
|
|
|
3099 Lisp_Object *args;
|
|
|
3100 {
|
|
|
3101 register Lisp_Object len, val;
|
|
|
3102 register int index;
|
|
|
3103 register struct Lisp_Vector *p;
|
|
|
3104
|
|
9295
|
3105 XSETFASTINT (len, nargs);
|
|
300
|
3106 val = Fmake_vector (len, Qnil);
|
|
|
3107 p = XVECTOR (val);
|
|
|
3108 for (index = 0; index < nargs; index++)
|
|
|
3109 p->contents[index] = args[index];
|
|
|
3110 return val;
|
|
|
3111 }
|
|
|
3112
|
|
27738
|
3113
|
|
300
|
3114 DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0,
|
|
40107
|
3115 doc: /* Create a byte-code object with specified arguments as elements.
|
|
39914
|
3116 The arguments should be the arglist, bytecode-string, constant vector,
|
|
|
3117 stack size, (optional) doc string, and (optional) interactive spec.
|
|
|
3118 The first four arguments are required; at most six have any
|
|
40113
|
3119 significance.
|
|
50626
|
3120 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */)
|
|
39988
|
3121 (nargs, args)
|
|
300
|
3122 register int nargs;
|
|
|
3123 Lisp_Object *args;
|
|
|
3124 {
|
|
|
3125 register Lisp_Object len, val;
|
|
|
3126 register int index;
|
|
|
3127 register struct Lisp_Vector *p;
|
|
|
3128
|
|
9295
|
3129 XSETFASTINT (len, nargs);
|
|
485
|
3130 if (!NILP (Vpurify_flag))
|
|
16101
|
3131 val = make_pure_vector ((EMACS_INT) nargs);
|
|
300
|
3132 else
|
|
|
3133 val = Fmake_vector (len, Qnil);
|
|
28997
|
3134
|
|
|
3135 if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
|
|
|
3136 /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
|
|
|
3137 earlier because they produced a raw 8-bit string for byte-code
|
|
|
3138 and now such a byte-code string is loaded as multibyte while
|
|
|
3139 raw 8-bit characters converted to multibyte form. Thus, now we
|
|
|
3140 must convert them back to the original unibyte form. */
|
|
|
3141 args[1] = Fstring_as_unibyte (args[1]);
|
|
|
3142
|
|
300
|
3143 p = XVECTOR (val);
|
|
|
3144 for (index = 0; index < nargs; index++)
|
|
|
3145 {
|
|
485
|
3146 if (!NILP (Vpurify_flag))
|
|
300
|
3147 args[index] = Fpurecopy (args[index]);
|
|
|
3148 p->contents[index] = args[index];
|
|
|
3149 }
|
|
18104
|
3150 XSETCOMPILED (val, p);
|
|
300
|
3151 return val;
|
|
|
3152 }
|
|
27142
|
3153
|
|
27738
|
3154
|
|
300
|
3155
|
|
27142
|
3156 /***********************************************************************
|
|
|
3157 Symbol Allocation
|
|
|
3158 ***********************************************************************/
|
|
|
3159
|
|
|
3160 /* Each symbol_block is just under 1020 bytes long, since malloc
|
|
|
3161 really allocates in units of powers of two and uses 4 bytes for its
|
|
|
3162 own overhead. */
|
|
300
|
3163
|
|
|
3164 #define SYMBOL_BLOCK_SIZE \
|
|
|
3165 ((1020 - sizeof (struct symbol_block *)) / sizeof (struct Lisp_Symbol))
|
|
|
3166
|
|
|
3167 struct symbol_block
|
|
27142
|
3168 {
|
|
53582
|
3169 /* Place `symbols' first, to preserve alignment. */
|
|
|
3170 struct Lisp_Symbol symbols[SYMBOL_BLOCK_SIZE];
|
|
27142
|
3171 struct symbol_block *next;
|
|
|
3172 };
|
|
300
|
3173
|
|
27738
|
3174 /* Current symbol block and index of first unused Lisp_Symbol
|
|
|
3175 structure in it. */
|
|
|
3176
|
|
300
|
3177 struct symbol_block *symbol_block;
|
|
|
3178 int symbol_block_index;
|
|
|
3179
|
|
27738
|
3180 /* List of free symbols. */
|
|
|
3181
|
|
300
|
3182 struct Lisp_Symbol *symbol_free_list;
|
|
|
3183
|
|
23958
|
3184 /* Total number of symbol blocks now in use. */
|
|
27142
|
3185
|
|
23958
|
3186 int n_symbol_blocks;
|
|
|
3187
|
|
27738
|
3188
|
|
|
3189 /* Initialize symbol allocation. */
|
|
|
3190
|
|
300
|
3191 void
|
|
|
3192 init_symbol ()
|
|
|
3193 {
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3194 symbol_block = NULL;
|
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3195 symbol_block_index = SYMBOL_BLOCK_SIZE;
|
|
300
|
3196 symbol_free_list = 0;
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3197 n_symbol_blocks = 0;
|
|
300
|
3198 }
|
|
|
3199
|
|
27738
|
3200
|
|
300
|
3201 DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
|
|
40107
|
3202 doc: /* Return a newly allocated uninterned symbol whose name is NAME.
|
|
39988
|
3203 Its value and function definition are void, and its property list is nil. */)
|
|
|
3204 (name)
|
|
14093
|
3205 Lisp_Object name;
|
|
300
|
3206 {
|
|
|
3207 register Lisp_Object val;
|
|
|
3208 register struct Lisp_Symbol *p;
|
|
|
3209
|
|
40656
|
3210 CHECK_STRING (name);
|
|
300
|
3211
|
|
68350
|
3212 eassert (!handling_signal);
|
|
|
3213
|
|
68430
|
3214 #ifndef SYNC_INPUT
|
|
|
3215 BLOCK_INPUT;
|
|
|
3216 #endif
|
|
|
3217
|
|
300
|
3218 if (symbol_free_list)
|
|
|
3219 {
|
|
9261
|
3220 XSETSYMBOL (val, symbol_free_list);
|
|
66889
|
3221 symbol_free_list = symbol_free_list->next;
|
|
300
|
3222 }
|
|
|
3223 else
|
|
|
3224 {
|
|
|
3225 if (symbol_block_index == SYMBOL_BLOCK_SIZE)
|
|
|
3226 {
|
|
12529
|
3227 struct symbol_block *new;
|
|
27738
|
3228 new = (struct symbol_block *) lisp_malloc (sizeof *new,
|
|
|
3229 MEM_TYPE_SYMBOL);
|
|
300
|
3230 new->next = symbol_block;
|
|
|
3231 symbol_block = new;
|
|
|
3232 symbol_block_index = 0;
|
|
23958
|
3233 n_symbol_blocks++;
|
|
300
|
3234 }
|
|
53093
|
3235 XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
|
|
|
3236 symbol_block_index++;
|
|
300
|
3237 }
|
|
49600
|
3238
|
|
68430
|
3239 #ifndef SYNC_INPUT
|
|
|
3240 UNBLOCK_INPUT;
|
|
|
3241 #endif
|
|
|
3242
|
|
300
|
3243 p = XSYMBOL (val);
|
45392
f3d7ab65641f
* alloc.c (Fmake_symbol): Set symbol xname field instead of name.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3244 p->xname = name;
|
|
300
|
3245 p->plist = Qnil;
|
|
|
3246 p->value = Qunbound;
|
|
|
3247 p->function = Qunbound;
|
|
39572
|
3248 p->next = NULL;
|
|
51658
|
3249 p->gcmarkbit = 0;
|
|
39572
|
3250 p->interned = SYMBOL_UNINTERNED;
|
|
|
3251 p->constant = 0;
|
|
|
3252 p->indirect_variable = 0;
|
|
300
|
3253 consing_since_gc += sizeof (struct Lisp_Symbol);
|
|
12748
|
3254 symbols_consed++;
|
|
300
|
3255 return val;
|
|
|
3256 }
|
|
27142
|
3257
|
|
|
3258
|
|
300
|
3259
|
|
27142
|
3260 /***********************************************************************
|
|
27738
|
3261 Marker (Misc) Allocation
|
|
27142
|
3262 ***********************************************************************/
|
|
|
3263
|
|
9437
|
3264 /* Allocation of markers and other objects that share that structure.
|
|
300
|
3265 Works like allocation of conses. */
|
|
|
3266
|
|
|
3267 #define MARKER_BLOCK_SIZE \
|
|
9437
|
3268 ((1020 - sizeof (struct marker_block *)) / sizeof (union Lisp_Misc))
|
|
300
|
3269
|
|
|
3270 struct marker_block
|
|
23958
|
3271 {
|
|
53582
|
3272 /* Place `markers' first, to preserve alignment. */
|
|
|
3273 union Lisp_Misc markers[MARKER_BLOCK_SIZE];
|
|
27142
|
3274 struct marker_block *next;
|
|
|
3275 };
|
|
300
|
3276
|
|
|
3277 struct marker_block *marker_block;
|
|
|
3278 int marker_block_index;
|
|
|
3279
|
|
9437
|
3280 union Lisp_Misc *marker_free_list;
|
|
300
|
3281
|
|
23958
|
3282 /* Total number of marker blocks now in use. */
|
|
27142
|
3283
|
|
23958
|
3284 int n_marker_blocks;
|
|
|
3285
|
|
300
|
3286 void
|
|
|
3287 init_marker ()
|
|
|
3288 {
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3289 marker_block = NULL;
|
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3290 marker_block_index = MARKER_BLOCK_SIZE;
|
|
300
|
3291 marker_free_list = 0;
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3292 n_marker_blocks = 0;
|
|
300
|
3293 }
|
|
|
3294
|
|
9437
|
3295 /* Return a newly allocated Lisp_Misc object, with no substructure. */
|
|
27142
|
3296
|
|
9437
|
3297 Lisp_Object
|
|
|
3298 allocate_misc ()
|
|
|
3299 {
|
|
|
3300 Lisp_Object val;
|
|
|
3301
|
|
68430
|
3302 /* eassert (!handling_signal); */
|
|
|
3303
|
|
|
3304 #ifndef SYNC_INPUT
|
|
|
3305 BLOCK_INPUT;
|
|
|
3306 #endif
|
|
68350
|
3307
|
|
9437
|
3308 if (marker_free_list)
|
|
|
3309 {
|
|
|
3310 XSETMISC (val, marker_free_list);
|
|
|
3311 marker_free_list = marker_free_list->u_free.chain;
|
|
|
3312 }
|
|
|
3313 else
|
|
|
3314 {
|
|
|
3315 if (marker_block_index == MARKER_BLOCK_SIZE)
|
|
|
3316 {
|
|
12529
|
3317 struct marker_block *new;
|
|
27738
|
3318 new = (struct marker_block *) lisp_malloc (sizeof *new,
|
|
|
3319 MEM_TYPE_MISC);
|
|
9437
|
3320 new->next = marker_block;
|
|
|
3321 marker_block = new;
|
|
|
3322 marker_block_index = 0;
|
|
23958
|
3323 n_marker_blocks++;
|
|
56239
|
3324 total_free_markers += MARKER_BLOCK_SIZE;
|
|
9437
|
3325 }
|
|
53093
|
3326 XSETMISC (val, &marker_block->markers[marker_block_index]);
|
|
|
3327 marker_block_index++;
|
|
9437
|
3328 }
|
|
49600
|
3329
|
|
68430
|
3330 #ifndef SYNC_INPUT
|
|
|
3331 UNBLOCK_INPUT;
|
|
|
3332 #endif
|
|
|
3333
|
|
56239
|
3334 --total_free_markers;
|
|
9437
|
3335 consing_since_gc += sizeof (union Lisp_Misc);
|
|
12748
|
3336 misc_objects_consed++;
|
|
51658
|
3337 XMARKER (val)->gcmarkbit = 0;
|
|
9437
|
3338 return val;
|
|
|
3339 }
|
|
|
3340
|
|
56239
|
3341 /* Free a Lisp_Misc object */
|
|
|
3342
|
|
|
3343 void
|
|
|
3344 free_misc (misc)
|
|
|
3345 Lisp_Object misc;
|
|
|
3346 {
|
|
|
3347 XMISC (misc)->u_marker.type = Lisp_Misc_Free;
|
|
|
3348 XMISC (misc)->u_free.chain = marker_free_list;
|
|
|
3349 marker_free_list = XMISC (misc);
|
|
|
3350
|
|
|
3351 total_free_markers++;
|
|
|
3352 }
|
|
|
3353
|
|
49055
|
3354 /* Return a Lisp_Misc_Save_Value object containing POINTER and
|
|
|
3355 INTEGER. This is used to package C values to call record_unwind_protect.
|
|
|
3356 The unwind function can get the C values back using XSAVE_VALUE. */
|
|
|
3357
|
|
|
3358 Lisp_Object
|
|
|
3359 make_save_value (pointer, integer)
|
|
|
3360 void *pointer;
|
|
|
3361 int integer;
|
|
|
3362 {
|
|
|
3363 register Lisp_Object val;
|
|
|
3364 register struct Lisp_Save_Value *p;
|
|
|
3365
|
|
|
3366 val = allocate_misc ();
|
|
|
3367 XMISCTYPE (val) = Lisp_Misc_Save_Value;
|
|
|
3368 p = XSAVE_VALUE (val);
|
|
|
3369 p->pointer = pointer;
|
|
|
3370 p->integer = integer;
|
|
56202
|
3371 p->dogc = 0;
|
|
49055
|
3372 return val;
|
|
|
3373 }
|
|
|
3374
|
|
300
|
3375 DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0,
|
|
40107
|
3376 doc: /* Return a newly allocated marker which does not point at any place. */)
|
|
39988
|
3377 ()
|
|
300
|
3378 {
|
|
|
3379 register Lisp_Object val;
|
|
|
3380 register struct Lisp_Marker *p;
|
|
638
|
3381
|
|
9437
|
3382 val = allocate_misc ();
|
|
11243
|
3383 XMISCTYPE (val) = Lisp_Misc_Marker;
|
|
300
|
3384 p = XMARKER (val);
|
|
|
3385 p->buffer = 0;
|
|
20565
|
3386 p->bytepos = 0;
|
|
|
3387 p->charpos = 0;
|
|
51668
|
3388 p->next = NULL;
|
|
13008
|
3389 p->insertion_type = 0;
|
|
300
|
3390 return val;
|
|
|
3391 }
|
|
19332
|
3392
|
|
|
3393 /* Put MARKER back on the free list after using it temporarily. */
|
|
|
3394
|
|
20375
|
3395 void
|
|
19332
|
3396 free_marker (marker)
|
|
|
3397 Lisp_Object marker;
|
|
|
3398 {
|
|
51668
|
3399 unchain_marker (XMARKER (marker));
|
|
56239
|
3400 free_misc (marker);
|
|
19332
|
3401 }
|
|
27142
|
3402
|
|
21258
|
3403
|
|
300
|
3404 /* Return a newly created vector or string with specified arguments as
|
|
2013
|
3405 elements. If all the arguments are characters that can fit
|
|
|
3406 in a string of events, make a string; otherwise, make a vector.
|
|
|
3407
|
|
|
3408 Any number of arguments, even zero arguments, are allowed. */
|
|
300
|
3409
|
|
|
3410 Lisp_Object
|
|
2013
|
3411 make_event_array (nargs, args)
|
|
300
|
3412 register int nargs;
|
|
|
3413 Lisp_Object *args;
|
|
|
3414 {
|
|
|
3415 int i;
|
|
|
3416
|
|
|
3417 for (i = 0; i < nargs; i++)
|
|
2013
|
3418 /* The things that fit in a string
|
|
3536
|
3419 are characters that are in 0...127,
|
|
|
3420 after discarding the meta bit and all the bits above it. */
|
9144
0e29f6a4fe7c
(Fmake_list, Fmake_vector, Fmake_string, make_event_array): Use type test
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
3421 if (!INTEGERP (args[i])
|
|
3536
|
3422 || (XUINT (args[i]) & ~(-CHAR_META)) >= 0200)
|
|
300
|
3423 return Fvector (nargs, args);
|
|
|
3424
|
|
|
3425 /* Since the loop exited, we know that all the things in it are
|
|
|
3426 characters, so we can make a string. */
|
|
|
3427 {
|
|
6492
|
3428 Lisp_Object result;
|
|
49600
|
3429
|
|
18104
|
3430 result = Fmake_string (make_number (nargs), make_number (0));
|
|
300
|
3431 for (i = 0; i < nargs; i++)
|
|
2013
|
3432 {
|
46418
b12a32662433
* alloc.c (make_event_array): Use SSET for storing into a string.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3433 SSET (result, i, XINT (args[i]));
|
|
2013
|
3434 /* Move the meta bit to the right place for a string char. */
|
|
|
3435 if (XINT (args[i]) & CHAR_META)
|
46418
b12a32662433
* alloc.c (make_event_array): Use SSET for storing into a string.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3436 SSET (result, i, SREF (result, i) | 0x80);
|
|
2013
|
3437 }
|
|
49600
|
3438
|
|
300
|
3439 return result;
|
|
|
3440 }
|
|
|
3441 }
|
|
27142
|
3442
|
|
|
3443
|
|
300
|
3444
|
|
27738
|
3445 /************************************************************************
|
|
66530
|
3446 Memory Full Handling
|
|
|
3447 ************************************************************************/
|
|
|
3448
|
|
|
3449
|
|
|
3450 /* Called if malloc returns zero. */
|
|
|
3451
|
|
|
3452 void
|
|
|
3453 memory_full ()
|
|
|
3454 {
|
|
|
3455 int i;
|
|
|
3456
|
|
|
3457 Vmemory_full = Qt;
|
|
|
3458
|
|
|
3459 memory_full_cons_threshold = sizeof (struct cons_block);
|
|
|
3460
|
|
|
3461 /* The first time we get here, free the spare memory. */
|
|
|
3462 for (i = 0; i < sizeof (spare_memory) / sizeof (char *); i++)
|
|
|
3463 if (spare_memory[i])
|
|
|
3464 {
|
|
|
3465 if (i == 0)
|
|
|
3466 free (spare_memory[i]);
|
|
|
3467 else if (i >= 1 && i <= 4)
|
|
|
3468 lisp_align_free (spare_memory[i]);
|
|
|
3469 else
|
|
|
3470 lisp_free (spare_memory[i]);
|
|
|
3471 spare_memory[i] = 0;
|
|
|
3472 }
|
|
|
3473
|
|
|
3474 /* Record the space now used. When it decreases substantially,
|
|
|
3475 we can refill the memory reserve. */
|
|
|
3476 #ifndef SYSTEM_MALLOC
|
|
|
3477 bytes_used_when_full = BYTES_USED;
|
|
|
3478 #endif
|
|
|
3479
|
|
|
3480 /* This used to call error, but if we've run out of memory, we could
|
|
|
3481 get infinite recursion trying to build the string. */
|
|
|
3482 while (1)
|
|
|
3483 Fsignal (Qnil, Vmemory_signal_data);
|
|
|
3484 }
|
|
|
3485
|
|
|
3486 /* If we released our reserve (due to running out of memory),
|
|
|
3487 and we have a fair amount free once again,
|
|
|
3488 try to set aside another reserve in case we run out once more.
|
|
|
3489
|
|
|
3490 This is called when a relocatable block is freed in ralloc.c,
|
|
|
3491 and also directly from this file, in case we're not using ralloc.c. */
|
|
|
3492
|
|
|
3493 void
|
|
|
3494 refill_memory_reserve ()
|
|
|
3495 {
|
|
|
3496 #ifndef SYSTEM_MALLOC
|
|
|
3497 if (spare_memory[0] == 0)
|
|
|
3498 spare_memory[0] = (char *) malloc ((size_t) SPARE_MEMORY);
|
|
|
3499 if (spare_memory[1] == 0)
|
|
|
3500 spare_memory[1] = (char *) lisp_align_malloc (sizeof (struct cons_block),
|
|
|
3501 MEM_TYPE_CONS);
|
|
|
3502 if (spare_memory[2] == 0)
|
|
|
3503 spare_memory[2] = (char *) lisp_align_malloc (sizeof (struct cons_block),
|
|
|
3504 MEM_TYPE_CONS);
|
|
|
3505 if (spare_memory[3] == 0)
|
|
|
3506 spare_memory[3] = (char *) lisp_align_malloc (sizeof (struct cons_block),
|
|
|
3507 MEM_TYPE_CONS);
|
|
|
3508 if (spare_memory[4] == 0)
|
|
|
3509 spare_memory[4] = (char *) lisp_align_malloc (sizeof (struct cons_block),
|
|
|
3510 MEM_TYPE_CONS);
|
|
|
3511 if (spare_memory[5] == 0)
|
|
|
3512 spare_memory[5] = (char *) lisp_malloc (sizeof (struct string_block),
|
|
|
3513 MEM_TYPE_STRING);
|
|
|
3514 if (spare_memory[6] == 0)
|
|
|
3515 spare_memory[6] = (char *) lisp_malloc (sizeof (struct string_block),
|
|
|
3516 MEM_TYPE_STRING);
|
|
|
3517 if (spare_memory[0] && spare_memory[1] && spare_memory[5])
|
|
|
3518 Vmemory_full = Qnil;
|
|
|
3519 #endif
|
|
|
3520 }
|
|
|
3521
|
|
|
3522 /************************************************************************
|
|
27738
|
3523 C Stack Marking
|
|
|
3524 ************************************************************************/
|
|
|
3525
|
|
32700
|
3526 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
|
|
|
3527
|
|
42403
|
3528 /* Conservative C stack marking requires a method to identify possibly
|
|
|
3529 live Lisp objects given a pointer value. We do this by keeping
|
|
|
3530 track of blocks of Lisp data that are allocated in a red-black tree
|
|
|
3531 (see also the comment of mem_node which is the type of nodes in
|
|
|
3532 that tree). Function lisp_malloc adds information for an allocated
|
|
|
3533 block to the red-black tree with calls to mem_insert, and function
|
|
|
3534 lisp_free removes it with mem_delete. Functions live_string_p etc
|
|
|
3535 call mem_find to lookup information about a given pointer in the
|
|
|
3536 tree, and use that to determine if the pointer points to a Lisp
|
|
|
3537 object or not. */
|
|
|
3538
|
|
27738
|
3539 /* Initialize this part of alloc.c. */
|
|
|
3540
|
|
|
3541 static void
|
|
|
3542 mem_init ()
|
|
|
3543 {
|
|
|
3544 mem_z.left = mem_z.right = MEM_NIL;
|
|
|
3545 mem_z.parent = NULL;
|
|
|
3546 mem_z.color = MEM_BLACK;
|
|
|
3547 mem_z.start = mem_z.end = NULL;
|
|
|
3548 mem_root = MEM_NIL;
|
|
|
3549 }
|
|
|
3550
|
|
|
3551
|
|
|
3552 /* Value is a pointer to the mem_node containing START. Value is
|
|
|
3553 MEM_NIL if there is no node in the tree containing START. */
|
|
|
3554
|
|
|
3555 static INLINE struct mem_node *
|
|
|
3556 mem_find (start)
|
|
|
3557 void *start;
|
|
|
3558 {
|
|
|
3559 struct mem_node *p;
|
|
|
3560
|
|
36435
|
3561 if (start < min_heap_address || start > max_heap_address)
|
|
|
3562 return MEM_NIL;
|
|
|
3563
|
|
27738
|
3564 /* Make the search always successful to speed up the loop below. */
|
|
|
3565 mem_z.start = start;
|
|
|
3566 mem_z.end = (char *) start + 1;
|
|
|
3567
|
|
|
3568 p = mem_root;
|
|
|
3569 while (start < p->start || start >= p->end)
|
|
|
3570 p = start < p->start ? p->left : p->right;
|
|
|
3571 return p;
|
|
|
3572 }
|
|
|
3573
|
|
|
3574
|
|
|
3575 /* Insert a new node into the tree for a block of memory with start
|
|
|
3576 address START, end address END, and type TYPE. Value is a
|
|
|
3577 pointer to the node that was inserted. */
|
|
|
3578
|
|
|
3579 static struct mem_node *
|
|
|
3580 mem_insert (start, end, type)
|
|
|
3581 void *start, *end;
|
|
|
3582 enum mem_type type;
|
|
|
3583 {
|
|
|
3584 struct mem_node *c, *parent, *x;
|
|
|
3585
|
|
36435
|
3586 if (start < min_heap_address)
|
|
|
3587 min_heap_address = start;
|
|
|
3588 if (end > max_heap_address)
|
|
|
3589 max_heap_address = end;
|
|
|
3590
|
|
27738
|
3591 /* See where in the tree a node for START belongs. In this
|
|
|
3592 particular application, it shouldn't happen that a node is already
|
|
|
3593 present. For debugging purposes, let's check that. */
|
|
|
3594 c = mem_root;
|
|
|
3595 parent = NULL;
|
|
|
3596
|
|
|
3597 #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
|
|
49600
|
3598
|
|
27738
|
3599 while (c != MEM_NIL)
|
|
|
3600 {
|
|
|
3601 if (start >= c->start && start < c->end)
|
|
|
3602 abort ();
|
|
|
3603 parent = c;
|
|
|
3604 c = start < c->start ? c->left : c->right;
|
|
|
3605 }
|
|
49600
|
3606
|
|
27738
|
3607 #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
|
|
49600
|
3608
|
|
27738
|
3609 while (c != MEM_NIL)
|
|
|
3610 {
|
|
|
3611 parent = c;
|
|
|
3612 c = start < c->start ? c->left : c->right;
|
|
|
3613 }
|
|
49600
|
3614
|
|
27738
|
3615 #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */
|
|
|
3616
|
|
|
3617 /* Create a new node. */
|
|
32692
|
3618 #ifdef GC_MALLOC_CHECK
|
|
|
3619 x = (struct mem_node *) _malloc_internal (sizeof *x);
|
|
|
3620 if (x == NULL)
|
|
|
3621 abort ();
|
|
|
3622 #else
|
|
27738
|
3623 x = (struct mem_node *) xmalloc (sizeof *x);
|
|
32692
|
3624 #endif
|
|
27738
|
3625 x->start = start;
|
|
|
3626 x->end = end;
|
|
|
3627 x->type = type;
|
|
|
3628 x->parent = parent;
|
|
|
3629 x->left = x->right = MEM_NIL;
|
|
|
3630 x->color = MEM_RED;
|
|
|
3631
|
|
|
3632 /* Insert it as child of PARENT or install it as root. */
|
|
|
3633 if (parent)
|
|
|
3634 {
|
|
|
3635 if (start < parent->start)
|
|
|
3636 parent->left = x;
|
|
|
3637 else
|
|
|
3638 parent->right = x;
|
|
|
3639 }
|
|
49600
|
3640 else
|
|
27738
|
3641 mem_root = x;
|
|
|
3642
|
|
|
3643 /* Re-establish red-black tree properties. */
|
|
|
3644 mem_insert_fixup (x);
|
|
32692
|
3645
|
|
27738
|
3646 return x;
|
|
|
3647 }
|
|
|
3648
|
|
|
3649
|
|
|
3650 /* Re-establish the red-black properties of the tree, and thereby
|
|
|
3651 balance the tree, after node X has been inserted; X is always red. */
|
|
|
3652
|
|
|
3653 static void
|
|
|
3654 mem_insert_fixup (x)
|
|
|
3655 struct mem_node *x;
|
|
|
3656 {
|
|
|
3657 while (x != mem_root && x->parent->color == MEM_RED)
|
|
|
3658 {
|
|
|
3659 /* X is red and its parent is red. This is a violation of
|
|
|
3660 red-black tree property #3. */
|
|
49600
|
3661
|
|
27738
|
3662 if (x->parent == x->parent->parent->left)
|
|
|
3663 {
|
|
|
3664 /* We're on the left side of our grandparent, and Y is our
|
|
|
3665 "uncle". */
|
|
|
3666 struct mem_node *y = x->parent->parent->right;
|
|
49600
|
3667
|
|
27738
|
3668 if (y->color == MEM_RED)
|
|
|
3669 {
|
|
|
3670 /* Uncle and parent are red but should be black because
|
|
|
3671 X is red. Change the colors accordingly and proceed
|
|
|
3672 with the grandparent. */
|
|
|
3673 x->parent->color = MEM_BLACK;
|
|
|
3674 y->color = MEM_BLACK;
|
|
|
3675 x->parent->parent->color = MEM_RED;
|
|
|
3676 x = x->parent->parent;
|
|
|
3677 }
|
|
|
3678 else
|
|
|
3679 {
|
|
|
3680 /* Parent and uncle have different colors; parent is
|
|
|
3681 red, uncle is black. */
|
|
|
3682 if (x == x->parent->right)
|
|
|
3683 {
|
|
|
3684 x = x->parent;
|
|
|
3685 mem_rotate_left (x);
|
|
|
3686 }
|
|
|
3687
|
|
|
3688 x->parent->color = MEM_BLACK;
|
|
|
3689 x->parent->parent->color = MEM_RED;
|
|
|
3690 mem_rotate_right (x->parent->parent);
|
|
|
3691 }
|
|
|
3692 }
|
|
|
3693 else
|
|
|
3694 {
|
|
|
3695 /* This is the symmetrical case of above. */
|
|
|
3696 struct mem_node *y = x->parent->parent->left;
|
|
49600
|
3697
|
|
27738
|
3698 if (y->color == MEM_RED)
|
|
|
3699 {
|
|
|
3700 x->parent->color = MEM_BLACK;
|
|
|
3701 y->color = MEM_BLACK;
|
|
|
3702 x->parent->parent->color = MEM_RED;
|
|
|
3703 x = x->parent->parent;
|
|
|
3704 }
|
|
|
3705 else
|
|
|
3706 {
|
|
|
3707 if (x == x->parent->left)
|
|
|
3708 {
|
|
|
3709 x = x->parent;
|
|
|
3710 mem_rotate_right (x);
|
|
|
3711 }
|
|
49600
|
3712
|
|
27738
|
3713 x->parent->color = MEM_BLACK;
|
|
|
3714 x->parent->parent->color = MEM_RED;
|
|
|
3715 mem_rotate_left (x->parent->parent);
|
|
|
3716 }
|
|
|
3717 }
|
|
|
3718 }
|
|
|
3719
|
|
|
3720 /* The root may have been changed to red due to the algorithm. Set
|
|
|
3721 it to black so that property #5 is satisfied. */
|
|
|
3722 mem_root->color = MEM_BLACK;
|
|
|
3723 }
|
|
|
3724
|
|
|
3725
|
|
49600
|
3726 /* (x) (y)
|
|
|
3727 / \ / \
|
|
27738
|
3728 a (y) ===> (x) c
|
|
|
3729 / \ / \
|
|
|
3730 b c a b */
|
|
|
3731
|
|
|
3732 static void
|
|
|
3733 mem_rotate_left (x)
|
|
|
3734 struct mem_node *x;
|
|
|
3735 {
|
|
|
3736 struct mem_node *y;
|
|
|
3737
|
|
|
3738 /* Turn y's left sub-tree into x's right sub-tree. */
|
|
|
3739 y = x->right;
|
|
|
3740 x->right = y->left;
|
|
|
3741 if (y->left != MEM_NIL)
|
|
|
3742 y->left->parent = x;
|
|
|
3743
|
|
|
3744 /* Y's parent was x's parent. */
|
|
|
3745 if (y != MEM_NIL)
|
|
|
3746 y->parent = x->parent;
|
|
|
3747
|
|
|
3748 /* Get the parent to point to y instead of x. */
|
|
|
3749 if (x->parent)
|
|
|
3750 {
|
|
|
3751 if (x == x->parent->left)
|
|
|
3752 x->parent->left = y;
|
|
|
3753 else
|
|
|
3754 x->parent->right = y;
|
|
|
3755 }
|
|
|
3756 else
|
|
|
3757 mem_root = y;
|
|
|
3758
|
|
|
3759 /* Put x on y's left. */
|
|
|
3760 y->left = x;
|
|
|
3761 if (x != MEM_NIL)
|
|
|
3762 x->parent = y;
|
|
|
3763 }
|
|
|
3764
|
|
|
3765
|
|
49600
|
3766 /* (x) (Y)
|
|
|
3767 / \ / \
|
|
|
3768 (y) c ===> a (x)
|
|
|
3769 / \ / \
|
|
27738
|
3770 a b b c */
|
|
|
3771
|
|
|
3772 static void
|
|
|
3773 mem_rotate_right (x)
|
|
|
3774 struct mem_node *x;
|
|
|
3775 {
|
|
|
3776 struct mem_node *y = x->left;
|
|
|
3777
|
|
|
3778 x->left = y->right;
|
|
|
3779 if (y->right != MEM_NIL)
|
|
|
3780 y->right->parent = x;
|
|
49600
|
3781
|
|
27738
|
3782 if (y != MEM_NIL)
|
|
|
3783 y->parent = x->parent;
|
|
|
3784 if (x->parent)
|
|
|
3785 {
|
|
|
3786 if (x == x->parent->right)
|
|
|
3787 x->parent->right = y;
|
|
|
3788 else
|
|
|
3789 x->parent->left = y;
|
|
|
3790 }
|
|
|
3791 else
|
|
|
3792 mem_root = y;
|
|
49600
|
3793
|
|
27738
|
3794 y->right = x;
|
|
|
3795 if (x != MEM_NIL)
|
|
|
3796 x->parent = y;
|
|
|
3797 }
|
|
|
3798
|
|
|
3799
|
|
|
3800 /* Delete node Z from the tree. If Z is null or MEM_NIL, do nothing. */
|
|
|
3801
|
|
|
3802 static void
|
|
|
3803 mem_delete (z)
|
|
|
3804 struct mem_node *z;
|
|
|
3805 {
|
|
|
3806 struct mem_node *x, *y;
|
|
|
3807
|
|
|
3808 if (!z || z == MEM_NIL)
|
|
|
3809 return;
|
|
|
3810
|
|
|
3811 if (z->left == MEM_NIL || z->right == MEM_NIL)
|
|
|
3812 y = z;
|
|
|
3813 else
|
|
|
3814 {
|
|
|
3815 y = z->right;
|
|
|
3816 while (y->left != MEM_NIL)
|
|
|
3817 y = y->left;
|
|
|
3818 }
|
|
|
3819
|
|
|
3820 if (y->left != MEM_NIL)
|
|
|
3821 x = y->left;
|
|
|
3822 else
|
|
|
3823 x = y->right;
|
|
|
3824
|
|
|
3825 x->parent = y->parent;
|
|
|
3826 if (y->parent)
|
|
|
3827 {
|
|
|
3828 if (y == y->parent->left)
|
|
|
3829 y->parent->left = x;
|
|
|
3830 else
|
|
|
3831 y->parent->right = x;
|
|
|
3832 }
|
|
|
3833 else
|
|
|
3834 mem_root = x;
|
|
|
3835
|
|
|
3836 if (y != z)
|
|
|
3837 {
|
|
|
3838 z->start = y->start;
|
|
|
3839 z->end = y->end;
|
|
|
3840 z->type = y->type;
|
|
|
3841 }
|
|
49600
|
3842
|
|
27738
|
3843 if (y->color == MEM_BLACK)
|
|
|
3844 mem_delete_fixup (x);
|
|
32692
|
3845
|
|
|
3846 #ifdef GC_MALLOC_CHECK
|
|
|
3847 _free_internal (y);
|
|
|
3848 #else
|
|
27738
|
3849 xfree (y);
|
|
32692
|
3850 #endif
|
|
27738
|
3851 }
|
|
|
3852
|
|
|
3853
|
|
|
3854 /* Re-establish the red-black properties of the tree, after a
|
|
|
3855 deletion. */
|
|
|
3856
|
|
|
3857 static void
|
|
|
3858 mem_delete_fixup (x)
|
|
|
3859 struct mem_node *x;
|
|
|
3860 {
|
|
|
3861 while (x != mem_root && x->color == MEM_BLACK)
|
|
|
3862 {
|
|
|
3863 if (x == x->parent->left)
|
|
|
3864 {
|
|
|
3865 struct mem_node *w = x->parent->right;
|
|
49600
|
3866
|
|
27738
|
3867 if (w->color == MEM_RED)
|
|
|
3868 {
|
|
|
3869 w->color = MEM_BLACK;
|
|
|
3870 x->parent->color = MEM_RED;
|
|
|
3871 mem_rotate_left (x->parent);
|
|
|
3872 w = x->parent->right;
|
|
|
3873 }
|
|
49600
|
3874
|
|
27738
|
3875 if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK)
|
|
|
3876 {
|
|
|
3877 w->color = MEM_RED;
|
|
|
3878 x = x->parent;
|
|
|
3879 }
|
|
|
3880 else
|
|
|
3881 {
|
|
|
3882 if (w->right->color == MEM_BLACK)
|
|
|
3883 {
|
|
|
3884 w->left->color = MEM_BLACK;
|
|
|
3885 w->color = MEM_RED;
|
|
|
3886 mem_rotate_right (w);
|
|
|
3887 w = x->parent->right;
|
|
|
3888 }
|
|
|
3889 w->color = x->parent->color;
|
|
|
3890 x->parent->color = MEM_BLACK;
|
|
|
3891 w->right->color = MEM_BLACK;
|
|
|
3892 mem_rotate_left (x->parent);
|
|
|
3893 x = mem_root;
|
|
|
3894 }
|
|
|
3895 }
|
|
|
3896 else
|
|
|
3897 {
|
|
|
3898 struct mem_node *w = x->parent->left;
|
|
49600
|
3899
|
|
27738
|
3900 if (w->color == MEM_RED)
|
|
|
3901 {
|
|
|
3902 w->color = MEM_BLACK;
|
|
|
3903 x->parent->color = MEM_RED;
|
|
|
3904 mem_rotate_right (x->parent);
|
|
|
3905 w = x->parent->left;
|
|
|
3906 }
|
|
49600
|
3907
|
|
27738
|
3908 if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK)
|
|
|
3909 {
|
|
|
3910 w->color = MEM_RED;
|
|
|
3911 x = x->parent;
|
|
|
3912 }
|
|
|
3913 else
|
|
|
3914 {
|
|
|
3915 if (w->left->color == MEM_BLACK)
|
|
|
3916 {
|
|
|
3917 w->right->color = MEM_BLACK;
|
|
|
3918 w->color = MEM_RED;
|
|
|
3919 mem_rotate_left (w);
|
|
|
3920 w = x->parent->left;
|
|
|
3921 }
|
|
49600
|
3922
|
|
27738
|
3923 w->color = x->parent->color;
|
|
|
3924 x->parent->color = MEM_BLACK;
|
|
|
3925 w->left->color = MEM_BLACK;
|
|
|
3926 mem_rotate_right (x->parent);
|
|
|
3927 x = mem_root;
|
|
|
3928 }
|
|
|
3929 }
|
|
|
3930 }
|
|
49600
|
3931
|
|
27738
|
3932 x->color = MEM_BLACK;
|
|
|
3933 }
|
|
|
3934
|
|
|
3935
|
|
|
3936 /* Value is non-zero if P is a pointer to a live Lisp string on
|
|
|
3937 the heap. M is a pointer to the mem_block for P. */
|
|
|
3938
|
|
|
3939 static INLINE int
|
|
|
3940 live_string_p (m, p)
|
|
|
3941 struct mem_node *m;
|
|
|
3942 void *p;
|
|
|
3943 {
|
|
|
3944 if (m->type == MEM_TYPE_STRING)
|
|
|
3945 {
|
|
|
3946 struct string_block *b = (struct string_block *) m->start;
|
|
|
3947 int offset = (char *) p - (char *) &b->strings[0];
|
|
|
3948
|
|
|
3949 /* P must point to the start of a Lisp_String structure, and it
|
|
|
3950 must not be on the free-list. */
|
|
37049
|
3951 return (offset >= 0
|
|
|
3952 && offset % sizeof b->strings[0] == 0
|
|
53582
|
3953 && offset < (STRING_BLOCK_SIZE * sizeof b->strings[0])
|
|
27738
|
3954 && ((struct Lisp_String *) p)->data != NULL);
|
|
|
3955 }
|
|
|
3956 else
|
|
|
3957 return 0;
|
|
|
3958 }
|
|
|
3959
|
|
|
3960
|
|
|
3961 /* Value is non-zero if P is a pointer to a live Lisp cons on
|
|
|
3962 the heap. M is a pointer to the mem_block for P. */
|
|
|
3963
|
|
|
3964 static INLINE int
|
|
|
3965 live_cons_p (m, p)
|
|
|
3966 struct mem_node *m;
|
|
|
3967 void *p;
|
|
|
3968 {
|
|
|
3969 if (m->type == MEM_TYPE_CONS)
|
|
|
3970 {
|
|
|
3971 struct cons_block *b = (struct cons_block *) m->start;
|
|
|
3972 int offset = (char *) p - (char *) &b->conses[0];
|
|
|
3973
|
|
|
3974 /* P must point to the start of a Lisp_Cons, not be
|
|
|
3975 one of the unused cells in the current cons block,
|
|
|
3976 and not be on the free-list. */
|
|
37049
|
3977 return (offset >= 0
|
|
53582
|
3978 && offset % sizeof b->conses[0] == 0
|
|
51938
|
3979 && offset < (CONS_BLOCK_SIZE * sizeof b->conses[0])
|
|
27738
|
3980 && (b != cons_block
|
|
|
3981 || offset / sizeof b->conses[0] < cons_block_index)
|
|
|
3982 && !EQ (((struct Lisp_Cons *) p)->car, Vdead));
|
|
|
3983 }
|
|
|
3984 else
|
|
|
3985 return 0;
|
|
|
3986 }
|
|
|
3987
|
|
|
3988
|
|
|
3989 /* Value is non-zero if P is a pointer to a live Lisp symbol on
|
|
|
3990 the heap. M is a pointer to the mem_block for P. */
|
|
|
3991
|
|
|
3992 static INLINE int
|
|
|
3993 live_symbol_p (m, p)
|
|
|
3994 struct mem_node *m;
|
|
|
3995 void *p;
|
|
|
3996 {
|
|
|
3997 if (m->type == MEM_TYPE_SYMBOL)
|
|
|
3998 {
|
|
|
3999 struct symbol_block *b = (struct symbol_block *) m->start;
|
|
|
4000 int offset = (char *) p - (char *) &b->symbols[0];
|
|
49600
|
4001
|
|
27738
|
4002 /* P must point to the start of a Lisp_Symbol, not be
|
|
|
4003 one of the unused cells in the current symbol block,
|
|
|
4004 and not be on the free-list. */
|
|
37049
|
4005 return (offset >= 0
|
|
|
4006 && offset % sizeof b->symbols[0] == 0
|
|
53582
|
4007 && offset < (SYMBOL_BLOCK_SIZE * sizeof b->symbols[0])
|
|
27738
|
4008 && (b != symbol_block
|
|
|
4009 || offset / sizeof b->symbols[0] < symbol_block_index)
|
|
|
4010 && !EQ (((struct Lisp_Symbol *) p)->function, Vdead));
|
|
|
4011 }
|
|
|
4012 else
|
|
|
4013 return 0;
|
|
|
4014 }
|
|
|
4015
|
|
|
4016
|
|
|
4017 /* Value is non-zero if P is a pointer to a live Lisp float on
|
|
|
4018 the heap. M is a pointer to the mem_block for P. */
|
|
|
4019
|
|
|
4020 static INLINE int
|
|
|
4021 live_float_p (m, p)
|
|
|
4022 struct mem_node *m;
|
|
|
4023 void *p;
|
|
|
4024 {
|
|
|
4025 if (m->type == MEM_TYPE_FLOAT)
|
|
|
4026 {
|
|
|
4027 struct float_block *b = (struct float_block *) m->start;
|
|
|
4028 int offset = (char *) p - (char *) &b->floats[0];
|
|
49600
|
4029
|
|
51723
|
4030 /* P must point to the start of a Lisp_Float and not be
|
|
|
4031 one of the unused cells in the current float block. */
|
|
37049
|
4032 return (offset >= 0
|
|
53582
|
4033 && offset % sizeof b->floats[0] == 0
|
51779
f01acdb936f9
(live_float_p): Check that p is not past the `floats' array,
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4034 && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0])
|
|
27738
|
4035 && (b != float_block
|
|
51723
|
4036 || offset / sizeof b->floats[0] < float_block_index));
|
|
27738
|
4037 }
|
|
|
4038 else
|
|
|
4039 return 0;
|
|
|
4040 }
|
|
|
4041
|
|
|
4042
|
|
|
4043 /* Value is non-zero if P is a pointer to a live Lisp Misc on
|
|
|
4044 the heap. M is a pointer to the mem_block for P. */
|
|
|
4045
|
|
|
4046 static INLINE int
|
|
|
4047 live_misc_p (m, p)
|
|
|
4048 struct mem_node *m;
|
|
|
4049 void *p;
|
|
|
4050 {
|
|
|
4051 if (m->type == MEM_TYPE_MISC)
|
|
|
4052 {
|
|
|
4053 struct marker_block *b = (struct marker_block *) m->start;
|
|
|
4054 int offset = (char *) p - (char *) &b->markers[0];
|
|
49600
|
4055
|
|
27738
|
4056 /* P must point to the start of a Lisp_Misc, not be
|
|
|
4057 one of the unused cells in the current misc block,
|
|
|
4058 and not be on the free-list. */
|
|
37049
|
4059 return (offset >= 0
|
|
|
4060 && offset % sizeof b->markers[0] == 0
|
|
53582
|
4061 && offset < (MARKER_BLOCK_SIZE * sizeof b->markers[0])
|
|
27738
|
4062 && (b != marker_block
|
|
|
4063 || offset / sizeof b->markers[0] < marker_block_index)
|
|
|
4064 && ((union Lisp_Misc *) p)->u_marker.type != Lisp_Misc_Free);
|
|
|
4065 }
|
|
|
4066 else
|
|
|
4067 return 0;
|
|
|
4068 }
|
|
|
4069
|
|
|
4070
|
|
|
4071 /* Value is non-zero if P is a pointer to a live vector-like object.
|
|
|
4072 M is a pointer to the mem_block for P. */
|
|
|
4073
|
|
|
4074 static INLINE int
|
|
|
4075 live_vector_p (m, p)
|
|
|
4076 struct mem_node *m;
|
|
|
4077 void *p;
|
|
|
4078 {
|
|
36435
|
4079 return (p == m->start
|
|
|
4080 && m->type >= MEM_TYPE_VECTOR
|
|
|
4081 && m->type <= MEM_TYPE_WINDOW);
|
|
27738
|
4082 }
|
|
|
4083
|
|
|
4084
|
|
51658
|
4085 /* Value is non-zero if P is a pointer to a live buffer. M is a
|
|
27738
|
4086 pointer to the mem_block for P. */
|
|
|
4087
|
|
|
4088 static INLINE int
|
|
|
4089 live_buffer_p (m, p)
|
|
|
4090 struct mem_node *m;
|
|
|
4091 void *p;
|
|
|
4092 {
|
|
|
4093 /* P must point to the start of the block, and the buffer
|
|
|
4094 must not have been killed. */
|
|
|
4095 return (m->type == MEM_TYPE_BUFFER
|
|
|
4096 && p == m->start
|
|
|
4097 && !NILP (((struct buffer *) p)->name));
|
|
|
4098 }
|
|
|
4099
|
|
32700
|
4100 #endif /* GC_MARK_STACK || defined GC_MALLOC_CHECK */
|
|
|
4101
|
|
|
4102 #if GC_MARK_STACK
|
|
|
4103
|
|
27738
|
4104 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
4105
|
|
|
4106 /* Array of objects that are kept alive because the C stack contains
|
|
|
4107 a pattern that looks like a reference to them . */
|
|
|
4108
|
|
|
4109 #define MAX_ZOMBIES 10
|
|
|
4110 static Lisp_Object zombies[MAX_ZOMBIES];
|
|
|
4111
|
|
|
4112 /* Number of zombie objects. */
|
|
|
4113
|
|
|
4114 static int nzombies;
|
|
|
4115
|
|
|
4116 /* Number of garbage collections. */
|
|
|
4117
|
|
|
4118 static int ngcs;
|
|
|
4119
|
|
|
4120 /* Average percentage of zombies per collection. */
|
|
|
4121
|
|
|
4122 static double avg_zombies;
|
|
|
4123
|
|
|
4124 /* Max. number of live and zombie objects. */
|
|
|
4125
|
|
|
4126 static int max_live, max_zombies;
|
|
|
4127
|
|
|
4128 /* Average number of live objects per GC. */
|
|
|
4129
|
|
|
4130 static double avg_live;
|
|
|
4131
|
|
|
4132 DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "",
|
|
39988
|
4133 doc: /* Show information about live and zombie objects. */)
|
|
|
4134 ()
|
|
27738
|
4135 {
|
|
49357
|
4136 Lisp_Object args[8], zombie_list = Qnil;
|
|
|
4137 int i;
|
|
|
4138 for (i = 0; i < nzombies; i++)
|
|
|
4139 zombie_list = Fcons (zombies[i], zombie_list);
|
|
|
4140 args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S");
|
|
27738
|
4141 args[1] = make_number (ngcs);
|
|
|
4142 args[2] = make_float (avg_live);
|
|
|
4143 args[3] = make_float (avg_zombies);
|
|
|
4144 args[4] = make_float (avg_zombies / avg_live / 100);
|
|
|
4145 args[5] = make_number (max_live);
|
|
|
4146 args[6] = make_number (max_zombies);
|
|
49357
|
4147 args[7] = zombie_list;
|
|
|
4148 return Fmessage (8, args);
|
|
27738
|
4149 }
|
|
|
4150
|
|
|
4151 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
|
|
|
4152
|
|
|
4153
|
|
28365
|
4154 /* Mark OBJ if we can prove it's a Lisp_Object. */
|
|
|
4155
|
|
|
4156 static INLINE void
|
|
|
4157 mark_maybe_object (obj)
|
|
|
4158 Lisp_Object obj;
|
|
|
4159 {
|
|
|
4160 void *po = (void *) XPNTR (obj);
|
|
|
4161 struct mem_node *m = mem_find (po);
|
|
49600
|
4162
|
|
28365
|
4163 if (m != MEM_NIL)
|
|
|
4164 {
|
|
|
4165 int mark_p = 0;
|
|
|
4166
|
|
|
4167 switch (XGCTYPE (obj))
|
|
|
4168 {
|
|
|
4169 case Lisp_String:
|
|
|
4170 mark_p = (live_string_p (m, po)
|
|
|
4171 && !STRING_MARKED_P ((struct Lisp_String *) po));
|
|
|
4172 break;
|
|
|
4173
|
|
|
4174 case Lisp_Cons:
|
|
51938
|
4175 mark_p = (live_cons_p (m, po) && !CONS_MARKED_P (XCONS (obj)));
|
|
28365
|
4176 break;
|
|
|
4177
|
|
|
4178 case Lisp_Symbol:
|
|
51658
|
4179 mark_p = (live_symbol_p (m, po) && !XSYMBOL (obj)->gcmarkbit);
|
|
28365
|
4180 break;
|
|
|
4181
|
|
|
4182 case Lisp_Float:
|
|
51723
|
4183 mark_p = (live_float_p (m, po) && !FLOAT_MARKED_P (XFLOAT (obj)));
|
|
28365
|
4184 break;
|
|
|
4185
|
|
|
4186 case Lisp_Vectorlike:
|
|
|
4187 /* Note: can't check GC_BUFFERP before we know it's a
|
|
|
4188 buffer because checking that dereferences the pointer
|
|
|
4189 PO which might point anywhere. */
|
|
|
4190 if (live_vector_p (m, po))
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4191 mark_p = !GC_SUBRP (obj) && !VECTOR_MARKED_P (XVECTOR (obj));
|
|
28365
|
4192 else if (live_buffer_p (m, po))
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4193 mark_p = GC_BUFFERP (obj) && !VECTOR_MARKED_P (XBUFFER (obj));
|
|
28365
|
4194 break;
|
|
|
4195
|
|
|
4196 case Lisp_Misc:
|
|
51658
|
4197 mark_p = (live_misc_p (m, po) && !XMARKER (obj)->gcmarkbit);
|
|
28365
|
4198 break;
|
|
31829
|
4199
|
|
|
4200 case Lisp_Int:
|
|
31897
|
4201 case Lisp_Type_Limit:
|
|
31829
|
4202 break;
|
|
28365
|
4203 }
|
|
|
4204
|
|
|
4205 if (mark_p)
|
|
|
4206 {
|
|
|
4207 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
4208 if (nzombies < MAX_ZOMBIES)
|
|
49357
|
4209 zombies[nzombies] = obj;
|
|
28365
|
4210 ++nzombies;
|
|
|
4211 #endif
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4212 mark_object (obj);
|
|
28365
|
4213 }
|
|
|
4214 }
|
|
|
4215 }
|
|
36435
|
4216
|
|
|
4217
|
|
|
4218 /* If P points to Lisp data, mark that as live if it isn't already
|
|
|
4219 marked. */
|
|
|
4220
|
|
|
4221 static INLINE void
|
|
|
4222 mark_maybe_pointer (p)
|
|
|
4223 void *p;
|
|
|
4224 {
|
|
|
4225 struct mem_node *m;
|
|
|
4226
|
|
|
4227 /* Quickly rule out some values which can't point to Lisp data. We
|
|
|
4228 assume that Lisp data is aligned on even addresses. */
|
|
|
4229 if ((EMACS_INT) p & 1)
|
|
|
4230 return;
|
|
49600
|
4231
|
|
36435
|
4232 m = mem_find (p);
|
|
|
4233 if (m != MEM_NIL)
|
|
|
4234 {
|
|
|
4235 Lisp_Object obj = Qnil;
|
|
49600
|
4236
|
|
36435
|
4237 switch (m->type)
|
|
|
4238 {
|
|
|
4239 case MEM_TYPE_NON_LISP:
|
|
36487
|
4240 /* Nothing to do; not a pointer to Lisp memory. */
|
|
36435
|
4241 break;
|
|
49600
|
4242
|
|
36435
|
4243 case MEM_TYPE_BUFFER:
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4244 if (live_buffer_p (m, p) && !VECTOR_MARKED_P((struct buffer *)p))
|
|
36435
|
4245 XSETVECTOR (obj, p);
|
|
|
4246 break;
|
|
49600
|
4247
|
|
36435
|
4248 case MEM_TYPE_CONS:
|
|
51938
|
4249 if (live_cons_p (m, p) && !CONS_MARKED_P ((struct Lisp_Cons *) p))
|
|
36435
|
4250 XSETCONS (obj, p);
|
|
|
4251 break;
|
|
49600
|
4252
|
|
36435
|
4253 case MEM_TYPE_STRING:
|
|
|
4254 if (live_string_p (m, p)
|
|
|
4255 && !STRING_MARKED_P ((struct Lisp_String *) p))
|
|
|
4256 XSETSTRING (obj, p);
|
|
|
4257 break;
|
|
|
4258
|
|
|
4259 case MEM_TYPE_MISC:
|
|
51658
|
4260 if (live_misc_p (m, p) && !((struct Lisp_Free *) p)->gcmarkbit)
|
|
|
4261 XSETMISC (obj, p);
|
|
36435
|
4262 break;
|
|
49600
|
4263
|
|
36435
|
4264 case MEM_TYPE_SYMBOL:
|
|
51658
|
4265 if (live_symbol_p (m, p) && !((struct Lisp_Symbol *) p)->gcmarkbit)
|
|
36435
|
4266 XSETSYMBOL (obj, p);
|
|
|
4267 break;
|
|
49600
|
4268
|
|
36435
|
4269 case MEM_TYPE_FLOAT:
|
|
51723
|
4270 if (live_float_p (m, p) && !FLOAT_MARKED_P (p))
|
|
36435
|
4271 XSETFLOAT (obj, p);
|
|
|
4272 break;
|
|
49600
|
4273
|
|
36435
|
4274 case MEM_TYPE_VECTOR:
|
|
|
4275 case MEM_TYPE_PROCESS:
|
|
|
4276 case MEM_TYPE_HASH_TABLE:
|
|
|
4277 case MEM_TYPE_FRAME:
|
|
|
4278 case MEM_TYPE_WINDOW:
|
|
|
4279 if (live_vector_p (m, p))
|
|
|
4280 {
|
|
|
4281 Lisp_Object tem;
|
|
|
4282 XSETVECTOR (tem, p);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4283 if (!GC_SUBRP (tem) && !VECTOR_MARKED_P (XVECTOR (tem)))
|
|
36435
|
4284 obj = tem;
|
|
|
4285 }
|
|
|
4286 break;
|
|
|
4287
|
|
|
4288 default:
|
|
|
4289 abort ();
|
|
|
4290 }
|
|
|
4291
|
|
|
4292 if (!GC_NILP (obj))
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4293 mark_object (obj);
|
|
36435
|
4294 }
|
|
|
4295 }
|
|
|
4296
|
|
|
4297
|
|
|
4298 /* Mark Lisp objects referenced from the address range START..END. */
|
|
27738
|
4299
|
|
49600
|
4300 static void
|
|
27738
|
4301 mark_memory (start, end)
|
|
|
4302 void *start, *end;
|
|
|
4303 {
|
|
|
4304 Lisp_Object *p;
|
|
36435
|
4305 void **pp;
|
|
27738
|
4306
|
|
|
4307 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
4308 nzombies = 0;
|
|
|
4309 #endif
|
|
|
4310
|
|
|
4311 /* Make START the pointer to the start of the memory region,
|
|
|
4312 if it isn't already. */
|
|
|
4313 if (end < start)
|
|
|
4314 {
|
|
|
4315 void *tem = start;
|
|
|
4316 start = end;
|
|
|
4317 end = tem;
|
|
|
4318 }
|
|
36435
|
4319
|
|
|
4320 /* Mark Lisp_Objects. */
|
|
27738
|
4321 for (p = (Lisp_Object *) start; (void *) p < end; ++p)
|
|
28365
|
4322 mark_maybe_object (*p);
|
|
36435
|
4323
|
|
|
4324 /* Mark Lisp data pointed to. This is necessary because, in some
|
|
|
4325 situations, the C compiler optimizes Lisp objects away, so that
|
|
|
4326 only a pointer to them remains. Example:
|
|
|
4327
|
|
|
4328 DEFUN ("testme", Ftestme, Stestme, 0, 0, 0, "")
|
|
39988
|
4329 ()
|
|
36435
|
4330 {
|
|
|
4331 Lisp_Object obj = build_string ("test");
|
|
|
4332 struct Lisp_String *s = XSTRING (obj);
|
|
|
4333 Fgarbage_collect ();
|
|
|
4334 fprintf (stderr, "test `%s'\n", s->data);
|
|
|
4335 return Qnil;
|
|
|
4336 }
|
|
|
4337
|
|
|
4338 Here, `obj' isn't really used, and the compiler optimizes it
|
|
|
4339 away. The only reference to the life string is through the
|
|
|
4340 pointer `s'. */
|
|
49600
|
4341
|
|
36435
|
4342 for (pp = (void **) start; (void *) pp < end; ++pp)
|
|
|
4343 mark_maybe_pointer (*pp);
|
|
28365
|
4344 }
|
|
|
4345
|
|
48316
|
4346 /* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in
|
|
|
4347 the GCC system configuration. In gcc 3.2, the only systems for
|
|
|
4348 which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included
|
|
|
4349 by others?) and ns32k-pc532-min. */
|
|
28365
|
4350
|
|
|
4351 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
|
|
|
4352
|
|
|
4353 static int setjmp_tested_p, longjmps_done;
|
|
|
4354
|
|
|
4355 #define SETJMP_WILL_LIKELY_WORK "\
|
|
|
4356 \n\
|
|
|
4357 Emacs garbage collector has been changed to use conservative stack\n\
|
|
|
4358 marking. Emacs has determined that the method it uses to do the\n\
|
|
|
4359 marking will likely work on your system, but this isn't sure.\n\
|
|
|
4360 \n\
|
|
|
4361 If you are a system-programmer, or can get the help of a local wizard\n\
|
|
|
4362 who is, please take a look at the function mark_stack in alloc.c, and\n\
|
|
|
4363 verify that the methods used are appropriate for your system.\n\
|
|
|
4364 \n\
|
|
43200
|
4365 Please mail the result to <emacs-devel@gnu.org>.\n\
|
|
28365
|
4366 "
|
|
|
4367
|
|
|
4368 #define SETJMP_WILL_NOT_WORK "\
|
|
|
4369 \n\
|
|
|
4370 Emacs garbage collector has been changed to use conservative stack\n\
|
|
|
4371 marking. Emacs has determined that the default method it uses to do the\n\
|
|
|
4372 marking will not work on your system. We will need a system-dependent\n\
|
|
|
4373 solution for your system.\n\
|
|
|
4374 \n\
|
|
|
4375 Please take a look at the function mark_stack in alloc.c, and\n\
|
|
|
4376 try to find a way to make it work on your system.\n\
|
|
48316
|
4377 \n\
|
|
|
4378 Note that you may get false negatives, depending on the compiler.\n\
|
|
|
4379 In particular, you need to use -O with GCC for this test.\n\
|
|
|
4380 \n\
|
|
43200
|
4381 Please mail the result to <emacs-devel@gnu.org>.\n\
|
|
28365
|
4382 "
|
|
|
4383
|
|
|
4384
|
|
|
4385 /* Perform a quick check if it looks like setjmp saves registers in a
|
|
|
4386 jmp_buf. Print a message to stderr saying so. When this test
|
|
|
4387 succeeds, this is _not_ a proof that setjmp is sufficient for
|
|
|
4388 conservative stack marking. Only the sources or a disassembly
|
|
|
4389 can prove that. */
|
|
|
4390
|
|
|
4391 static void
|
|
|
4392 test_setjmp ()
|
|
|
4393 {
|
|
|
4394 char buf[10];
|
|
|
4395 register int x;
|
|
|
4396 jmp_buf jbuf;
|
|
|
4397 int result = 0;
|
|
|
4398
|
|
|
4399 /* Arrange for X to be put in a register. */
|
|
|
4400 sprintf (buf, "1");
|
|
|
4401 x = strlen (buf);
|
|
|
4402 x = 2 * x - 1;
|
|
|
4403
|
|
|
4404 setjmp (jbuf);
|
|
|
4405 if (longjmps_done == 1)
|
|
27738
|
4406 {
|
|
28365
|
4407 /* Came here after the longjmp at the end of the function.
|
|
|
4408
|
|
|
4409 If x == 1, the longjmp has restored the register to its
|
|
|
4410 value before the setjmp, and we can hope that setjmp
|
|
|
4411 saves all such registers in the jmp_buf, although that
|
|
|
4412 isn't sure.
|
|
|
4413
|
|
|
4414 For other values of X, either something really strange is
|
|
|
4415 taking place, or the setjmp just didn't save the register. */
|
|
|
4416
|
|
|
4417 if (x == 1)
|
|
|
4418 fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
|
|
|
4419 else
|
|
27738
|
4420 {
|
|
28365
|
4421 fprintf (stderr, SETJMP_WILL_NOT_WORK);
|
|
|
4422 exit (1);
|
|
27738
|
4423 }
|
|
|
4424 }
|
|
28365
|
4425
|
|
|
4426 ++longjmps_done;
|
|
|
4427 x = 2;
|
|
|
4428 if (longjmps_done == 1)
|
|
|
4429 longjmp (jbuf, 1);
|
|
27738
|
4430 }
|
|
|
4431
|
|
28365
|
4432 #endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
|
|
|
4433
|
|
27738
|
4434
|
|
|
4435 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
|
|
|
4436
|
|
|
4437 /* Abort if anything GCPRO'd doesn't survive the GC. */
|
|
|
4438
|
|
|
4439 static void
|
|
|
4440 check_gcpros ()
|
|
|
4441 {
|
|
|
4442 struct gcpro *p;
|
|
|
4443 int i;
|
|
|
4444
|
|
|
4445 for (p = gcprolist; p; p = p->next)
|
|
|
4446 for (i = 0; i < p->nvars; ++i)
|
|
|
4447 if (!survives_gc_p (p->var[i]))
|
|
50626
|
4448 /* FIXME: It's not necessarily a bug. It might just be that the
|
|
|
4449 GCPRO is unnecessary or should release the object sooner. */
|
|
27738
|
4450 abort ();
|
|
|
4451 }
|
|
|
4452
|
|
|
4453 #elif GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
4454
|
|
|
4455 static void
|
|
|
4456 dump_zombies ()
|
|
|
4457 {
|
|
|
4458 int i;
|
|
|
4459
|
|
|
4460 fprintf (stderr, "\nZombies kept alive = %d:\n", nzombies);
|
|
|
4461 for (i = 0; i < min (MAX_ZOMBIES, nzombies); ++i)
|
|
|
4462 {
|
|
|
4463 fprintf (stderr, " %d = ", i);
|
|
|
4464 debug_print (zombies[i]);
|
|
|
4465 }
|
|
|
4466 }
|
|
|
4467
|
|
|
4468 #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
|
|
|
4469
|
|
|
4470
|
|
28365
|
4471 /* Mark live Lisp objects on the C stack.
|
|
|
4472
|
|
|
4473 There are several system-dependent problems to consider when
|
|
|
4474 porting this to new architectures:
|
|
|
4475
|
|
|
4476 Processor Registers
|
|
|
4477
|
|
|
4478 We have to mark Lisp objects in CPU registers that can hold local
|
|
|
4479 variables or are used to pass parameters.
|
|
|
4480
|
|
|
4481 If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
|
|
|
4482 something that either saves relevant registers on the stack, or
|
|
|
4483 calls mark_maybe_object passing it each register's contents.
|
|
|
4484
|
|
|
4485 If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
|
|
|
4486 implementation assumes that calling setjmp saves registers we need
|
|
|
4487 to see in a jmp_buf which itself lies on the stack. This doesn't
|
|
|
4488 have to be true! It must be verified for each system, possibly
|
|
|
4489 by taking a look at the source code of setjmp.
|
|
|
4490
|
|
|
4491 Stack Layout
|
|
|
4492
|
|
|
4493 Architectures differ in the way their processor stack is organized.
|
|
|
4494 For example, the stack might look like this
|
|
|
4495
|
|
|
4496 +----------------+
|
|
|
4497 | Lisp_Object | size = 4
|
|
|
4498 +----------------+
|
|
|
4499 | something else | size = 2
|
|
|
4500 +----------------+
|
|
|
4501 | Lisp_Object | size = 4
|
|
|
4502 +----------------+
|
|
|
4503 | ... |
|
|
|
4504
|
|
|
4505 In such a case, not every Lisp_Object will be aligned equally. To
|
|
|
4506 find all Lisp_Object on the stack it won't be sufficient to walk
|
|
|
4507 the stack in steps of 4 bytes. Instead, two passes will be
|
|
|
4508 necessary, one starting at the start of the stack, and a second
|
|
|
4509 pass starting at the start of the stack + 2. Likewise, if the
|
|
|
4510 minimal alignment of Lisp_Objects on the stack is 1, four passes
|
|
|
4511 would be necessary, each one starting with one byte more offset
|
|
|
4512 from the stack start.
|
|
|
4513
|
|
|
4514 The current code assumes by default that Lisp_Objects are aligned
|
|
|
4515 equally on the stack. */
|
|
27738
|
4516
|
|
|
4517 static void
|
|
|
4518 mark_stack ()
|
|
|
4519 {
|
|
43160
|
4520 int i;
|
|
27738
|
4521 jmp_buf j;
|
|
31829
|
4522 volatile int stack_grows_down_p = (char *) &j > (char *) stack_base;
|
|
27738
|
4523 void *end;
|
|
|
4524
|
|
|
4525 /* This trick flushes the register windows so that all the state of
|
|
|
4526 the process is contained in the stack. */
|
|
51723
|
4527 /* Fixme: Code in the Boehm GC suggests flushing (with `flushrs') is
|
|
49414
|
4528 needed on ia64 too. See mach_dep.c, where it also says inline
|
|
|
4529 assembler doesn't work with relevant proprietary compilers. */
|
|
27738
|
4530 #ifdef sparc
|
|
|
4531 asm ("ta 3");
|
|
|
4532 #endif
|
|
49600
|
4533
|
|
27738
|
4534 /* Save registers that we need to see on the stack. We need to see
|
|
|
4535 registers used to hold register variables and registers used to
|
|
|
4536 pass parameters. */
|
|
|
4537 #ifdef GC_SAVE_REGISTERS_ON_STACK
|
|
|
4538 GC_SAVE_REGISTERS_ON_STACK (end);
|
|
28365
|
4539 #else /* not GC_SAVE_REGISTERS_ON_STACK */
|
|
49600
|
4540
|
|
28365
|
4541 #ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
|
|
|
4542 setjmp will definitely work, test it
|
|
|
4543 and print a message with the result
|
|
|
4544 of the test. */
|
|
|
4545 if (!setjmp_tested_p)
|
|
|
4546 {
|
|
|
4547 setjmp_tested_p = 1;
|
|
|
4548 test_setjmp ();
|
|
|
4549 }
|
|
|
4550 #endif /* GC_SETJMP_WORKS */
|
|
49600
|
4551
|
|
27738
|
4552 setjmp (j);
|
|
|
4553 end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
|
|
28365
|
4554 #endif /* not GC_SAVE_REGISTERS_ON_STACK */
|
|
27738
|
4555
|
|
|
4556 /* This assumes that the stack is a contiguous region in memory. If
|
|
28365
|
4557 that's not the case, something has to be done here to iterate
|
|
|
4558 over the stack segments. */
|
|
43160
|
4559 #ifndef GC_LISP_OBJECT_ALIGNMENT
|
|
49414
|
4560 #ifdef __GNUC__
|
|
|
4561 #define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object)
|
|
|
4562 #else
|
|
43160
|
4563 #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object)
|
|
28365
|
4564 #endif
|
|
49414
|
4565 #endif
|
|
43161
|
4566 for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT)
|
|
43160
|
4567 mark_memory ((char *) stack_base + i, end);
|
|
58593
|
4568 /* Allow for marking a secondary stack, like the register stack on the
|
|
|
4569 ia64. */
|
|
|
4570 #ifdef GC_MARK_SECONDARY_STACK
|
|
|
4571 GC_MARK_SECONDARY_STACK ();
|
|
|
4572 #endif
|
|
27738
|
4573
|
|
|
4574 #if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
|
|
|
4575 check_gcpros ();
|
|
|
4576 #endif
|
|
|
4577 }
|
|
|
4578
|
|
|
4579 #endif /* GC_MARK_STACK != 0 */
|
|
|
4580
|
|
|
4581
|
|
66777
|
4582
|
|
|
4583 /* Return 1 if OBJ is a valid lisp object.
|
|
|
4584 Return 0 if OBJ is NOT a valid lisp object.
|
|
|
4585 Return -1 if we cannot validate OBJ.
|
|
67494
|
4586 This function can be quite slow,
|
|
|
4587 so it should only be used in code for manual debugging. */
|
|
66777
|
4588
|
|
|
4589 int
|
|
|
4590 valid_lisp_object_p (obj)
|
|
|
4591 Lisp_Object obj;
|
|
|
4592 {
|
|
67216
|
4593 void *p;
|
|
66777
|
4594 #if !GC_MARK_STACK
|
|
67216
|
4595 int fd;
|
|
66777
|
4596 #else
|
|
|
4597 struct mem_node *m;
|
|
67216
|
4598 #endif
|
|
66777
|
4599
|
|
|
4600 if (INTEGERP (obj))
|
|
|
4601 return 1;
|
|
|
4602
|
|
|
4603 p = (void *) XPNTR (obj);
|
|
|
4604 if (PURE_POINTER_P (p))
|
|
|
4605 return 1;
|
|
|
4606
|
|
67216
|
4607 #if !GC_MARK_STACK
|
|
|
4608 /* We need to determine whether it is safe to access memory at
|
|
|
4609 address P. Obviously, we cannot just access it (we would SEGV
|
|
|
4610 trying), so we trick the o/s to tell us whether p is a valid
|
|
|
4611 pointer. Unfortunately, we cannot use NULL_DEVICE here, as
|
|
|
4612 emacs_write may not validate p in that case. */
|
|
67494
|
4613 if ((fd = emacs_open ("__Valid__Lisp__Object__", O_CREAT | O_WRONLY | O_TRUNC, 0666)) >= 0)
|
|
67216
|
4614 {
|
|
67494
|
4615 int valid = (emacs_write (fd, (char *)p, 16) == 16);
|
|
|
4616 emacs_close (fd);
|
|
|
4617 unlink ("__Valid__Lisp__Object__");
|
|
67216
|
4618 return valid;
|
|
|
4619 }
|
|
|
4620
|
|
|
4621 return -1;
|
|
|
4622 #else
|
|
|
4623
|
|
66777
|
4624 m = mem_find (p);
|
|
|
4625
|
|
|
4626 if (m == MEM_NIL)
|
|
|
4627 return 0;
|
|
|
4628
|
|
|
4629 switch (m->type)
|
|
|
4630 {
|
|
|
4631 case MEM_TYPE_NON_LISP:
|
|
|
4632 return 0;
|
|
|
4633
|
|
|
4634 case MEM_TYPE_BUFFER:
|
|
|
4635 return live_buffer_p (m, p);
|
|
|
4636
|
|
|
4637 case MEM_TYPE_CONS:
|
|
|
4638 return live_cons_p (m, p);
|
|
|
4639
|
|
|
4640 case MEM_TYPE_STRING:
|
|
|
4641 return live_string_p (m, p);
|
|
|
4642
|
|
|
4643 case MEM_TYPE_MISC:
|
|
|
4644 return live_misc_p (m, p);
|
|
|
4645
|
|
|
4646 case MEM_TYPE_SYMBOL:
|
|
|
4647 return live_symbol_p (m, p);
|
|
|
4648
|
|
|
4649 case MEM_TYPE_FLOAT:
|
|
|
4650 return live_float_p (m, p);
|
|
|
4651
|
|
|
4652 case MEM_TYPE_VECTOR:
|
|
|
4653 case MEM_TYPE_PROCESS:
|
|
|
4654 case MEM_TYPE_HASH_TABLE:
|
|
|
4655 case MEM_TYPE_FRAME:
|
|
|
4656 case MEM_TYPE_WINDOW:
|
|
|
4657 return live_vector_p (m, p);
|
|
|
4658
|
|
|
4659 default:
|
|
|
4660 break;
|
|
|
4661 }
|
|
|
4662
|
|
|
4663 return 0;
|
|
|
4664 #endif
|
|
|
4665 }
|
|
|
4666
|
|
|
4667
|
|
|
4668
|
|
27738
|
4669
|
|
27142
|
4670 /***********************************************************************
|
|
|
4671 Pure Storage Management
|
|
|
4672 ***********************************************************************/
|
|
|
4673
|
|
32594
|
4674 /* Allocate room for SIZE bytes from pure Lisp storage and return a
|
|
|
4675 pointer to it. TYPE is the Lisp type for which the memory is
|
|
|
4676 allocated. TYPE < 0 means it's not used for a Lisp object.
|
|
|
4677
|
|
|
4678 If store_pure_type_info is set and TYPE is >= 0, the type of
|
|
|
4679 the allocated object is recorded in pure_types. */
|
|
|
4680
|
|
|
4681 static POINTER_TYPE *
|
|
|
4682 pure_alloc (size, type)
|
|
|
4683 size_t size;
|
|
|
4684 int type;
|
|
|
4685 {
|
|
|
4686 POINTER_TYPE *result;
|
|
53650
|
4687 #ifdef USE_LSB_TAG
|
|
|
4688 size_t alignment = (1 << GCTYPEBITS);
|
|
|
4689 #else
|
|
49159
|
4690 size_t alignment = sizeof (EMACS_INT);
|
|
32594
|
4691
|
|
|
4692 /* Give Lisp_Floats an extra alignment. */
|
|
|
4693 if (type == Lisp_Float)
|
|
|
4694 {
|
|
|
4695 #if defined __GNUC__ && __GNUC__ >= 2
|
|
|
4696 alignment = __alignof (struct Lisp_Float);
|
|
|
4697 #else
|
|
|
4698 alignment = sizeof (struct Lisp_Float);
|
|
|
4699 #endif
|
|
|
4700 }
|
|
53650
|
4701 #endif
|
|
49159
|
4702
|
|
|
4703 again:
|
|
51723
|
4704 result = ALIGN (purebeg + pure_bytes_used, alignment);
|
|
49159
|
4705 pure_bytes_used = ((char *)result - (char *)purebeg) + size;
|
|
|
4706
|
|
|
4707 if (pure_bytes_used <= pure_size)
|
|
|
4708 return result;
|
|
|
4709
|
|
|
4710 /* Don't allocate a large amount here,
|
|
|
4711 because it might get mmap'd and then its address
|
|
|
4712 might not be usable. */
|
|
|
4713 purebeg = (char *) xmalloc (10000);
|
|
|
4714 pure_size = 10000;
|
|
|
4715 pure_bytes_used_before_overflow += pure_bytes_used - size;
|
|
|
4716 pure_bytes_used = 0;
|
|
|
4717 goto again;
|
|
32594
|
4718 }
|
|
|
4719
|
|
|
4720
|
|
44149
|
4721 /* Print a warning if PURESIZE is too small. */
|
|
39572
|
4722
|
|
|
4723 void
|
|
|
4724 check_pure_size ()
|
|
|
4725 {
|
|
|
4726 if (pure_bytes_used_before_overflow)
|
|
68398
|
4727 message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
|
|
44100
|
4728 (int) (pure_bytes_used + pure_bytes_used_before_overflow));
|
|
39572
|
4729 }
|
|
|
4730
|
|
|
4731
|
|
27142
|
4732 /* Return a string allocated in pure space. DATA is a buffer holding
|
|
|
4733 NCHARS characters, and NBYTES bytes of string data. MULTIBYTE
|
|
|
4734 non-zero means make the result string multibyte.
|
|
|
4735
|
|
|
4736 Must get an error if pure storage is full, since if it cannot hold
|
|
|
4737 a large string it may be able to hold conses that point to that
|
|
|
4738 string; then the string is not protected from gc. */
|
|
300
|
4739
|
|
|
4740 Lisp_Object
|
|
27142
|
4741 make_pure_string (data, nchars, nbytes, multibyte)
|
|
300
|
4742 char *data;
|
|
27142
|
4743 int nchars, nbytes;
|
|
21258
|
4744 int multibyte;
|
|
300
|
4745 {
|
|
27142
|
4746 Lisp_Object string;
|
|
|
4747 struct Lisp_String *s;
|
|
32594
|
4748
|
|
|
4749 s = (struct Lisp_String *) pure_alloc (sizeof *s, Lisp_String);
|
|
|
4750 s->data = (unsigned char *) pure_alloc (nbytes + 1, -1);
|
|
27142
|
4751 s->size = nchars;
|
|
|
4752 s->size_byte = multibyte ? nbytes : -1;
|
|
|
4753 bcopy (data, s->data, nbytes);
|
|
|
4754 s->data[nbytes] = '\0';
|
|
|
4755 s->intervals = NULL_INTERVAL;
|
|
|
4756 XSETSTRING (string, s);
|
|
|
4757 return string;
|
|
300
|
4758 }
|
|
|
4759
|
|
27142
|
4760
|
|
27738
|
4761 /* Return a cons allocated from pure space. Give it pure copies
|
|
|
4762 of CAR as car and CDR as cdr. */
|
|
|
4763
|
|
300
|
4764 Lisp_Object
|
|
|
4765 pure_cons (car, cdr)
|
|
|
4766 Lisp_Object car, cdr;
|
|
|
4767 {
|
|
|
4768 register Lisp_Object new;
|
|
32594
|
4769 struct Lisp_Cons *p;
|
|
|
4770
|
|
|
4771 p = (struct Lisp_Cons *) pure_alloc (sizeof *p, Lisp_Cons);
|
|
|
4772 XSETCONS (new, p);
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4773 XSETCAR (new, Fpurecopy (car));
|
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4774 XSETCDR (new, Fpurecopy (cdr));
|
|
300
|
4775 return new;
|
|
|
4776 }
|
|
|
4777
|
|
|
4778
|
|
27738
|
4779 /* Value is a float object with value NUM allocated from pure space. */
|
|
|
4780
|
|
300
|
4781 Lisp_Object
|
|
|
4782 make_pure_float (num)
|
|
|
4783 double num;
|
|
|
4784 {
|
|
|
4785 register Lisp_Object new;
|
|
32594
|
4786 struct Lisp_Float *p;
|
|
|
4787
|
|
|
4788 p = (struct Lisp_Float *) pure_alloc (sizeof *p, Lisp_Float);
|
|
|
4789 XSETFLOAT (new, p);
|
|
25645
|
4790 XFLOAT_DATA (new) = num;
|
|
300
|
4791 return new;
|
|
|
4792 }
|
|
|
4793
|
|
27738
|
4794
|
|
|
4795 /* Return a vector with room for LEN Lisp_Objects allocated from
|
|
|
4796 pure space. */
|
|
|
4797
|
|
300
|
4798 Lisp_Object
|
|
|
4799 make_pure_vector (len)
|
|
8817
|
4800 EMACS_INT len;
|
|
300
|
4801 {
|
|
32594
|
4802 Lisp_Object new;
|
|
|
4803 struct Lisp_Vector *p;
|
|
|
4804 size_t size = sizeof *p + (len - 1) * sizeof (Lisp_Object);
|
|
|
4805
|
|
|
4806 p = (struct Lisp_Vector *) pure_alloc (size, Lisp_Vectorlike);
|
|
|
4807 XSETVECTOR (new, p);
|
|
300
|
4808 XVECTOR (new)->size = len;
|
|
|
4809 return new;
|
|
|
4810 }
|
|
|
4811
|
|
27738
|
4812
|
|
300
|
4813 DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0,
|
|
68741
|
4814 doc: /* Make a copy of object OBJ in pure storage.
|
|
39914
|
4815 Recursively copies contents of vectors and cons cells.
|
|
39988
|
4816 Does not copy symbols. Copies strings without text properties. */)
|
|
|
4817 (obj)
|
|
300
|
4818 register Lisp_Object obj;
|
|
|
4819 {
|
|
485
|
4820 if (NILP (Vpurify_flag))
|
|
300
|
4821 return obj;
|
|
|
4822
|
|
32594
|
4823 if (PURE_POINTER_P (XPNTR (obj)))
|
|
300
|
4824 return obj;
|
|
|
4825
|
|
10004
|
4826 if (CONSP (obj))
|
|
25645
|
4827 return pure_cons (XCAR (obj), XCDR (obj));
|
|
10004
|
4828 else if (FLOATP (obj))
|
|
25645
|
4829 return make_pure_float (XFLOAT_DATA (obj));
|
|
10004
|
4830 else if (STRINGP (obj))
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4831 return make_pure_string (SDATA (obj), SCHARS (obj),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4832 SBYTES (obj),
|
|
21258
|
4833 STRING_MULTIBYTE (obj));
|
|
10004
|
4834 else if (COMPILEDP (obj) || VECTORP (obj))
|
|
|
4835 {
|
|
|
4836 register struct Lisp_Vector *vec;
|
|
53705
|
4837 register int i;
|
|
|
4838 EMACS_INT size;
|
|
300
|
4839
|
|
10004
|
4840 size = XVECTOR (obj)->size;
|
|
10427
|
4841 if (size & PSEUDOVECTOR_FLAG)
|
|
|
4842 size &= PSEUDOVECTOR_SIZE_MASK;
|
|
53705
|
4843 vec = XVECTOR (make_pure_vector (size));
|
|
10004
|
4844 for (i = 0; i < size; i++)
|
|
|
4845 vec->contents[i] = Fpurecopy (XVECTOR (obj)->contents[i]);
|
|
|
4846 if (COMPILEDP (obj))
|
|
|
4847 XSETCOMPILED (obj, vec);
|
|
|
4848 else
|
|
|
4849 XSETVECTOR (obj, vec);
|
|
300
|
4850 return obj;
|
|
|
4851 }
|
|
10004
|
4852 else if (MARKERP (obj))
|
|
|
4853 error ("Attempt to copy a marker to pure storage");
|
|
31829
|
4854
|
|
|
4855 return obj;
|
|
300
|
4856 }
|
|
27142
|
4857
|
|
27738
|
4858
|
|
300
|
4859
|
|
27738
|
4860 /***********************************************************************
|
|
|
4861 Protection from GC
|
|
|
4862 ***********************************************************************/
|
|
|
4863
|
|
27142
|
4864 /* Put an entry in staticvec, pointing at the variable with address
|
|
|
4865 VARADDRESS. */
|
|
300
|
4866
|
|
|
4867 void
|
|
|
4868 staticpro (varaddress)
|
|
|
4869 Lisp_Object *varaddress;
|
|
|
4870 {
|
|
|
4871 staticvec[staticidx++] = varaddress;
|
|
|
4872 if (staticidx >= NSTATICS)
|
|
|
4873 abort ();
|
|
|
4874 }
|
|
|
4875
|
|
|
4876 struct catchtag
|
|
27142
|
4877 {
|
|
300
|
4878 Lisp_Object tag;
|
|
|
4879 Lisp_Object val;
|
|
|
4880 struct catchtag *next;
|
|
27142
|
4881 };
|
|
300
|
4882
|
|
|
4883
|
|
27738
|
4884 /***********************************************************************
|
|
|
4885 Protection from GC
|
|
|
4886 ***********************************************************************/
|
|
1908
|
4887
|
|
11374
|
4888 /* Temporarily prevent garbage collection. */
|
|
|
4889
|
|
|
4890 int
|
|
|
4891 inhibit_garbage_collection ()
|
|
|
4892 {
|
|
46293
|
4893 int count = SPECPDL_INDEX ();
|
41867
a555c6419185
(inhibit_garbage_collection): Don't exceed value an int can hold.
Andreas Schwab <schwab@suse.de>
diff
changeset
|
4894 int nbits = min (VALBITS, BITS_PER_INT);
|
a555c6419185
(inhibit_garbage_collection): Don't exceed value an int can hold.
Andreas Schwab <schwab@suse.de>
diff
changeset
|
4895
|
a555c6419185
(inhibit_garbage_collection): Don't exceed value an int can hold.
Andreas Schwab <schwab@suse.de>
diff
changeset
|
4896 specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1));
|
|
11374
|
4897 return count;
|
|
|
4898 }
|
|
|
4899
|
|
27738
|
4900
|
|
300
|
4901 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
|
|
39988
|
4902 doc: /* Reclaim storage for Lisp objects no longer needed.
|
|
51788
|
4903 Garbage collection happens automatically if you cons more than
|
|
|
4904 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
|
|
|
4905 `garbage-collect' normally returns a list with info on amount of space in use:
|
|
39914
|
4906 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
|
|
|
4907 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
|
|
|
4908 (USED-FLOATS . FREE-FLOATS) (USED-INTERVALS . FREE-INTERVALS)
|
|
|
4909 (USED-STRINGS . FREE-STRINGS))
|
|
51788
|
4910 However, if there was overflow in pure space, `garbage-collect'
|
|
|
4911 returns nil, because real GC can't be done. */)
|
|
39988
|
4912 ()
|
|
300
|
4913 {
|
|
|
4914 register struct specbinding *bind;
|
|
|
4915 struct catchtag *catch;
|
|
|
4916 struct handler *handler;
|
|
|
4917 char stack_top_variable;
|
|
|
4918 register int i;
|
|
25343
|
4919 int message_p;
|
|
34270
|
4920 Lisp_Object total[8];
|
|
46285
|
4921 int count = SPECPDL_INDEX ();
|
|
49529
|
4922 EMACS_TIME t1, t2, t3;
|
|
|
4923
|
|
50745
|
4924 if (abort_on_gc)
|
|
|
4925 abort ();
|
|
|
4926
|
|
39572
|
4927 /* Can't GC if pure storage overflowed because we can't determine
|
|
|
4928 if something is a pure object or not. */
|
|
|
4929 if (pure_bytes_used_before_overflow)
|
|
|
4930 return Qnil;
|
|
|
4931
|
|
61252
|
4932 CHECK_CONS_LIST ();
|
|
|
4933
|
|
59047
|
4934 /* Don't keep undo information around forever.
|
|
|
4935 Do this early on, so it is no problem if the user quits. */
|
|
|
4936 {
|
|
|
4937 register struct buffer *nextb = all_buffers;
|
|
|
4938
|
|
|
4939 while (nextb)
|
|
|
4940 {
|
|
|
4941 /* If a buffer's undo list is Qt, that means that undo is
|
|
|
4942 turned off in that buffer. Calling truncate_undo_list on
|
|
|
4943 Qt tends to return NULL, which effectively turns undo back on.
|
|
|
4944 So don't call truncate_undo_list if undo_list is Qt. */
|
|
59314
|
4945 if (! NILP (nextb->name) && ! EQ (nextb->undo_list, Qt))
|
|
59047
|
4946 truncate_undo_list (nextb);
|
|
|
4947
|
|
|
4948 /* Shrink buffer gaps, but skip indirect and dead buffers. */
|
|
|
4949 if (nextb->base_buffer == 0 && !NILP (nextb->name))
|
|
|
4950 {
|
|
|
4951 /* If a buffer's gap size is more than 10% of the buffer
|
|
|
4952 size, or larger than 2000 bytes, then shrink it
|
|
|
4953 accordingly. Keep a minimum size of 20 bytes. */
|
|
|
4954 int size = min (2000, max (20, (nextb->text->z_byte / 10)));
|
|
|
4955
|
|
|
4956 if (nextb->text->gap_size > size)
|
|
|
4957 {
|
|
|
4958 struct buffer *save_current = current_buffer;
|
|
|
4959 current_buffer = nextb;
|
|
|
4960 make_gap (-(nextb->text->gap_size - size));
|
|
|
4961 current_buffer = save_current;
|
|
|
4962 }
|
|
|
4963 }
|
|
|
4964
|
|
|
4965 nextb = nextb->next;
|
|
|
4966 }
|
|
|
4967 }
|
|
|
4968
|
|
|
4969 EMACS_GET_TIME (t1);
|
|
|
4970
|
|
11892
|
4971 /* In case user calls debug_print during GC,
|
|
|
4972 don't let that cause a recursive GC. */
|
|
|
4973 consing_since_gc = 0;
|
|
|
4974
|
|
25343
|
4975 /* Save what's currently displayed in the echo area. */
|
|
|
4976 message_p = push_message ();
|
|
47391
|
4977 record_unwind_protect (pop_message_unwind, Qnil);
|
|
25024
|
4978
|
|
300
|
4979 /* Save a copy of the contents of the stack, for debugging. */
|
|
|
4980 #if MAX_SAVE_STACK > 0
|
|
485
|
4981 if (NILP (Vpurify_flag))
|
|
300
|
4982 {
|
|
|
4983 i = &stack_top_variable - stack_bottom;
|
|
|
4984 if (i < 0) i = -i;
|
|
|
4985 if (i < MAX_SAVE_STACK)
|
|
|
4986 {
|
|
|
4987 if (stack_copy == 0)
|
|
2439
|
4988 stack_copy = (char *) xmalloc (stack_copy_size = i);
|
|
300
|
4989 else if (stack_copy_size < i)
|
|
2439
|
4990 stack_copy = (char *) xrealloc (stack_copy, (stack_copy_size = i));
|
|
300
|
4991 if (stack_copy)
|
|
|
4992 {
|
|
8817
|
4993 if ((EMACS_INT) (&stack_top_variable - stack_bottom) > 0)
|
|
300
|
4994 bcopy (stack_bottom, stack_copy, i);
|
|
|
4995 else
|
|
|
4996 bcopy (&stack_top_variable, stack_copy, i);
|
|
|
4997 }
|
|
|
4998 }
|
|
|
4999 }
|
|
|
5000 #endif /* MAX_SAVE_STACK > 0 */
|
|
|
5001
|
|
14959
|
5002 if (garbage_collection_messages)
|
|
10395
|
5003 message1_nolog ("Garbage collecting...");
|
|
300
|
5004
|
|
23534
|
5005 BLOCK_INPUT;
|
|
|
5006
|
|
22220
|
5007 shrink_regexp_cache ();
|
|
|
5008
|
|
300
|
5009 gc_in_progress = 1;
|
|
|
5010
|
|
16231
|
5011 /* clear_marks (); */
|
|
300
|
5012
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5013 /* Mark all the special slots that serve as the roots of accessibility. */
|
|
300
|
5014
|
|
|
5015 for (i = 0; i < staticidx; i++)
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5016 mark_object (*staticvec[i]);
|
|
27738
|
5017
|
57098
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5018 for (bind = specpdl; bind != specpdl_ptr; bind++)
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5019 {
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5020 mark_object (bind->symbol);
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5021 mark_object (bind->old_value);
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5022 }
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5023 mark_kboards ();
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5024
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5025 #ifdef USE_GTK
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5026 {
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5027 extern void xg_mark_data ();
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5028 xg_mark_data ();
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5029 }
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5030 #endif
|
0487c26b96ee
(Fgarbage_collect): Mark keyboards, gtk data, and specpdl
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5031
|
|
27738
|
5032 #if (GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS \
|
|
|
5033 || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
|
|
|
5034 mark_stack ();
|
|
|
5035 #else
|
|
51228
|
5036 {
|
|
|
5037 register struct gcpro *tail;
|
|
|
5038 for (tail = gcprolist; tail; tail = tail->next)
|
|
|
5039 for (i = 0; i < tail->nvars; i++)
|
52473
a3fd06a8c844
(init_intervals, init_symbol, init_marker): Don't preallocate anything.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5040 mark_object (tail->var[i]);
|
|
51228
|
5041 }
|
|
27738
|
5042 #endif
|
|
49600
|
5043
|
|
26364
|
5044 mark_byte_stack ();
|
|
300
|
5045 for (catch = catchlist; catch; catch = catch->next)
|
|
|
5046 {
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5047 mark_object (catch->tag);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5048 mark_object (catch->val);
|
|
49600
|
5049 }
|
|
300
|
5050 for (handler = handlerlist; handler; handler = handler->next)
|
|
|
5051 {
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5052 mark_object (handler->handler);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5053 mark_object (handler->var);
|
|
49600
|
5054 }
|
|
55798
|
5055 mark_backtrace ();
|
|
300
|
5056
|
|
59400
|
5057 #ifdef HAVE_WINDOW_SYSTEM
|
|
|
5058 mark_fringe_data ();
|
|
|
5059 #endif
|
|
|
5060
|
|
55667
|
5061 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
5062 mark_stack ();
|
|
|
5063 #endif
|
|
|
5064
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5065 /* Everything is now marked, except for the things that require special
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5066 finalization, i.e. the undo_list.
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5067 Look thru every buffer's undo list
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5068 for elements that update markers that were not marked,
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5069 and delete them. */
|
|
21306
|
5070 {
|
|
|
5071 register struct buffer *nextb = all_buffers;
|
|
|
5072
|
|
|
5073 while (nextb)
|
|
|
5074 {
|
|
|
5075 /* If a buffer's undo list is Qt, that means that undo is
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5076 turned off in that buffer. Calling truncate_undo_list on
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5077 Qt tends to return NULL, which effectively turns undo back on.
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5078 So don't call truncate_undo_list if undo_list is Qt. */
|
|
21306
|
5079 if (! EQ (nextb->undo_list, Qt))
|
|
|
5080 {
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5081 Lisp_Object tail, prev;
|
|
21306
|
5082 tail = nextb->undo_list;
|
|
|
5083 prev = Qnil;
|
|
|
5084 while (CONSP (tail))
|
|
|
5085 {
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5086 if (GC_CONSP (XCAR (tail))
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5087 && GC_MARKERP (XCAR (XCAR (tail)))
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5088 && !XMARKER (XCAR (XCAR (tail)))->gcmarkbit)
|
|
21306
|
5089 {
|
|
|
5090 if (NILP (prev))
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5091 nextb->undo_list = tail = XCDR (tail);
|
|
21306
|
5092 else
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5093 {
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5094 tail = XCDR (tail);
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5095 XSETCDR (prev, tail);
|
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5096 }
|
|
21306
|
5097 }
|
|
|
5098 else
|
|
|
5099 {
|
|
|
5100 prev = tail;
|
|
25645
|
5101 tail = XCDR (tail);
|
|
21306
|
5102 }
|
|
|
5103 }
|
|
|
5104 }
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5105 /* Now that we have stripped the elements that need not be in the
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5106 undo_list any more, we can finally mark the list. */
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5107 mark_object (nextb->undo_list);
|
|
21306
|
5108
|
|
|
5109 nextb = nextb->next;
|
|
|
5110 }
|
|
|
5111 }
|
|
|
5112
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5113 gc_sweep ();
|
|
55767
|
5114
|
|
300
|
5115 /* Clear the mark bits that we set in certain root slots. */
|
|
|
5116
|
|
26378
|
5117 unmark_byte_stack ();
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5118 VECTOR_UNMARK (&buffer_defaults);
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5119 VECTOR_UNMARK (&buffer_local_symbols);
|
|
300
|
5120
|
|
27738
|
5121 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES && 0
|
|
|
5122 dump_zombies ();
|
|
|
5123 #endif
|
|
|
5124
|
|
23534
|
5125 UNBLOCK_INPUT;
|
|
|
5126
|
|
61252
|
5127 CHECK_CONS_LIST ();
|
|
|
5128
|
|
16231
|
5129 /* clear_marks (); */
|
|
300
|
5130 gc_in_progress = 0;
|
|
|
5131
|
|
|
5132 consing_since_gc = 0;
|
|
|
5133 if (gc_cons_threshold < 10000)
|
|
|
5134 gc_cons_threshold = 10000;
|
|
|
5135
|
64267
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5136 if (FLOATP (Vgc_cons_percentage))
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5137 { /* Set gc_cons_combined_threshold. */
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5138 EMACS_INT total = 0;
|
|
64611
|
5139
|
64267
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5140 total += total_conses * sizeof (struct Lisp_Cons);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5141 total += total_symbols * sizeof (struct Lisp_Symbol);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5142 total += total_markers * sizeof (union Lisp_Misc);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5143 total += total_string_size;
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5144 total += total_vector_size * sizeof (Lisp_Object);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5145 total += total_floats * sizeof (struct Lisp_Float);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5146 total += total_intervals * sizeof (struct interval);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5147 total += total_strings * sizeof (struct Lisp_String);
|
|
66777
|
5148
|
|
64611
|
5149 gc_relative_threshold = total * XFLOAT_DATA (Vgc_cons_percentage);
|
64267
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5150 }
|
|
64611
|
5151 else
|
|
|
5152 gc_relative_threshold = 0;
|
64267
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5153
|
|
14959
|
5154 if (garbage_collection_messages)
|
|
|
5155 {
|
|
25343
|
5156 if (message_p || minibuf_level > 0)
|
|
|
5157 restore_message ();
|
|
14959
|
5158 else
|
|
|
5159 message1_nolog ("Garbage collecting...done");
|
|
|
5160 }
|
|
300
|
5161
|
|
35170
|
5162 unbind_to (count, Qnil);
|
|
27142
|
5163
|
|
|
5164 total[0] = Fcons (make_number (total_conses),
|
|
|
5165 make_number (total_free_conses));
|
|
|
5166 total[1] = Fcons (make_number (total_symbols),
|
|
|
5167 make_number (total_free_symbols));
|
|
|
5168 total[2] = Fcons (make_number (total_markers),
|
|
|
5169 make_number (total_free_markers));
|
|
34270
|
5170 total[3] = make_number (total_string_size);
|
|
|
5171 total[4] = make_number (total_vector_size);
|
|
|
5172 total[5] = Fcons (make_number (total_floats),
|
|
27142
|
5173 make_number (total_free_floats));
|
|
34270
|
5174 total[6] = Fcons (make_number (total_intervals),
|
|
27142
|
5175 make_number (total_free_intervals));
|
|
34270
|
5176 total[7] = Fcons (make_number (total_strings),
|
|
27142
|
5177 make_number (total_free_strings));
|
|
|
5178
|
|
27738
|
5179 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
5180 {
|
|
|
5181 /* Compute average percentage of zombies. */
|
|
|
5182 double nlive = 0;
|
|
49600
|
5183
|
|
27738
|
5184 for (i = 0; i < 7; ++i)
|
|
49357
|
5185 if (CONSP (total[i]))
|
|
|
5186 nlive += XFASTINT (XCAR (total[i]));
|
|
27738
|
5187
|
|
|
5188 avg_live = (avg_live * ngcs + nlive) / (ngcs + 1);
|
|
|
5189 max_live = max (nlive, max_live);
|
|
|
5190 avg_zombies = (avg_zombies * ngcs + nzombies) / (ngcs + 1);
|
|
|
5191 max_zombies = max (nzombies, max_zombies);
|
|
|
5192 ++ngcs;
|
|
|
5193 }
|
|
|
5194 #endif
|
|
|
5195
|
|
39572
|
5196 if (!NILP (Vpost_gc_hook))
|
|
|
5197 {
|
|
|
5198 int count = inhibit_garbage_collection ();
|
|
|
5199 safe_run_hooks (Qpost_gc_hook);
|
|
|
5200 unbind_to (count, Qnil);
|
|
|
5201 }
|
|
49529
|
5202
|
|
|
5203 /* Accumulate statistics. */
|
|
|
5204 EMACS_GET_TIME (t2);
|
|
|
5205 EMACS_SUB_TIME (t3, t2, t1);
|
|
|
5206 if (FLOATP (Vgc_elapsed))
|
|
49911
|
5207 Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) +
|
|
|
5208 EMACS_SECS (t3) +
|
|
|
5209 EMACS_USECS (t3) * 1.0e-6);
|
|
49529
|
5210 gcs_done++;
|
|
|
5211
|
|
34270
|
5212 return Flist (sizeof total / sizeof *total, total);
|
|
300
|
5213 }
|
|
27738
|
5214
|
|
25024
|
5215
|
|
25367
|
5216 /* Mark Lisp objects in glyph matrix MATRIX. Currently the
|
|
|
5217 only interesting objects referenced from glyphs are strings. */
|
|
25024
|
5218
|
|
|
5219 static void
|
|
|
5220 mark_glyph_matrix (matrix)
|
|
|
5221 struct glyph_matrix *matrix;
|
|
|
5222 {
|
|
|
5223 struct glyph_row *row = matrix->rows;
|
|
|
5224 struct glyph_row *end = row + matrix->nrows;
|
|
|
5225
|
|
27142
|
5226 for (; row < end; ++row)
|
|
|
5227 if (row->enabled_p)
|
|
|
5228 {
|
|
|
5229 int area;
|
|
|
5230 for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
|
|
|
5231 {
|
|
|
5232 struct glyph *glyph = row->glyphs[area];
|
|
|
5233 struct glyph *end_glyph = glyph + row->used[area];
|
|
49600
|
5234
|
|
27142
|
5235 for (; glyph < end_glyph; ++glyph)
|
|
|
5236 if (GC_STRINGP (glyph->object)
|
|
|
5237 && !STRING_MARKED_P (XSTRING (glyph->object)))
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5238 mark_object (glyph->object);
|
|
27142
|
5239 }
|
|
|
5240 }
|
|
25024
|
5241 }
|
|
|
5242
|
|
27738
|
5243
|
|
25024
|
5244 /* Mark Lisp faces in the face cache C. */
|
|
|
5245
|
|
|
5246 static void
|
|
|
5247 mark_face_cache (c)
|
|
|
5248 struct face_cache *c;
|
|
|
5249 {
|
|
|
5250 if (c)
|
|
|
5251 {
|
|
|
5252 int i, j;
|
|
|
5253 for (i = 0; i < c->used; ++i)
|
|
|
5254 {
|
|
|
5255 struct face *face = FACE_FROM_ID (c->f, i);
|
|
|
5256
|
|
|
5257 if (face)
|
|
|
5258 {
|
|
|
5259 for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5260 mark_object (face->lface[j]);
|
|
25024
|
5261 }
|
|
|
5262 }
|
|
|
5263 }
|
|
|
5264 }
|
|
|
5265
|
|
|
5266
|
|
|
5267 #ifdef HAVE_WINDOW_SYSTEM
|
|
|
5268
|
|
|
5269 /* Mark Lisp objects in image IMG. */
|
|
|
5270
|
|
|
5271 static void
|
|
|
5272 mark_image (img)
|
|
|
5273 struct image *img;
|
|
|
5274 {
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5275 mark_object (img->spec);
|
|
49600
|
5276
|
|
31892
|
5277 if (!NILP (img->data.lisp_val))
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5278 mark_object (img->data.lisp_val);
|
|
25024
|
5279 }
|
|
|
5280
|
|
|
5281
|
|
|
5282 /* Mark Lisp objects in image cache of frame F. It's done this way so
|
|
|
5283 that we don't have to include xterm.h here. */
|
|
|
5284
|
|
|
5285 static void
|
|
|
5286 mark_image_cache (f)
|
|
|
5287 struct frame *f;
|
|
|
5288 {
|
|
|
5289 forall_images_in_image_cache (f, mark_image);
|
|
|
5290 }
|
|
|
5291
|
|
|
5292 #endif /* HAVE_X_WINDOWS */
|
|
|
5293
|
|
|
5294
|
|
300
|
5295
|
|
1908
|
5296 /* Mark reference to a Lisp_Object.
|
|
27142
|
5297 If the object referred to has not been seen yet, recursively mark
|
|
|
5298 all the references contained in it. */
|
|
300
|
5299
|
|
1168
|
5300 #define LAST_MARKED_SIZE 500
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5301 Lisp_Object last_marked[LAST_MARKED_SIZE];
|
|
1168
|
5302 int last_marked_index;
|
|
|
5303
|
|
46833
|
5304 /* For debugging--call abort when we cdr down this many
|
|
|
5305 links of a list, in mark_object. In debugging,
|
|
|
5306 the call to abort will hit a breakpoint.
|
|
|
5307 Normally this is zero and the check never goes off. */
|
|
|
5308 int mark_object_loop_halt;
|
|
|
5309
|
|
25024
|
5310 void
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5311 mark_object (arg)
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5312 Lisp_Object arg;
|
|
300
|
5313 {
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5314 register Lisp_Object obj = arg;
|
|
29743
|
5315 #ifdef GC_CHECK_MARKED_OBJECTS
|
|
|
5316 void *po;
|
|
|
5317 struct mem_node *m;
|
|
|
5318 #endif
|
|
46833
|
5319 int cdr_count = 0;
|
|
300
|
5320
|
|
5868
|
5321 loop:
|
|
300
|
5322
|
|
32594
|
5323 if (PURE_POINTER_P (XPNTR (obj)))
|
|
300
|
5324 return;
|
|
|
5325
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5326 last_marked[last_marked_index++] = obj;
|
|
1168
|
5327 if (last_marked_index == LAST_MARKED_SIZE)
|
|
|
5328 last_marked_index = 0;
|
|
|
5329
|
|
29743
|
5330 /* Perform some sanity checks on the objects marked here. Abort if
|
|
|
5331 we encounter an object we know is bogus. This increases GC time
|
|
|
5332 by ~80%, and requires compilation with GC_MARK_STACK != 0. */
|
|
|
5333 #ifdef GC_CHECK_MARKED_OBJECTS
|
|
|
5334
|
|
|
5335 po = (void *) XPNTR (obj);
|
|
|
5336
|
|
|
5337 /* Check that the object pointed to by PO is known to be a Lisp
|
|
|
5338 structure allocated from the heap. */
|
|
|
5339 #define CHECK_ALLOCATED() \
|
|
|
5340 do { \
|
|
|
5341 m = mem_find (po); \
|
|
|
5342 if (m == MEM_NIL) \
|
|
|
5343 abort (); \
|
|
|
5344 } while (0)
|
|
|
5345
|
|
|
5346 /* Check that the object pointed to by PO is live, using predicate
|
|
|
5347 function LIVEP. */
|
|
|
5348 #define CHECK_LIVE(LIVEP) \
|
|
|
5349 do { \
|
|
|
5350 if (!LIVEP (m, po)) \
|
|
|
5351 abort (); \
|
|
|
5352 } while (0)
|
|
|
5353
|
|
|
5354 /* Check both of the above conditions. */
|
|
|
5355 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) \
|
|
|
5356 do { \
|
|
|
5357 CHECK_ALLOCATED (); \
|
|
|
5358 CHECK_LIVE (LIVEP); \
|
|
|
5359 } while (0) \
|
|
49600
|
5360
|
|
29743
|
5361 #else /* not GC_CHECK_MARKED_OBJECTS */
|
|
49600
|
5362
|
|
29743
|
5363 #define CHECK_ALLOCATED() (void) 0
|
|
|
5364 #define CHECK_LIVE(LIVEP) (void) 0
|
|
|
5365 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0
|
|
49600
|
5366
|
|
29743
|
5367 #endif /* not GC_CHECK_MARKED_OBJECTS */
|
|
|
5368
|
10457
2ab3bd0288a9
Change all occurences of SWITCH_ENUM_BUG to use SWITCH_ENUM_CAST instead.
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
5369 switch (SWITCH_ENUM_CAST (XGCTYPE (obj)))
|
|
300
|
5370 {
|
|
|
5371 case Lisp_String:
|
|
|
5372 {
|
|
|
5373 register struct Lisp_String *ptr = XSTRING (obj);
|
|
29743
|
5374 CHECK_ALLOCATED_AND_LIVE (live_string_p);
|
|
1300
|
5375 MARK_INTERVAL_TREE (ptr->intervals);
|
|
27142
|
5376 MARK_STRING (ptr);
|
|
32587
|
5377 #ifdef GC_CHECK_STRING_BYTES
|
|
35183
|
5378 /* Check that the string size recorded in the string is the
|
|
|
5379 same as the one recorded in the sdata structure. */
|
|
|
5380 CHECK_STRING_BYTES (ptr);
|
|
32587
|
5381 #endif /* GC_CHECK_STRING_BYTES */
|
|
300
|
5382 }
|
|
|
5383 break;
|
|
|
5384
|
|
10009
|
5385 case Lisp_Vectorlike:
|
|
29743
|
5386 #ifdef GC_CHECK_MARKED_OBJECTS
|
|
|
5387 m = mem_find (po);
|
|
|
5388 if (m == MEM_NIL && !GC_SUBRP (obj)
|
|
|
5389 && po != &buffer_defaults
|
|
|
5390 && po != &buffer_local_symbols)
|
|
|
5391 abort ();
|
|
|
5392 #endif /* GC_CHECK_MARKED_OBJECTS */
|
|
49600
|
5393
|
|
10307
|
5394 if (GC_BUFFERP (obj))
|
|
10340
|
5395 {
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5396 if (!VECTOR_MARKED_P (XBUFFER (obj)))
|
|
29743
|
5397 {
|
|
|
5398 #ifdef GC_CHECK_MARKED_OBJECTS
|
|
|
5399 if (po != &buffer_defaults && po != &buffer_local_symbols)
|
|
|
5400 {
|
|
|
5401 struct buffer *b;
|
|
|
5402 for (b = all_buffers; b && b != po; b = b->next)
|
|
|
5403 ;
|
|
|
5404 if (b == NULL)
|
|
|
5405 abort ();
|
|
|
5406 }
|
|
|
5407 #endif /* GC_CHECK_MARKED_OBJECTS */
|
|
|
5408 mark_buffer (obj);
|
|
|
5409 }
|
|
10340
|
5410 }
|
|
10307
|
5411 else if (GC_SUBRP (obj))
|
|
10291
|
5412 break;
|
|
|
5413 else if (GC_COMPILEDP (obj))
|
|
27142
|
5414 /* We could treat this just like a vector, but it is better to
|
|
|
5415 save the COMPILED_CONSTANTS element for last and avoid
|
|
|
5416 recursion there. */
|
|
10291
|
5417 {
|
|
|
5418 register struct Lisp_Vector *ptr = XVECTOR (obj);
|
|
|
5419 register EMACS_INT size = ptr->size;
|
|
|
5420 register int i;
|
|
300
|
5421
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5422 if (VECTOR_MARKED_P (ptr))
|
|
10291
|
5423 break; /* Already marked */
|
|
49600
|
5424
|
|
29743
|
5425 CHECK_LIVE (live_vector_p);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5426 VECTOR_MARK (ptr); /* Else mark it */
|
|
10009
|
5427 size &= PSEUDOVECTOR_SIZE_MASK;
|
|
10291
|
5428 for (i = 0; i < size; i++) /* and then mark its elements */
|
|
|
5429 {
|
|
|
5430 if (i != COMPILED_CONSTANTS)
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5431 mark_object (ptr->contents[i]);
|
|
10291
|
5432 }
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5433 obj = ptr->contents[COMPILED_CONSTANTS];
|
|
10291
|
5434 goto loop;
|
|
|
5435 }
|
|
|
5436 else if (GC_FRAMEP (obj))
|
|
|
5437 {
|
|
32360
|
5438 register struct frame *ptr = XFRAME (obj);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5439
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5440 if (VECTOR_MARKED_P (ptr)) break; /* Already marked */
|
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5441 VECTOR_MARK (ptr); /* Else mark it */
|
|
1295
|
5442
|
|
29743
|
5443 CHECK_LIVE (live_vector_p);
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5444 mark_object (ptr->name);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5445 mark_object (ptr->icon_name);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5446 mark_object (ptr->title);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5447 mark_object (ptr->focus_frame);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5448 mark_object (ptr->selected_window);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5449 mark_object (ptr->minibuffer_window);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5450 mark_object (ptr->param_alist);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5451 mark_object (ptr->scroll_bars);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5452 mark_object (ptr->condemned_scroll_bars);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5453 mark_object (ptr->menu_bar_items);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5454 mark_object (ptr->face_alist);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5455 mark_object (ptr->menu_bar_vector);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5456 mark_object (ptr->buffer_predicate);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5457 mark_object (ptr->buffer_list);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5458 mark_object (ptr->menu_bar_window);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5459 mark_object (ptr->tool_bar_window);
|
|
25024
|
5460 mark_face_cache (ptr->face_cache);
|
|
|
5461 #ifdef HAVE_WINDOW_SYSTEM
|
|
|
5462 mark_image_cache (ptr);
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5463 mark_object (ptr->tool_bar_items);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5464 mark_object (ptr->desired_tool_bar_string);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5465 mark_object (ptr->current_tool_bar_string);
|
|
25024
|
5466 #endif /* HAVE_WINDOW_SYSTEM */
|
|
10291
|
5467 }
|
|
13141
|
5468 else if (GC_BOOL_VECTOR_P (obj))
|
|
15379
|
5469 {
|
|
|
5470 register struct Lisp_Vector *ptr = XVECTOR (obj);
|
|
|
5471
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5472 if (VECTOR_MARKED_P (ptr))
|
|
15379
|
5473 break; /* Already marked */
|
|
29743
|
5474 CHECK_LIVE (live_vector_p);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5475 VECTOR_MARK (ptr); /* Else mark it */
|
|
15379
|
5476 }
|
|
25024
|
5477 else if (GC_WINDOWP (obj))
|
|
|
5478 {
|
|
|
5479 register struct Lisp_Vector *ptr = XVECTOR (obj);
|
|
|
5480 struct window *w = XWINDOW (obj);
|
|
|
5481 register int i;
|
|
|
5482
|
|
|
5483 /* Stop if already marked. */
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5484 if (VECTOR_MARKED_P (ptr))
|
|
25024
|
5485 break;
|
|
|
5486
|
|
|
5487 /* Mark it. */
|
|
29743
|
5488 CHECK_LIVE (live_vector_p);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5489 VECTOR_MARK (ptr);
|
|
25024
|
5490
|
|
|
5491 /* There is no Lisp data above The member CURRENT_MATRIX in
|
|
|
5492 struct WINDOW. Stop marking when that slot is reached. */
|
|
|
5493 for (i = 0;
|
|
32360
|
5494 (char *) &ptr->contents[i] < (char *) &w->current_matrix;
|
|
25024
|
5495 i++)
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5496 mark_object (ptr->contents[i]);
|
|
25024
|
5497
|
|
|
5498 /* Mark glyphs for leaf windows. Marking window matrices is
|
|
|
5499 sufficient because frame matrices use the same glyph
|
|
|
5500 memory. */
|
|
|
5501 if (NILP (w->hchild)
|
|
|
5502 && NILP (w->vchild)
|
|
|
5503 && w->current_matrix)
|
|
|
5504 {
|
|
|
5505 mark_glyph_matrix (w->current_matrix);
|
|
|
5506 mark_glyph_matrix (w->desired_matrix);
|
|
|
5507 }
|
|
|
5508 }
|
|
|
5509 else if (GC_HASH_TABLE_P (obj))
|
|
|
5510 {
|
|
|
5511 struct Lisp_Hash_Table *h = XHASH_TABLE (obj);
|
|
49600
|
5512
|
|
25024
|
5513 /* Stop if already marked. */
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5514 if (VECTOR_MARKED_P (h))
|
|
25024
|
5515 break;
|
|
49600
|
5516
|
|
25024
|
5517 /* Mark it. */
|
|
29743
|
5518 CHECK_LIVE (live_vector_p);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5519 VECTOR_MARK (h);
|
|
25024
|
5520
|
|
|
5521 /* Mark contents. */
|
|
43005
|
5522 /* Do not mark next_free or next_weak.
|
|
49600
|
5523 Being in the next_weak chain
|
|
43005
|
5524 should not keep the hash table alive.
|
|
|
5525 No need to mark `count' since it is an integer. */
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5526 mark_object (h->test);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5527 mark_object (h->weak);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5528 mark_object (h->rehash_size);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5529 mark_object (h->rehash_threshold);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5530 mark_object (h->hash);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5531 mark_object (h->next);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5532 mark_object (h->index);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5533 mark_object (h->user_hash_function);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5534 mark_object (h->user_cmp_function);
|
|
25024
|
5535
|
|
|
5536 /* If hash table is not weak, mark all keys and values.
|
|
|
5537 For weak tables, mark only the vector. */
|
|
|
5538 if (GC_NILP (h->weak))
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5539 mark_object (h->key_and_value);
|
|
25024
|
5540 else
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5541 VECTOR_MARK (XVECTOR (h->key_and_value));
|
|
25024
|
5542 }
|
|
10291
|
5543 else
|
|
|
5544 {
|
|
|
5545 register struct Lisp_Vector *ptr = XVECTOR (obj);
|
|
|
5546 register EMACS_INT size = ptr->size;
|
|
|
5547 register int i;
|
|
300
|
5548
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5549 if (VECTOR_MARKED_P (ptr)) break; /* Already marked */
|
|
29743
|
5550 CHECK_LIVE (live_vector_p);
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5551 VECTOR_MARK (ptr); /* Else mark it */
|
|
10291
|
5552 if (size & PSEUDOVECTOR_FLAG)
|
|
|
5553 size &= PSEUDOVECTOR_SIZE_MASK;
|
|
25024
|
5554
|
|
10291
|
5555 for (i = 0; i < size; i++) /* and then mark its elements */
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5556 mark_object (ptr->contents[i]);
|
|
10291
|
5557 }
|
|
300
|
5558 break;
|
|
|
5559
|
|
|
5560 case Lisp_Symbol:
|
|
|
5561 {
|
|
32360
|
5562 register struct Lisp_Symbol *ptr = XSYMBOL (obj);
|
|
300
|
5563 struct Lisp_Symbol *ptrx;
|
|
|
5564
|
|
51658
|
5565 if (ptr->gcmarkbit) break;
|
|
29743
|
5566 CHECK_ALLOCATED_AND_LIVE (live_symbol_p);
|
|
51658
|
5567 ptr->gcmarkbit = 1;
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5568 mark_object (ptr->value);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5569 mark_object (ptr->function);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5570 mark_object (ptr->plist);
|
|
27738
|
5571
|
45392
f3d7ab65641f
* alloc.c (Fmake_symbol): Set symbol xname field instead of name.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5572 if (!PURE_POINTER_P (XSTRING (ptr->xname)))
|
f3d7ab65641f
* alloc.c (Fmake_symbol): Set symbol xname field instead of name.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5573 MARK_STRING (XSTRING (ptr->xname));
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5574 MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname));
|
|
49600
|
5575
|
|
20768
|
5576 /* Note that we do not mark the obarray of the symbol.
|
|
|
5577 It is safe not to do so because nothing accesses that
|
|
|
5578 slot except to check whether it is nil. */
|
|
300
|
5579 ptr = ptr->next;
|
|
|
5580 if (ptr)
|
|
|
5581 {
|
|
2507
|
5582 ptrx = ptr; /* Use of ptrx avoids compiler bug on Sun */
|
|
300
|
5583 XSETSYMBOL (obj, ptrx);
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5584 goto loop;
|
|
300
|
5585 }
|
|
|
5586 }
|
|
|
5587 break;
|
|
|
5588
|
|
9437
|
5589 case Lisp_Misc:
|
|
29743
|
5590 CHECK_ALLOCATED_AND_LIVE (live_misc_p);
|
|
51658
|
5591 if (XMARKER (obj)->gcmarkbit)
|
|
|
5592 break;
|
|
|
5593 XMARKER (obj)->gcmarkbit = 1;
|
|
56202
|
5594
|
|
11243
|
5595 switch (XMISCTYPE (obj))
|
|
9437
|
5596 {
|
|
9893
|
5597 case Lisp_Misc_Buffer_Local_Value:
|
|
|
5598 case Lisp_Misc_Some_Buffer_Local_Value:
|
|
|
5599 {
|
|
|
5600 register struct Lisp_Buffer_Local_Value *ptr
|
|
|
5601 = XBUFFER_LOCAL_VALUE (obj);
|
|
|
5602 /* If the cdr is nil, avoid recursion for the car. */
|
|
|
5603 if (EQ (ptr->cdr, Qnil))
|
|
|
5604 {
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5605 obj = ptr->realvalue;
|
|
9893
|
5606 goto loop;
|
|
|
5607 }
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5608 mark_object (ptr->realvalue);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5609 mark_object (ptr->buffer);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5610 mark_object (ptr->frame);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5611 obj = ptr->cdr;
|
|
9893
|
5612 goto loop;
|
|
|
5613 }
|
|
|
5614
|
|
51658
|
5615 case Lisp_Misc_Marker:
|
|
|
5616 /* DO NOT mark thru the marker's chain.
|
|
|
5617 The buffer's markers chain does not preserve markers from gc;
|
|
|
5618 instead, markers are removed from the chain when freed by gc. */
|
|
56202
|
5619 break;
|
|
|
5620
|
|
9463
|
5621 case Lisp_Misc_Intfwd:
|
|
|
5622 case Lisp_Misc_Boolfwd:
|
|
|
5623 case Lisp_Misc_Objfwd:
|
|
|
5624 case Lisp_Misc_Buffer_Objfwd:
|
|
11018
|
5625 case Lisp_Misc_Kboard_Objfwd:
|
|
9463
|
5626 /* Don't bother with Lisp_Buffer_Objfwd,
|
|
|
5627 since all markable slots in current buffer marked anyway. */
|
|
|
5628 /* Don't need to do Lisp_Objfwd, since the places they point
|
|
|
5629 are protected with staticpro. */
|
|
56202
|
5630 break;
|
|
|
5631
|
|
52166
|
5632 case Lisp_Misc_Save_Value:
|
|
56401
|
5633 #if GC_MARK_STACK
|
|
56202
|
5634 {
|
|
|
5635 register struct Lisp_Save_Value *ptr = XSAVE_VALUE (obj);
|
|
|
5636 /* If DOGC is set, POINTER is the address of a memory
|
|
|
5637 area containing INTEGER potential Lisp_Objects. */
|
|
|
5638 if (ptr->dogc)
|
|
|
5639 {
|
|
|
5640 Lisp_Object *p = (Lisp_Object *) ptr->pointer;
|
|
|
5641 int nelt;
|
|
|
5642 for (nelt = ptr->integer; nelt > 0; nelt--, p++)
|
|
|
5643 mark_maybe_object (*p);
|
|
|
5644 }
|
|
|
5645 }
|
|
56401
|
5646 #endif
|
|
9463
|
5647 break;
|
|
|
5648
|
|
9926
|
5649 case Lisp_Misc_Overlay:
|
|
|
5650 {
|
|
|
5651 struct Lisp_Overlay *ptr = XOVERLAY (obj);
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5652 mark_object (ptr->start);
|
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5653 mark_object (ptr->end);
|
|
51843
|
5654 mark_object (ptr->plist);
|
|
|
5655 if (ptr->next)
|
|
|
5656 {
|
|
|
5657 XSETMISC (obj, ptr->next);
|
|
|
5658 goto loop;
|
|
|
5659 }
|
|
9926
|
5660 }
|
|
|
5661 break;
|
|
|
5662
|
|
9437
|
5663 default:
|
|
|
5664 abort ();
|
|
|
5665 }
|
|
300
|
5666 break;
|
|
|
5667
|
|
|
5668 case Lisp_Cons:
|
|
|
5669 {
|
|
|
5670 register struct Lisp_Cons *ptr = XCONS (obj);
|
|
51938
|
5671 if (CONS_MARKED_P (ptr)) break;
|
|
29743
|
5672 CHECK_ALLOCATED_AND_LIVE (live_cons_p);
|
|
51938
|
5673 CONS_MARK (ptr);
|
|
1295
|
5674 /* If the cdr is nil, avoid recursion for the car. */
|
|
66889
|
5675 if (EQ (ptr->u.cdr, Qnil))
|
|
1295
|
5676 {
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5677 obj = ptr->car;
|
|
46833
|
5678 cdr_count = 0;
|
|
1295
|
5679 goto loop;
|
|
|
5680 }
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5681 mark_object (ptr->car);
|
|
66889
|
5682 obj = ptr->u.cdr;
|
|
46833
|
5683 cdr_count++;
|
|
|
5684 if (cdr_count == mark_object_loop_halt)
|
|
|
5685 abort ();
|
|
300
|
5686 goto loop;
|
|
|
5687 }
|
|
|
5688
|
|
|
5689 case Lisp_Float:
|
|
29743
|
5690 CHECK_ALLOCATED_AND_LIVE (live_float_p);
|
|
51723
|
5691 FLOAT_MARK (XFLOAT (obj));
|
|
300
|
5692 break;
|
|
|
5693
|
|
|
5694 case Lisp_Int:
|
|
|
5695 break;
|
|
|
5696
|
|
|
5697 default:
|
|
|
5698 abort ();
|
|
|
5699 }
|
|
29743
|
5700
|
|
|
5701 #undef CHECK_LIVE
|
|
|
5702 #undef CHECK_ALLOCATED
|
|
|
5703 #undef CHECK_ALLOCATED_AND_LIVE
|
|
300
|
5704 }
|
|
|
5705
|
|
|
5706 /* Mark the pointers in a buffer structure. */
|
|
|
5707
|
|
|
5708 static void
|
|
|
5709 mark_buffer (buf)
|
|
|
5710 Lisp_Object buf;
|
|
|
5711 {
|
|
|
5712 register struct buffer *buffer = XBUFFER (buf);
|
|
51843
|
5713 register Lisp_Object *ptr, tmp;
|
|
10307
|
5714 Lisp_Object base_buffer;
|
|
300
|
5715
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5716 VECTOR_MARK (buffer);
|
|
300
|
5717
|
|
10307
|
5718 MARK_INTERVAL_TREE (BUF_INTERVALS (buffer));
|
|
1300
|
5719
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5720 /* For now, we just don't mark the undo_list. It's done later in
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5721 a special way just before the sweep phase, and after stripping
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5722 some of its elements that are not needed any more. */
|
|
21306
|
5723
|
|
51843
|
5724 if (buffer->overlays_before)
|
|
|
5725 {
|
|
|
5726 XSETMISC (tmp, buffer->overlays_before);
|
|
|
5727 mark_object (tmp);
|
|
|
5728 }
|
|
|
5729 if (buffer->overlays_after)
|
|
|
5730 {
|
|
|
5731 XSETMISC (tmp, buffer->overlays_after);
|
|
|
5732 mark_object (tmp);
|
|
|
5733 }
|
|
|
5734
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5735 for (ptr = &buffer->name;
|
|
300
|
5736 (char *)ptr < (char *)buffer + sizeof (struct buffer);
|
|
|
5737 ptr++)
|
51770
ad47aa3ee2d7
(mark_object): Change arg to only take Lisp_Object rather than *Lisp_Object.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5738 mark_object (*ptr);
|
|
10307
|
5739
|
|
|
5740 /* If this is an indirect buffer, mark its base buffer. */
|
|
51686
|
5741 if (buffer->base_buffer && !VECTOR_MARKED_P (buffer->base_buffer))
|
|
10307
|
5742 {
|
|
49600
|
5743 XSETBUFFER (base_buffer, buffer->base_buffer);
|
|
10307
|
5744 mark_buffer (base_buffer);
|
|
|
5745 }
|
|
300
|
5746 }
|
|
10649
|
5747
|
|
|
5748
|
|
25024
|
5749 /* Value is non-zero if OBJ will survive the current GC because it's
|
|
|
5750 either marked or does not need to be marked to survive. */
|
|
|
5751
|
|
|
5752 int
|
|
|
5753 survives_gc_p (obj)
|
|
|
5754 Lisp_Object obj;
|
|
|
5755 {
|
|
|
5756 int survives_p;
|
|
49600
|
5757
|
|
25024
|
5758 switch (XGCTYPE (obj))
|
|
|
5759 {
|
|
|
5760 case Lisp_Int:
|
|
|
5761 survives_p = 1;
|
|
|
5762 break;
|
|
|
5763
|
|
|
5764 case Lisp_Symbol:
|
|
51658
|
5765 survives_p = XSYMBOL (obj)->gcmarkbit;
|
|
25024
|
5766 break;
|
|
|
5767
|
|
|
5768 case Lisp_Misc:
|
|
51668
|
5769 survives_p = XMARKER (obj)->gcmarkbit;
|
|
25024
|
5770 break;
|
|
|
5771
|
|
|
5772 case Lisp_String:
|
|
51938
|
5773 survives_p = STRING_MARKED_P (XSTRING (obj));
|
|
25024
|
5774 break;
|
|
|
5775
|
|
|
5776 case Lisp_Vectorlike:
|
|
51938
|
5777 survives_p = GC_SUBRP (obj) || VECTOR_MARKED_P (XVECTOR (obj));
|
|
25024
|
5778 break;
|
|
|
5779
|
|
|
5780 case Lisp_Cons:
|
|
51938
|
5781 survives_p = CONS_MARKED_P (XCONS (obj));
|
|
25024
|
5782 break;
|
|
|
5783
|
|
|
5784 case Lisp_Float:
|
|
51723
|
5785 survives_p = FLOAT_MARKED_P (XFLOAT (obj));
|
|
25024
|
5786 break;
|
|
|
5787
|
|
|
5788 default:
|
|
|
5789 abort ();
|
|
|
5790 }
|
|
|
5791
|
|
27738
|
5792 return survives_p || PURE_POINTER_P ((void *) XPNTR (obj));
|
|
25024
|
5793 }
|
|
|
5794
|
|
|
5795
|
|
300
|
5796
|
|
1908
|
5797 /* Sweep: find all structures not marked, and free them. */
|
|
300
|
5798
|
|
|
5799 static void
|
|
|
5800 gc_sweep ()
|
|
|
5801 {
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5802 /* Remove or mark entries in weak hash tables.
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5803 This must be done before any object is unmarked. */
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5804 sweep_weak_hash_tables ();
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5805
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5806 sweep_strings ();
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5807 #ifdef GC_CHECK_STRING_BYTES
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5808 if (!noninteractive)
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5809 check_string_bytes (1);
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5810 #endif
|
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
5811
|
|
300
|
5812 /* Put all unmarked conses on free list */
|
|
|
5813 {
|
|
|
5814 register struct cons_block *cblk;
|
|
20057
|
5815 struct cons_block **cprev = &cons_block;
|
|
300
|
5816 register int lim = cons_block_index;
|
|
|
5817 register int num_free = 0, num_used = 0;
|
|
|
5818
|
|
|
5819 cons_free_list = 0;
|
|
49600
|
5820
|
|
20057
|
5821 for (cblk = cons_block; cblk; cblk = *cprev)
|
|
300
|
5822 {
|
|
|
5823 register int i;
|
|
20057
|
5824 int this_free = 0;
|
|
300
|
5825 for (i = 0; i < lim; i++)
|
|
51938
|
5826 if (!CONS_MARKED_P (&cblk->conses[i]))
|
|
300
|
5827 {
|
|
20057
|
5828 this_free++;
|
|
66889
|
5829 cblk->conses[i].u.chain = cons_free_list;
|
|
300
|
5830 cons_free_list = &cblk->conses[i];
|
|
27738
|
5831 #if GC_MARK_STACK
|
|
|
5832 cons_free_list->car = Vdead;
|
|
|
5833 #endif
|
|
300
|
5834 }
|
|
|
5835 else
|
|
|
5836 {
|
|
|
5837 num_used++;
|
|
51938
|
5838 CONS_UNMARK (&cblk->conses[i]);
|
|
300
|
5839 }
|
|
|
5840 lim = CONS_BLOCK_SIZE;
|
|
20057
|
5841 /* If this block contains only free conses and we have already
|
|
|
5842 seen more than two blocks worth of free conses then deallocate
|
|
|
5843 this block. */
|
|
21379
|
5844 if (this_free == CONS_BLOCK_SIZE && num_free > CONS_BLOCK_SIZE)
|
|
20057
|
5845 {
|
|
|
5846 *cprev = cblk->next;
|
|
|
5847 /* Unhook from the free list. */
|
|
66889
|
5848 cons_free_list = cblk->conses[0].u.chain;
|
|
51938
|
5849 lisp_align_free (cblk);
|
|
23958
|
5850 n_cons_blocks--;
|
|
20057
|
5851 }
|
|
|
5852 else
|
|
21379
|
5853 {
|
|
|
5854 num_free += this_free;
|
|
|
5855 cprev = &cblk->next;
|
|
|
5856 }
|
|
300
|
5857 }
|
|
|
5858 total_conses = num_used;
|
|
|
5859 total_free_conses = num_free;
|
|
|
5860 }
|
|
|
5861
|
|
|
5862 /* Put all unmarked floats on free list */
|
|
|
5863 {
|
|
|
5864 register struct float_block *fblk;
|
|
20057
|
5865 struct float_block **fprev = &float_block;
|
|
300
|
5866 register int lim = float_block_index;
|
|
|
5867 register int num_free = 0, num_used = 0;
|
|
|
5868
|
|
|
5869 float_free_list = 0;
|
|
49600
|
5870
|
|
20057
|
5871 for (fblk = float_block; fblk; fblk = *fprev)
|
|
300
|
5872 {
|
|
|
5873 register int i;
|
|
20057
|
5874 int this_free = 0;
|
|
300
|
5875 for (i = 0; i < lim; i++)
|
|
51723
|
5876 if (!FLOAT_MARKED_P (&fblk->floats[i]))
|
|
300
|
5877 {
|
|
20057
|
5878 this_free++;
|
|
66889
|
5879 fblk->floats[i].u.chain = float_free_list;
|
|
300
|
5880 float_free_list = &fblk->floats[i];
|
|
|
5881 }
|
|
|
5882 else
|
|
|
5883 {
|
|
|
5884 num_used++;
|
|
51723
|
5885 FLOAT_UNMARK (&fblk->floats[i]);
|
|
300
|
5886 }
|
|
|
5887 lim = FLOAT_BLOCK_SIZE;
|
|
20057
|
5888 /* If this block contains only free floats and we have already
|
|
|
5889 seen more than two blocks worth of free floats then deallocate
|
|
|
5890 this block. */
|
|
21379
|
5891 if (this_free == FLOAT_BLOCK_SIZE && num_free > FLOAT_BLOCK_SIZE)
|
|
20057
|
5892 {
|
|
|
5893 *fprev = fblk->next;
|
|
|
5894 /* Unhook from the free list. */
|
|
66889
|
5895 float_free_list = fblk->floats[0].u.chain;
|
|
51723
|
5896 lisp_align_free (fblk);
|
|
23958
|
5897 n_float_blocks--;
|
|
20057
|
5898 }
|
|
|
5899 else
|
|
21379
|
5900 {
|
|
|
5901 num_free += this_free;
|
|
|
5902 fprev = &fblk->next;
|
|
|
5903 }
|
|
300
|
5904 }
|
|
|
5905 total_floats = num_used;
|
|
|
5906 total_free_floats = num_free;
|
|
|
5907 }
|
|
|
5908
|
|
1300
|
5909 /* Put all unmarked intervals on free list */
|
|
|
5910 {
|
|
|
5911 register struct interval_block *iblk;
|
|
20057
|
5912 struct interval_block **iprev = &interval_block;
|
|
1300
|
5913 register int lim = interval_block_index;
|
|
|
5914 register int num_free = 0, num_used = 0;
|
|
|
5915
|
|
|
5916 interval_free_list = 0;
|
|
|
5917
|
|
20057
|
5918 for (iblk = interval_block; iblk; iblk = *iprev)
|
|
1300
|
5919 {
|
|
|
5920 register int i;
|
|
20057
|
5921 int this_free = 0;
|
|
1300
|
5922
|
|
|
5923 for (i = 0; i < lim; i++)
|
|
|
5924 {
|
|
51658
|
5925 if (!iblk->intervals[i].gcmarkbit)
|
|
1300
|
5926 {
|
28269
fd13be8ae190
Changes towards better type safety regarding intervals, primarily
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5927 SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
|
|
1300
|
5928 interval_free_list = &iblk->intervals[i];
|
|
20057
|
5929 this_free++;
|
|
1300
|
5930 }
|
|
|
5931 else
|
|
|
5932 {
|
|
|
5933 num_used++;
|
|
51658
|
5934 iblk->intervals[i].gcmarkbit = 0;
|
|
1300
|
5935 }
|
|
|
5936 }
|
|
|
5937 lim = INTERVAL_BLOCK_SIZE;
|
|
20057
|
5938 /* If this block contains only free intervals and we have already
|
|
|
5939 seen more than two blocks worth of free intervals then
|
|
|
5940 deallocate this block. */
|
|
21379
|
5941 if (this_free == INTERVAL_BLOCK_SIZE && num_free > INTERVAL_BLOCK_SIZE)
|
|
20057
|
5942 {
|
|
|
5943 *iprev = iblk->next;
|
|
|
5944 /* Unhook from the free list. */
|
28269
fd13be8ae190
Changes towards better type safety regarding intervals, primarily
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5945 interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
|
|
23958
|
5946 lisp_free (iblk);
|
|
|
5947 n_interval_blocks--;
|
|
20057
|
5948 }
|
|
|
5949 else
|
|
21379
|
5950 {
|
|
|
5951 num_free += this_free;
|
|
|
5952 iprev = &iblk->next;
|
|
|
5953 }
|
|
1300
|
5954 }
|
|
|
5955 total_intervals = num_used;
|
|
|
5956 total_free_intervals = num_free;
|
|
|
5957 }
|
|
|
5958
|
|
300
|
5959 /* Put all unmarked symbols on free list */
|
|
|
5960 {
|
|
|
5961 register struct symbol_block *sblk;
|
|
20057
|
5962 struct symbol_block **sprev = &symbol_block;
|
|
300
|
5963 register int lim = symbol_block_index;
|
|
|
5964 register int num_free = 0, num_used = 0;
|
|
|
5965
|
|
34308
|
5966 symbol_free_list = NULL;
|
|
49600
|
5967
|
|
20057
|
5968 for (sblk = symbol_block; sblk; sblk = *sprev)
|
|
300
|
5969 {
|
|
20057
|
5970 int this_free = 0;
|
|
34308
|
5971 struct Lisp_Symbol *sym = sblk->symbols;
|
|
|
5972 struct Lisp_Symbol *end = sym + lim;
|
|
|
5973
|
|
|
5974 for (; sym < end; ++sym)
|
|
|
5975 {
|
|
34325
|
5976 /* Check if the symbol was created during loadup. In such a case
|
|
|
5977 it might be pointed to by pure bytecode which we don't trace,
|
|
|
5978 so we conservatively assume that it is live. */
|
45392
f3d7ab65641f
* alloc.c (Fmake_symbol): Set symbol xname field instead of name.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5979 int pure_p = PURE_POINTER_P (XSTRING (sym->xname));
|
|
49600
|
5980
|
|
51658
|
5981 if (!sym->gcmarkbit && !pure_p)
|
|
34308
|
5982 {
|
|
66889
|
5983 sym->next = symbol_free_list;
|
|
34308
|
5984 symbol_free_list = sym;
|
|
27738
|
5985 #if GC_MARK_STACK
|
|
34308
|
5986 symbol_free_list->function = Vdead;
|
|
27738
|
5987 #endif
|
|
34308
|
5988 ++this_free;
|
|
|
5989 }
|
|
|
5990 else
|
|
|
5991 {
|
|
|
5992 ++num_used;
|
|
|
5993 if (!pure_p)
|
45392
f3d7ab65641f
* alloc.c (Fmake_symbol): Set symbol xname field instead of name.
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
5994 UNMARK_STRING (XSTRING (sym->xname));
|
|
51658
|
5995 sym->gcmarkbit = 0;
|
|
34308
|
5996 }
|
|
|
5997 }
|
|
49600
|
5998
|
|
300
|
5999 lim = SYMBOL_BLOCK_SIZE;
|
|
20057
|
6000 /* If this block contains only free symbols and we have already
|
|
|
6001 seen more than two blocks worth of free symbols then deallocate
|
|
|
6002 this block. */
|
|
21379
|
6003 if (this_free == SYMBOL_BLOCK_SIZE && num_free > SYMBOL_BLOCK_SIZE)
|
|
20057
|
6004 {
|
|
|
6005 *sprev = sblk->next;
|
|
|
6006 /* Unhook from the free list. */
|
|
66889
|
6007 symbol_free_list = sblk->symbols[0].next;
|
|
23958
|
6008 lisp_free (sblk);
|
|
|
6009 n_symbol_blocks--;
|
|
20057
|
6010 }
|
|
|
6011 else
|
|
21379
|
6012 {
|
|
|
6013 num_free += this_free;
|
|
|
6014 sprev = &sblk->next;
|
|
|
6015 }
|
|
300
|
6016 }
|
|
|
6017 total_symbols = num_used;
|
|
|
6018 total_free_symbols = num_free;
|
|
|
6019 }
|
|
|
6020
|
|
21143
|
6021 /* Put all unmarked misc's on free list.
|
|
|
6022 For a marker, first unchain it from the buffer it points into. */
|
|
300
|
6023 {
|
|
|
6024 register struct marker_block *mblk;
|
|
20057
|
6025 struct marker_block **mprev = &marker_block;
|
|
300
|
6026 register int lim = marker_block_index;
|
|
|
6027 register int num_free = 0, num_used = 0;
|
|
|
6028
|
|
|
6029 marker_free_list = 0;
|
|
49600
|
6030
|
|
20057
|
6031 for (mblk = marker_block; mblk; mblk = *mprev)
|
|
300
|
6032 {
|
|
|
6033 register int i;
|
|
20057
|
6034 int this_free = 0;
|
|
11403
|
6035
|
|
300
|
6036 for (i = 0; i < lim; i++)
|
|
9893
|
6037 {
|
|
51658
|
6038 if (!mblk->markers[i].u_marker.gcmarkbit)
|
|
9893
|
6039 {
|
|
11243
|
6040 if (mblk->markers[i].u_marker.type == Lisp_Misc_Marker)
|
|
51668
|
6041 unchain_marker (&mblk->markers[i].u_marker);
|
|
11403
|
6042 /* Set the type of the freed object to Lisp_Misc_Free.
|
|
|
6043 We could leave the type alone, since nobody checks it,
|
|
9893
|
6044 but this might catch bugs faster. */
|
|
11243
|
6045 mblk->markers[i].u_marker.type = Lisp_Misc_Free;
|
|
9893
|
6046 mblk->markers[i].u_free.chain = marker_free_list;
|
|
|
6047 marker_free_list = &mblk->markers[i];
|
|
20057
|
6048 this_free++;
|
|
9893
|
6049 }
|
|
|
6050 else
|
|
|
6051 {
|
|
|
6052 num_used++;
|
|
51658
|
6053 mblk->markers[i].u_marker.gcmarkbit = 0;
|
|
9893
|
6054 }
|
|
|
6055 }
|
|
300
|
6056 lim = MARKER_BLOCK_SIZE;
|
|
20057
|
6057 /* If this block contains only free markers and we have already
|
|
|
6058 seen more than two blocks worth of free markers then deallocate
|
|
|
6059 this block. */
|
|
21379
|
6060 if (this_free == MARKER_BLOCK_SIZE && num_free > MARKER_BLOCK_SIZE)
|
|
20057
|
6061 {
|
|
|
6062 *mprev = mblk->next;
|
|
|
6063 /* Unhook from the free list. */
|
|
|
6064 marker_free_list = mblk->markers[0].u_free.chain;
|
55816
a4fe04f4d9c2
Undo Kim's recent changes and fix the same bug differently.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6065 lisp_free (mblk);
|
|
23958
|
6066 n_marker_blocks--;
|
|
20057
|
6067 }
|
|
|
6068 else
|
|
21379
|
6069 {
|
|
|
6070 num_free += this_free;
|
|
|
6071 mprev = &mblk->next;
|
|
|
6072 }
|
|
300
|
6073 }
|
|
|
6074
|
|
|
6075 total_markers = num_used;
|
|
|
6076 total_free_markers = num_free;
|
|
|
6077 }
|
|
|
6078
|
|
|
6079 /* Free all unmarked buffers */
|
|
|
6080 {
|
|
|
6081 register struct buffer *buffer = all_buffers, *prev = 0, *next;
|
|
|
6082
|
|
|
6083 while (buffer)
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6084 if (!VECTOR_MARKED_P (buffer))
|
|
300
|
6085 {
|
|
|
6086 if (prev)
|
|
|
6087 prev->next = buffer->next;
|
|
|
6088 else
|
|
|
6089 all_buffers = buffer->next;
|
|
|
6090 next = buffer->next;
|
|
27738
|
6091 lisp_free (buffer);
|
|
300
|
6092 buffer = next;
|
|
|
6093 }
|
|
|
6094 else
|
|
|
6095 {
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6096 VECTOR_UNMARK (buffer);
|
|
10307
|
6097 UNMARK_BALANCE_INTERVALS (BUF_INTERVALS (buffer));
|
|
300
|
6098 prev = buffer, buffer = buffer->next;
|
|
|
6099 }
|
|
|
6100 }
|
|
|
6101
|
|
|
6102 /* Free all unmarked vectors */
|
|
|
6103 {
|
|
|
6104 register struct Lisp_Vector *vector = all_vectors, *prev = 0, *next;
|
|
|
6105 total_vector_size = 0;
|
|
|
6106
|
|
|
6107 while (vector)
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6108 if (!VECTOR_MARKED_P (vector))
|
|
300
|
6109 {
|
|
|
6110 if (prev)
|
|
|
6111 prev->next = vector->next;
|
|
|
6112 else
|
|
|
6113 all_vectors = vector->next;
|
|
|
6114 next = vector->next;
|
|
23958
|
6115 lisp_free (vector);
|
|
|
6116 n_vectors--;
|
|
300
|
6117 vector = next;
|
|
25024
|
6118
|
|
300
|
6119 }
|
|
|
6120 else
|
|
|
6121 {
|
51683
fb960854a12c
(VECTOR_MARK, VECTOR_UNMARK, VECTOR_MARKED_P): New macros.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6122 VECTOR_UNMARK (vector);
|
|
11403
|
6123 if (vector->size & PSEUDOVECTOR_FLAG)
|
|
|
6124 total_vector_size += (PSEUDOVECTOR_SIZE_MASK & vector->size);
|
|
|
6125 else
|
|
|
6126 total_vector_size += vector->size;
|
|
300
|
6127 prev = vector, vector = vector->next;
|
|
|
6128 }
|
|
|
6129 }
|
|
49600
|
6130
|
|
35183
|
6131 #ifdef GC_CHECK_STRING_BYTES
|
|
|
6132 if (!noninteractive)
|
|
|
6133 check_string_bytes (1);
|
|
|
6134 #endif
|
|
300
|
6135 }
|
|
27142
|
6136
|
|
|
6137
|
|
|
6138
|
|
300
|
6139
|
|
1327
|
6140 /* Debugging aids. */
|
|
|
6141
|
|
5353
|
6142 DEFUN ("memory-limit", Fmemory_limit, Smemory_limit, 0, 0, 0,
|
|
40107
|
6143 doc: /* Return the address of the last byte Emacs has allocated, divided by 1024.
|
|
39914
|
6144 This may be helpful in debugging Emacs's memory usage.
|
|
39988
|
6145 We divide the value by 1024 to make sure it fits in a Lisp integer. */)
|
|
|
6146 ()
|
|
1327
|
6147 {
|
|
|
6148 Lisp_Object end;
|
|
|
6149
|
|
9261
|
6150 XSETINT (end, (EMACS_INT) sbrk (0) / 1024);
|
|
1327
|
6151
|
|
|
6152 return end;
|
|
|
6153 }
|
|
|
6154
|
|
12748
|
6155 DEFUN ("memory-use-counts", Fmemory_use_counts, Smemory_use_counts, 0, 0, 0,
|
|
40107
|
6156 doc: /* Return a list of counters that measure how much consing there has been.
|
|
39914
|
6157 Each of these counters increments for a certain kind of object.
|
|
|
6158 The counters wrap around from the largest positive integer to zero.
|
|
|
6159 Garbage collection does not decrease them.
|
|
|
6160 The elements of the value are as follows:
|
|
|
6161 (CONSES FLOATS VECTOR-CELLS SYMBOLS STRING-CHARS MISCS INTERVALS STRINGS)
|
|
|
6162 All are in units of 1 = one object consed
|
|
|
6163 except for VECTOR-CELLS and STRING-CHARS, which count the total length of
|
|
|
6164 objects consed.
|
|
|
6165 MISCS include overlays, markers, and some internal types.
|
|
|
6166 Frames, windows, buffers, and subprocesses count as vectors
|
|
39988
|
6167 (but the contents of a buffer's text do not count here). */)
|
|
|
6168 ()
|
|
12748
|
6169 {
|
|
27142
|
6170 Lisp_Object consed[8];
|
|
|
6171
|
|
39633
|
6172 consed[0] = make_number (min (MOST_POSITIVE_FIXNUM, cons_cells_consed));
|
|
|
6173 consed[1] = make_number (min (MOST_POSITIVE_FIXNUM, floats_consed));
|
|
|
6174 consed[2] = make_number (min (MOST_POSITIVE_FIXNUM, vector_cells_consed));
|
|
|
6175 consed[3] = make_number (min (MOST_POSITIVE_FIXNUM, symbols_consed));
|
|
|
6176 consed[4] = make_number (min (MOST_POSITIVE_FIXNUM, string_chars_consed));
|
|
|
6177 consed[5] = make_number (min (MOST_POSITIVE_FIXNUM, misc_objects_consed));
|
|
|
6178 consed[6] = make_number (min (MOST_POSITIVE_FIXNUM, intervals_consed));
|
|
|
6179 consed[7] = make_number (min (MOST_POSITIVE_FIXNUM, strings_consed));
|
|
27142
|
6180
|
|
|
6181 return Flist (8, consed);
|
|
12748
|
6182 }
|
28406
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6183
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6184 int suppress_checking;
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6185 void
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6186 die (msg, file, line)
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6187 const char *msg;
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6188 const char *file;
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6189 int line;
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6190 {
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6191 fprintf (stderr, "\r\nEmacs fatal error: %s:%d: %s\r\n",
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6192 file, line, msg);
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6193 abort ();
|
451721e784a8
Stop assuming interval pointers and lisp objects can be distinguished by
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
6194 }
|
|
1327
|
6195
|
|
300
|
6196 /* Initialization */
|
|
|
6197
|
|
21514
|
6198 void
|
|
300
|
6199 init_alloc_once ()
|
|
|
6200 {
|
|
|
6201 /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
|
|
39572
|
6202 purebeg = PUREBEG;
|
|
|
6203 pure_size = PURESIZE;
|
|
32594
|
6204 pure_bytes_used = 0;
|
|
39572
|
6205 pure_bytes_used_before_overflow = 0;
|
|
|
6206
|
|
51723
|
6207 /* Initialize the list of free aligned blocks. */
|
|
|
6208 free_ablock = NULL;
|
|
|
6209
|
|
32692
|
6210 #if GC_MARK_STACK || defined GC_MALLOC_CHECK
|
|
27738
|
6211 mem_init ();
|
|
|
6212 Vdead = make_pure_string ("DEAD", 4, 4, 0);
|
|
|
6213 #endif
|
|
39572
|
6214
|
|
300
|
6215 all_vectors = 0;
|
|
|
6216 ignore_warnings = 1;
|
|
17345
|
6217 #ifdef DOUG_LEA_MALLOC
|
|
|
6218 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
|
|
|
6219 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
|
|
23973
|
6220 mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); /* max. number of mmap'ed areas */
|
|
17345
|
6221 #endif
|
|
300
|
6222 init_strings ();
|
|
|
6223 init_cons ();
|
|
|
6224 init_symbol ();
|
|
|
6225 init_marker ();
|
|
|
6226 init_float ();
|
|
27738
|
6227 init_intervals ();
|
|
1300
|
6228
|
|
10673
|
6229 #ifdef REL_ALLOC
|
|
|
6230 malloc_hysteresis = 32;
|
|
|
6231 #else
|
|
|
6232 malloc_hysteresis = 0;
|
|
|
6233 #endif
|
|
|
6234
|
|
66530
|
6235 refill_memory_reserve ();
|
|
10673
|
6236
|
|
300
|
6237 ignore_warnings = 0;
|
|
|
6238 gcprolist = 0;
|
|
26364
|
6239 byte_stack_list = 0;
|
|
300
|
6240 staticidx = 0;
|
|
|
6241 consing_since_gc = 0;
|
|
12605
|
6242 gc_cons_threshold = 100000 * sizeof (Lisp_Object);
|
|
64611
|
6243 gc_relative_threshold = 0;
|
|
|
6244
|
|
300
|
6245 #ifdef VIRT_ADDR_VARIES
|
|
|
6246 malloc_sbrk_unused = 1<<22; /* A large number */
|
|
|
6247 malloc_sbrk_used = 100000; /* as reasonable as any number */
|
|
|
6248 #endif /* VIRT_ADDR_VARIES */
|
|
|
6249 }
|
|
|
6250
|
|
21514
|
6251 void
|
|
300
|
6252 init_alloc ()
|
|
|
6253 {
|
|
|
6254 gcprolist = 0;
|
|
26364
|
6255 byte_stack_list = 0;
|
|
28365
|
6256 #if GC_MARK_STACK
|
|
|
6257 #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
|
|
|
6258 setjmp_tested_p = longjmps_done = 0;
|
|
|
6259 #endif
|
|
|
6260 #endif
|
|
49529
|
6261 Vgc_elapsed = make_float (0.0);
|
|
|
6262 gcs_done = 0;
|
|
300
|
6263 }
|
|
|
6264
|
|
|
6265 void
|
|
|
6266 syms_of_alloc ()
|
|
|
6267 {
|
|
39988
|
6268 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold,
|
|
40107
|
6269 doc: /* *Number of bytes of consing between garbage collections.
|
|
39914
|
6270 Garbage collection can happen automatically once this many bytes have been
|
|
|
6271 allocated since the last garbage collection. All data types count.
|
|
|
6272
|
|
|
6273 Garbage collection happens automatically only when `eval' is called.
|
|
|
6274
|
|
|
6275 By binding this temporarily to a large number, you can effectively
|
64267
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6276 prevent garbage collection during a part of the program.
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6277 See also `gc-cons-percentage'. */);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6278
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6279 DEFVAR_LISP ("gc-cons-percentage", &Vgc_cons_percentage,
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6280 doc: /* *Portion of the heap used for allocation.
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6281 Garbage collection can happen automatically once this portion of the heap
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6282 has been allocated since the last garbage collection.
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6283 If this portion is smaller than `gc-cons-threshold', this is ignored. */);
|
5c7cbbd6dbb4
(gc_cons_combined_threshold, Vgc_cons_percentage): New vars.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
6284 Vgc_cons_percentage = make_float (0.1);
|
|
39914
|
6285
|
|
39988
|
6286 DEFVAR_INT ("pure-bytes-used", &pure_bytes_used,
|
|
40107
|
6287 doc: /* Number of bytes of sharable Lisp data allocated so far. */);
|
|
39988
|
6288
|
|
|
6289 DEFVAR_INT ("cons-cells-consed", &cons_cells_consed,
|
|
40107
|
6290 doc: /* Number of cons cells that have been consed so far. */);
|
|
39988
|
6291
|
|
|
6292 DEFVAR_INT ("floats-consed", &floats_consed,
|
|
40107
|
6293 doc: /* Number of floats that have been consed so far. */);
|
|
39988
|
6294
|
|
|
6295 DEFVAR_INT ("vector-cells-consed", &vector_cells_consed,
|
|
40107
|
6296 doc: /* Number of vector cells that have been consed so far. */);
|
|
39988
|
6297
|
|
|
6298 DEFVAR_INT ("symbols-consed", &symbols_consed,
|
|
40107
|
6299 doc: /* Number of symbols that have been consed so far. */);
|
|
39988
|
6300
|
|
|
6301 DEFVAR_INT ("string-chars-consed", &string_chars_consed,
|
|
40107
|
6302 doc: /* Number of string characters that have been consed so far. */);
|
|
39988
|
6303
|
|
|
6304 DEFVAR_INT ("misc-objects-consed", &misc_objects_consed,
|
|
40107
|
6305 doc: /* Number of miscellaneous objects that have been consed so far. */);
|
|
39988
|
6306
|
|
|
6307 DEFVAR_INT ("intervals-consed", &intervals_consed,
|
|
40107
|
6308 doc: /* Number of intervals that have been consed so far. */);
|
|
39988
|
6309
|
|
|
6310 DEFVAR_INT ("strings-consed", &strings_consed,
|
|
40107
|
6311 doc: /* Number of strings that have been consed so far. */);
|
|
39988
|
6312
|
|
|
6313 DEFVAR_LISP ("purify-flag", &Vpurify_flag,
|
|
40107
|
6314 doc: /* Non-nil means loading Lisp code in order to dump an executable.
|
|
39914
|
6315 This means that certain objects should be allocated in shared (pure) space. */);
|
|
|
6316
|
|
39988
|
6317 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages,
|
|
40107
|
6318 doc: /* Non-nil means display messages at start and end of garbage collection. */);
|
|
14959
|
6319 garbage_collection_messages = 0;
|
|
|
6320
|
|
39988
|
6321 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook,
|
|
40107
|
6322 doc: /* Hook run after garbage collection has finished. */);
|
|
39572
|
6323 Vpost_gc_hook = Qnil;
|
|
|
6324 Qpost_gc_hook = intern ("post-gc-hook");
|
|
|
6325 staticpro (&Qpost_gc_hook);
|
|
|
6326
|
|
46305
|
6327 DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data,
|
|
|
6328 doc: /* Precomputed `signal' argument for memory-full error. */);
|
6116
64417bbbb128
(memory_full): Use new variable memory_signal_data with precomputed value
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
6329 /* We build this in advance because if we wait until we need it, we might
|
64417bbbb128
(memory_full): Use new variable memory_signal_data with precomputed value
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
6330 not be able to allocate the memory to hold it. */
|
|
46305
|
6331 Vmemory_signal_data
|
|
|
6332 = list2 (Qerror,
|
|
|
6333 build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs"));
|
|
|
6334
|
|
|
6335 DEFVAR_LISP ("memory-full", &Vmemory_full,
|
|
66530
|
6336 doc: /* Non-nil means Emacs cannot get much more Lisp memory. */);
|
|
46305
|
6337 Vmemory_full = Qnil;
|
6116
64417bbbb128
(memory_full): Use new variable memory_signal_data with precomputed value
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
6338
|
|
11374
|
6339 staticpro (&Qgc_cons_threshold);
|
|
|
6340 Qgc_cons_threshold = intern ("gc-cons-threshold");
|
|
|
6341
|
|
13219
|
6342 staticpro (&Qchar_table_extra_slots);
|
|
|
6343 Qchar_table_extra_slots = intern ("char-table-extra-slots");
|
|
|
6344
|
|
49529
|
6345 DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed,
|
|
|
6346 doc: /* Accumulated time elapsed in garbage collections.
|
|
51974
|
6347 The time is in seconds as a floating point value. */);
|
|
49529
|
6348 DEFVAR_INT ("gcs-done", &gcs_done,
|
|
51974
|
6349 doc: /* Accumulated number of garbage collections done. */);
|
|
49529
|
6350
|
|
300
|
6351 defsubr (&Scons);
|
|
|
6352 defsubr (&Slist);
|
|
|
6353 defsubr (&Svector);
|
|
|
6354 defsubr (&Smake_byte_code);
|
|
|
6355 defsubr (&Smake_list);
|
|
|
6356 defsubr (&Smake_vector);
|
|
13141
|
6357 defsubr (&Smake_char_table);
|
|
300
|
6358 defsubr (&Smake_string);
|
|
13141
|
6359 defsubr (&Smake_bool_vector);
|
|
300
|
6360 defsubr (&Smake_symbol);
|
|
|
6361 defsubr (&Smake_marker);
|
|
|
6362 defsubr (&Spurecopy);
|
|
|
6363 defsubr (&Sgarbage_collect);
|
|
1327
|
6364 defsubr (&Smemory_limit);
|
|
12748
|
6365 defsubr (&Smemory_use_counts);
|
|
27738
|
6366
|
|
|
6367 #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
|
|
|
6368 defsubr (&Sgc_status);
|
|
|
6369 #endif
|
|
300
|
6370 }
|
|
52401
|
6371
|
|
|
6372 /* arch-tag: 6695ca10-e3c5-4c2c-8bc3-ed26a7dda857
|
|
|
6373 (do not change this comment) */
|
