Mercurial > hg > xemacs-beta
annotate src/alloc.c @ 2500:3d8143fc88e1
[xemacs-hg @ 2005-01-24 23:33:30 by ben]
get working with VC7
config.inc.samp: Declare OPTIONAL_LIBRARY_DIR as root of library directories.
Redo all graphics library defaults to mirror the versions and
directories in the current binary aux distribution on xemacs
web site. Enable TIFF and COMPFACE by default since you can
now compile with them and binary libs are provided.
xemacs.mak: Put our own directories first in case of conflict (e.g. config.h
in compface).
xemacs.mak: Use MSVCRT to avoid link problems.
s/windowsnt.h:
bytecode.c, print.c: Add casts to avoid warning.
compiler.h: Add MSC_VERSION and include definitions of DOESNT_RETURN and
friends here, like for GCC. Need different definitions for VC7
and VC6.
s/windowsnt.h: Remove stuff moved to compiler.h. Disable warning 4646 ("function
declared with __declspec(noreturn) has non-void return type")
on VC7 since lots of Lisp primitives trigger this and there is
no easy way to kludge around the warning.
glyphs-eimage.c: Some really nasty hacks to allow TIFF and JPEG to both be compiled.
#### The better solution is to move the TIFF and JPEG code to
different files.
glyphs-msw.c: Define __STDC__ to avoid problems with compface.h.
intl-auto-encap-win32.c, intl-auto-encap-win32.h, intl-encap-win32.c, syswindows.h: Those wankers at Microsoft cannot leave well enough alone.
Various functions change parameter types semi-randomly between
VC6 and VC7, so we need to include our own versions that
can handle both kinds with appropriate casting.
EmacsFrame.c, EmacsShell-sub.c, EmacsShell.c, alloc.c, alloca.c, buffer.c, bytecode.c, charset.h, chartab.c, cm.c, console-stream.c, console.c, data.c, debug.h, device-msw.c, device-tty.c, device-x.c, doprnt.c, dumper.c, dynarr.c, elhash.c, emacs.c, eval.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, events.c, extents.c, faces.c, file-coding.c, fileio.c, fns.c, font-lock.c, frame-gtk.c, frame-x.c, frame.c, free-hook.c, gccache-gtk.c, glyphs-eimage.c, glyphs-gtk.c, glyphs-msw.c, glyphs-x.c, glyphs.c, gtk-glue.c, gutter.c, input-method-xlib.c, insdel.c, intl-win32.c, keymap.c, lisp.h, lread.c, lstream.c, macros.c, malloc.c, menubar-gtk.c, menubar-msw.c, menubar-x.c, mule-coding.c, native-gtk-toolbar.c, number.c, objects-msw.c, objects.c, print.c, process-nt.c, process-unix.c, process.c, ralloc.c, rangetab.c, redisplay-gtk.c, redisplay-msw.c, redisplay-output.c, redisplay-tty.c, redisplay-x.c, redisplay.c, regex.c, scrollbar-gtk.c, scrollbar-x.c, search.c, select-x.c, signal.c, specifier.c, specifier.h, strftime.c, sunplay.c, symbols.c, sysdep.c, sysproc.h, text.c, text.h, toolbar-common.c, toolbar-msw.c, toolbar.c, ui-gtk.c, unexnt.c, unicode.c, win32.c, window.c, xgccache.c, s/windowsnt.h: abort() -> ABORT(). Eliminate preprocessor games with abort()
since it creates huge problems in VC7, solvable only by including
massive amounts of files in every compile (and not worth it).
| author | ben |
|---|---|
| date | Mon, 24 Jan 2005 23:34:34 +0000 |
| parents | ecf1ebac70d8 |
| children | 989a7680c221 |
| rev | line source |
|---|---|
| 428 | 1 /* Storage allocation and gc for XEmacs Lisp interpreter. |
| 2 Copyright (C) 1985-1998 Free Software Foundation, Inc. | |
| 3 Copyright (C) 1995 Sun Microsystems, Inc. | |
| 2367 | 4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004 Ben Wing. |
| 428 | 5 |
| 6 This file is part of XEmacs. | |
| 7 | |
| 8 XEmacs is free software; you can redistribute it and/or modify it | |
| 9 under the terms of the GNU General Public License as published by the | |
| 10 Free Software Foundation; either version 2, or (at your option) any | |
| 11 later version. | |
| 12 | |
| 13 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 16 for more details. | |
| 17 | |
| 18 You should have received a copy of the GNU General Public License | |
| 19 along with XEmacs; see the file COPYING. If not, write to | |
| 20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 21 Boston, MA 02111-1307, USA. */ | |
| 22 | |
| 23 /* Synched up with: FSF 19.28, Mule 2.0. Substantially different from | |
| 24 FSF. */ | |
| 25 | |
| 26 /* Authorship: | |
| 27 | |
| 28 FSF: Original version; a long time ago. | |
| 29 Mly: Significantly rewritten to use new 3-bit tags and | |
| 30 nicely abstracted object definitions, for 19.8. | |
| 31 JWZ: Improved code to keep track of purespace usage and | |
| 32 issue nice purespace and GC stats. | |
| 33 Ben Wing: Cleaned up frob-block lrecord code, added error-checking | |
| 34 and various changes for Mule, for 19.12. | |
| 35 Added bit vectors for 19.13. | |
| 36 Added lcrecord lists for 19.14. | |
| 37 slb: Lots of work on the purification and dump time code. | |
| 38 Synched Doug Lea malloc support from Emacs 20.2. | |
| 442 | 39 og: Killed the purespace. Portable dumper (moved to dumper.c) |
| 428 | 40 */ |
| 41 | |
| 42 #include <config.h> | |
| 43 #include "lisp.h" | |
| 44 | |
| 45 #include "backtrace.h" | |
| 46 #include "buffer.h" | |
| 47 #include "bytecode.h" | |
| 48 #include "chartab.h" | |
| 49 #include "device.h" | |
| 50 #include "elhash.h" | |
| 51 #include "events.h" | |
| 872 | 52 #include "extents-impl.h" |
| 1204 | 53 #include "file-coding.h" |
| 872 | 54 #include "frame-impl.h" |
| 428 | 55 #include "glyphs.h" |
| 56 #include "opaque.h" | |
| 1204 | 57 #include "lstream.h" |
| 872 | 58 #include "process.h" |
| 1292 | 59 #include "profile.h" |
| 428 | 60 #include "redisplay.h" |
| 61 #include "specifier.h" | |
| 62 #include "sysfile.h" | |
| 442 | 63 #include "sysdep.h" |
| 428 | 64 #include "window.h" |
| 65 #include "console-stream.h" | |
| 66 | |
| 67 #ifdef DOUG_LEA_MALLOC | |
| 68 #include <malloc.h> | |
| 69 #endif | |
| 70 | |
| 71 EXFUN (Fgarbage_collect, 0); | |
| 72 | |
| 814 | 73 static void recompute_need_to_garbage_collect (void); |
| 74 | |
| 428 | 75 #if 0 /* this is _way_ too slow to be part of the standard debug options */ |
| 76 #if defined(DEBUG_XEMACS) && defined(MULE) | |
| 77 #define VERIFY_STRING_CHARS_INTEGRITY | |
| 78 #endif | |
| 79 #endif | |
| 80 | |
| 81 /* Define this to use malloc/free with no freelist for all datatypes, | |
| 82 the hope being that some debugging tools may help detect | |
| 83 freed memory references */ | |
| 84 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */ | |
| 85 #include <dmalloc.h> | |
| 86 #define ALLOC_NO_POOLS | |
| 87 #endif | |
| 88 | |
| 89 #ifdef DEBUG_XEMACS | |
| 458 | 90 static Fixnum debug_allocation; |
| 91 static Fixnum debug_allocation_backtrace_length; | |
| 428 | 92 #endif |
| 93 | |
| 94 /* Number of bytes of consing done since the last gc */ | |
| 814 | 95 static EMACS_INT consing_since_gc; |
| 1292 | 96 EMACS_UINT total_consing; |
| 97 | |
| 814 | 98 int need_to_garbage_collect; |
| 851 | 99 int need_to_check_c_alloca; |
| 887 | 100 int need_to_signal_post_gc; |
| 851 | 101 int funcall_allocation_flag; |
| 102 Bytecount __temp_alloca_size__; | |
| 103 Bytecount funcall_alloca_count; | |
| 814 | 104 |
| 105 /* Determine now whether we need to garbage collect or not, to make | |
| 106 Ffuncall() faster */ | |
| 107 #define INCREMENT_CONS_COUNTER_1(size) \ | |
| 108 do \ | |
| 109 { \ | |
| 110 consing_since_gc += (size); \ | |
| 1292 | 111 total_consing += (size); \ |
| 112 if (profiling_active) \ | |
| 113 profile_record_consing (size); \ | |
| 814 | 114 recompute_need_to_garbage_collect (); \ |
| 115 } while (0) | |
| 428 | 116 |
| 117 #define debug_allocation_backtrace() \ | |
| 118 do { \ | |
| 119 if (debug_allocation_backtrace_length > 0) \ | |
| 120 debug_short_backtrace (debug_allocation_backtrace_length); \ | |
| 121 } while (0) | |
| 122 | |
| 123 #ifdef DEBUG_XEMACS | |
| 801 | 124 #define INCREMENT_CONS_COUNTER(foosize, type) \ |
| 125 do { \ | |
| 126 if (debug_allocation) \ | |
| 127 { \ | |
| 128 stderr_out ("allocating %s (size %ld)\n", type, \ | |
| 129 (long) foosize); \ | |
| 130 debug_allocation_backtrace (); \ | |
| 131 } \ | |
| 132 INCREMENT_CONS_COUNTER_1 (foosize); \ | |
| 428 | 133 } while (0) |
| 134 #define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \ | |
| 135 do { \ | |
| 136 if (debug_allocation > 1) \ | |
| 137 { \ | |
| 801 | 138 stderr_out ("allocating noseeum %s (size %ld)\n", type, \ |
| 139 (long) foosize); \ | |
| 428 | 140 debug_allocation_backtrace (); \ |
| 141 } \ | |
| 142 INCREMENT_CONS_COUNTER_1 (foosize); \ | |
| 143 } while (0) | |
| 144 #else | |
| 145 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size) | |
| 146 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \ | |
| 147 INCREMENT_CONS_COUNTER_1 (size) | |
| 148 #endif | |
| 149 | |
| 150 #define DECREMENT_CONS_COUNTER(size) do { \ | |
| 151 consing_since_gc -= (size); \ | |
| 1292 | 152 total_consing -= (size); \ |
| 153 if (profiling_active) \ | |
| 154 profile_record_unconsing (size); \ | |
| 428 | 155 if (consing_since_gc < 0) \ |
| 156 consing_since_gc = 0; \ | |
| 814 | 157 recompute_need_to_garbage_collect (); \ |
| 428 | 158 } while (0) |
| 159 | |
| 160 /* Number of bytes of consing since gc before another gc should be done. */ | |
| 801 | 161 static EMACS_INT gc_cons_threshold; |
| 162 | |
| 163 /* Percentage of consing of total data size before another GC. */ | |
| 164 static EMACS_INT gc_cons_percentage; | |
| 165 | |
| 166 #ifdef ERROR_CHECK_GC | |
| 853 | 167 int always_gc; /* Debugging hack; equivalent to |
| 168 (setq gc-cons-thresold -1) */ | |
| 801 | 169 #else |
| 170 #define always_gc 0 | |
| 171 #endif | |
| 428 | 172 |
| 173 /* Nonzero during gc */ | |
| 174 int gc_in_progress; | |
| 175 | |
| 1154 | 176 /* Nonzero means display messages at beginning and end of GC. */ |
| 177 | |
| 178 int garbage_collection_messages; | |
| 179 | |
| 428 | 180 /* Number of times GC has happened at this level or below. |
| 181 * Level 0 is most volatile, contrary to usual convention. | |
| 182 * (Of course, there's only one level at present) */ | |
| 183 EMACS_INT gc_generation_number[1]; | |
| 184 | |
| 185 /* This is just for use by the printer, to allow things to print uniquely */ | |
| 186 static int lrecord_uid_counter; | |
| 187 | |
| 188 /* Nonzero when calling certain hooks or doing other things where | |
| 189 a GC would be bad */ | |
| 1957 | 190 int gc_currently_forbidden; |
| 428 | 191 |
| 192 /* Hooks. */ | |
| 193 Lisp_Object Vpre_gc_hook, Qpre_gc_hook; | |
| 194 Lisp_Object Vpost_gc_hook, Qpost_gc_hook; | |
| 195 | |
| 196 /* "Garbage collecting" */ | |
| 197 Lisp_Object Vgc_message; | |
| 198 Lisp_Object Vgc_pointer_glyph; | |
| 2367 | 199 static const Ascbyte gc_default_message[] = "Garbage collecting"; |
| 428 | 200 Lisp_Object Qgarbage_collecting; |
| 201 | |
| 1292 | 202 static Lisp_Object QSin_garbage_collection; |
| 203 | |
| 428 | 204 /* Non-zero means we're in the process of doing the dump */ |
| 205 int purify_flag; | |
| 206 | |
| 1204 | 207 /* Non-zero means we're pdumping out or in */ |
| 208 #ifdef PDUMP | |
| 209 int in_pdump; | |
| 210 #endif | |
| 211 | |
| 800 | 212 #ifdef ERROR_CHECK_TYPES |
| 428 | 213 |
| 793 | 214 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN; |
| 428 | 215 |
| 216 #endif | |
| 217 | |
| 801 | 218 /* Very cheesy ways of figuring out how much memory is being used for |
| 219 data. #### Need better (system-dependent) ways. */ | |
| 220 void *minimum_address_seen; | |
| 221 void *maximum_address_seen; | |
| 222 | |
| 428 | 223 int |
| 224 c_readonly (Lisp_Object obj) | |
| 225 { | |
| 226 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj); | |
| 227 } | |
| 228 | |
| 229 int | |
| 230 lisp_readonly (Lisp_Object obj) | |
| 231 { | |
| 232 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj); | |
| 233 } | |
| 234 | |
| 235 | |
| 236 /* Maximum amount of C stack to save when a GC happens. */ | |
| 237 | |
| 238 #ifndef MAX_SAVE_STACK | |
| 239 #define MAX_SAVE_STACK 0 /* 16000 */ | |
| 240 #endif | |
| 241 | |
| 242 /* Non-zero means ignore malloc warnings. Set during initialization. */ | |
| 243 int ignore_malloc_warnings; | |
| 244 | |
| 245 | |
| 246 static void *breathing_space; | |
| 247 | |
| 248 void | |
| 249 release_breathing_space (void) | |
| 250 { | |
| 251 if (breathing_space) | |
| 252 { | |
| 253 void *tmp = breathing_space; | |
| 254 breathing_space = 0; | |
| 1726 | 255 xfree (tmp, void *); |
| 428 | 256 } |
| 257 } | |
| 258 | |
| 259 /* malloc calls this if it finds we are near exhausting storage */ | |
| 260 void | |
| 442 | 261 malloc_warning (const char *str) |
| 428 | 262 { |
| 263 if (ignore_malloc_warnings) | |
| 264 return; | |
| 265 | |
| 266 warn_when_safe | |
| 793 | 267 (Qmemory, Qemergency, |
| 428 | 268 "%s\n" |
| 269 "Killing some buffers may delay running out of memory.\n" | |
| 270 "However, certainly by the time you receive the 95%% warning,\n" | |
| 271 "you should clean up, kill this Emacs, and start a new one.", | |
| 272 str); | |
| 273 } | |
| 274 | |
| 275 /* Called if malloc returns zero */ | |
| 276 DOESNT_RETURN | |
| 277 memory_full (void) | |
| 278 { | |
| 279 /* Force a GC next time eval is called. | |
| 280 It's better to loop garbage-collecting (we might reclaim enough | |
| 281 to win) than to loop beeping and barfing "Memory exhausted" | |
| 282 */ | |
| 283 consing_since_gc = gc_cons_threshold + 1; | |
| 814 | 284 recompute_need_to_garbage_collect (); |
| 428 | 285 release_breathing_space (); |
| 286 | |
| 287 /* Flush some histories which might conceivably contain garbalogical | |
| 288 inhibitors. */ | |
| 289 if (!NILP (Fboundp (Qvalues))) | |
| 290 Fset (Qvalues, Qnil); | |
| 291 Vcommand_history = Qnil; | |
| 292 | |
| 563 | 293 out_of_memory ("Memory exhausted", Qunbound); |
| 428 | 294 } |
| 295 | |
| 801 | 296 static void |
| 297 set_alloc_mins_and_maxes (void *val, Bytecount size) | |
| 298 { | |
| 299 if (!val) | |
| 300 return; | |
| 301 if ((char *) val + size > (char *) maximum_address_seen) | |
| 302 maximum_address_seen = (char *) val + size; | |
| 303 if (!minimum_address_seen) | |
| 304 minimum_address_seen = | |
| 305 #if SIZEOF_VOID_P == 8 | |
| 306 (void *) 0xFFFFFFFFFFFFFFFF; | |
| 307 #else | |
| 308 (void *) 0xFFFFFFFF; | |
| 309 #endif | |
| 310 if ((char *) val < (char *) minimum_address_seen) | |
| 311 minimum_address_seen = (char *) val; | |
| 312 } | |
| 313 | |
| 1315 | 314 #ifdef ERROR_CHECK_MALLOC |
| 1292 | 315 static int in_malloc; |
| 1333 | 316 extern int regex_malloc_disallowed; |
| 2367 | 317 |
| 318 #define MALLOC_BEGIN() \ | |
| 319 do \ | |
| 320 { \ | |
| 321 assert (!in_malloc); \ | |
| 322 assert (!regex_malloc_disallowed); \ | |
| 323 in_malloc = 1; \ | |
| 324 } \ | |
| 325 while (0) | |
| 326 | |
| 327 #define FREE_OR_REALLOC_BEGIN(block) \ | |
| 328 do \ | |
| 329 { \ | |
| 330 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
| 331 error until much later on for many system mallocs, such as \ | |
| 332 the one that comes with Solaris 2.3. FMH!! */ \ | |
| 333 assert (block != (void *) 0xDEADBEEF); \ | |
| 334 /* You cannot free something within dumped space, because there is \ | |
| 335 no longer any sort of malloc structure associated with the block. \ | |
| 336 If you are tripping this, you may need to conditionalize on \ | |
| 337 DUMPEDP. */ \ | |
| 338 assert (!DUMPEDP (block)); \ | |
| 339 MALLOC_BEGIN (); \ | |
| 340 } \ | |
| 341 while (0) | |
| 342 | |
| 343 #define MALLOC_END() \ | |
| 344 do \ | |
| 345 { \ | |
| 346 in_malloc = 0; \ | |
| 347 } \ | |
| 348 while (0) | |
| 349 | |
| 350 #else /* ERROR_CHECK_MALLOC */ | |
| 351 | |
| 352 #define MALLOC_BEGIN(block) | |
| 353 #define FREE_OR_REALLOC_BEGIN(block) | |
| 354 #define MALLOC_END() | |
| 355 | |
| 356 #endif /* ERROR_CHECK_MALLOC */ | |
| 357 | |
| 358 static void | |
| 359 malloc_after (void *val, Bytecount size) | |
| 360 { | |
| 361 if (!val && size != 0) | |
| 362 memory_full (); | |
| 363 set_alloc_mins_and_maxes (val, size); | |
| 364 } | |
| 365 | |
| 366 /* like malloc, calloc, realloc, free but: | |
| 367 | |
| 368 -- check for no memory left | |
| 369 -- set internal mins and maxes | |
| 370 -- with error-checking on, check for reentrancy, invalid freeing, etc. | |
| 371 */ | |
| 1292 | 372 |
| 428 | 373 #undef xmalloc |
| 374 void * | |
| 665 | 375 xmalloc (Bytecount size) |
| 428 | 376 { |
| 1292 | 377 void *val; |
| 2367 | 378 MALLOC_BEGIN (); |
| 1292 | 379 val = malloc (size); |
| 2367 | 380 MALLOC_END (); |
| 381 malloc_after (val, size); | |
| 428 | 382 return val; |
| 383 } | |
| 384 | |
| 385 #undef xcalloc | |
| 386 static void * | |
| 665 | 387 xcalloc (Elemcount nelem, Bytecount elsize) |
| 428 | 388 { |
| 1292 | 389 void *val; |
| 2367 | 390 MALLOC_BEGIN (); |
| 1292 | 391 val= calloc (nelem, elsize); |
| 2367 | 392 MALLOC_END (); |
| 393 malloc_after (val, nelem * elsize); | |
| 428 | 394 return val; |
| 395 } | |
| 396 | |
| 397 void * | |
| 665 | 398 xmalloc_and_zero (Bytecount size) |
| 428 | 399 { |
| 400 return xcalloc (size, sizeof (char)); | |
| 401 } | |
| 402 | |
| 403 #undef xrealloc | |
| 404 void * | |
| 665 | 405 xrealloc (void *block, Bytecount size) |
| 428 | 406 { |
| 2367 | 407 FREE_OR_REALLOC_BEGIN (block); |
| 551 | 408 block = realloc (block, size); |
| 2367 | 409 MALLOC_END (); |
| 410 malloc_after (block, size); | |
| 551 | 411 return block; |
| 428 | 412 } |
| 413 | |
| 414 void | |
| 415 xfree_1 (void *block) | |
| 416 { | |
| 417 #ifdef ERROR_CHECK_MALLOC | |
| 418 assert (block); | |
| 419 #endif /* ERROR_CHECK_MALLOC */ | |
| 2367 | 420 FREE_OR_REALLOC_BEGIN (block); |
| 428 | 421 free (block); |
| 2367 | 422 MALLOC_END (); |
| 428 | 423 } |
| 424 | |
| 425 #ifdef ERROR_CHECK_GC | |
| 426 | |
| 427 static void | |
| 665 | 428 deadbeef_memory (void *ptr, Bytecount size) |
| 428 | 429 { |
| 826 | 430 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr; |
| 665 | 431 Bytecount beefs = size >> 2; |
| 428 | 432 |
| 433 /* In practice, size will always be a multiple of four. */ | |
| 434 while (beefs--) | |
| 1204 | 435 (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */ |
| 428 | 436 } |
| 437 | |
| 438 #else /* !ERROR_CHECK_GC */ | |
| 439 | |
| 440 | |
| 441 #define deadbeef_memory(ptr, size) | |
| 442 | |
| 443 #endif /* !ERROR_CHECK_GC */ | |
| 444 | |
| 445 #undef xstrdup | |
| 446 char * | |
| 442 | 447 xstrdup (const char *str) |
| 428 | 448 { |
| 449 int len = strlen (str) + 1; /* for stupid terminating 0 */ | |
| 450 void *val = xmalloc (len); | |
| 771 | 451 |
| 428 | 452 if (val == 0) return 0; |
| 453 return (char *) memcpy (val, str, len); | |
| 454 } | |
| 455 | |
| 456 #ifdef NEED_STRDUP | |
| 457 char * | |
| 442 | 458 strdup (const char *s) |
| 428 | 459 { |
| 460 return xstrdup (s); | |
| 461 } | |
| 462 #endif /* NEED_STRDUP */ | |
| 463 | |
| 464 | |
| 465 static void * | |
| 665 | 466 allocate_lisp_storage (Bytecount size) |
| 428 | 467 { |
| 793 | 468 void *val = xmalloc (size); |
| 469 /* We don't increment the cons counter anymore. Calling functions do | |
| 470 that now because we have two different kinds of cons counters -- one | |
| 471 for normal objects, and one for no-see-um conses (and possibly others | |
| 472 similar) where the conses are used totally internally, never escape, | |
| 473 and are created and then freed and shouldn't logically increment the | |
| 474 cons counting. #### (Or perhaps, we should decrement it when an object | |
| 475 get freed?) */ | |
| 476 | |
| 477 /* But we do now (as of 3-27-02) go and zero out the memory. This is a | |
| 478 good thing, as it will guarantee we won't get any intermittent bugs | |
| 1204 | 479 coming from an uninitiated field. The speed loss is unnoticeable, |
| 480 esp. as the objects are not large -- large stuff like buffer text and | |
| 481 redisplay structures are allocated separately. */ | |
| 793 | 482 memset (val, 0, size); |
| 851 | 483 |
| 484 if (need_to_check_c_alloca) | |
| 485 xemacs_c_alloca (0); | |
| 486 | |
| 793 | 487 return val; |
| 428 | 488 } |
| 489 | |
| 490 | |
| 442 | 491 /* lcrecords are chained together through their "next" field. |
| 492 After doing the mark phase, GC will walk this linked list | |
| 493 and free any lcrecord which hasn't been marked. */ | |
| 428 | 494 static struct lcrecord_header *all_lcrecords; |
| 495 | |
| 1204 | 496 /* The most basic of the lcrecord allocation functions. Not usually called |
| 497 directly. Allocates an lrecord not managed by any lcrecord-list, of a | |
| 498 specified size. See lrecord.h. */ | |
| 499 | |
| 428 | 500 void * |
| 1204 | 501 basic_alloc_lcrecord (Bytecount size, |
| 502 const struct lrecord_implementation *implementation) | |
| 428 | 503 { |
| 504 struct lcrecord_header *lcheader; | |
| 505 | |
| 442 | 506 type_checking_assert |
| 507 ((implementation->static_size == 0 ? | |
| 508 implementation->size_in_bytes_method != NULL : | |
| 509 implementation->static_size == size) | |
| 510 && | |
| 511 (! implementation->basic_p) | |
| 512 && | |
| 513 (! (implementation->hash == NULL && implementation->equal != NULL))); | |
| 428 | 514 |
| 515 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size); | |
| 442 | 516 set_lheader_implementation (&lcheader->lheader, implementation); |
| 428 | 517 lcheader->next = all_lcrecords; |
| 518 #if 1 /* mly prefers to see small ID numbers */ | |
| 519 lcheader->uid = lrecord_uid_counter++; | |
| 520 #else /* jwz prefers to see real addrs */ | |
| 521 lcheader->uid = (int) &lcheader; | |
| 522 #endif | |
| 523 lcheader->free = 0; | |
| 524 all_lcrecords = lcheader; | |
| 525 INCREMENT_CONS_COUNTER (size, implementation->name); | |
| 526 return lcheader; | |
| 527 } | |
| 528 | |
| 529 #if 0 /* Presently unused */ | |
| 530 /* Very, very poor man's EGC? | |
| 531 * This may be slow and thrash pages all over the place. | |
| 532 * Only call it if you really feel you must (and if the | |
| 533 * lrecord was fairly recently allocated). | |
| 534 * Otherwise, just let the GC do its job -- that's what it's there for | |
| 535 */ | |
| 536 void | |
| 771 | 537 very_old_free_lcrecord (struct lcrecord_header *lcrecord) |
| 428 | 538 { |
| 539 if (all_lcrecords == lcrecord) | |
| 540 { | |
| 541 all_lcrecords = lcrecord->next; | |
| 542 } | |
| 543 else | |
| 544 { | |
| 545 struct lrecord_header *header = all_lcrecords; | |
| 546 for (;;) | |
| 547 { | |
| 548 struct lrecord_header *next = header->next; | |
| 549 if (next == lcrecord) | |
| 550 { | |
| 551 header->next = lrecord->next; | |
| 552 break; | |
| 553 } | |
| 554 else if (next == 0) | |
| 2500 | 555 ABORT (); |
| 428 | 556 else |
| 557 header = next; | |
| 558 } | |
| 559 } | |
| 560 if (lrecord->implementation->finalizer) | |
| 561 lrecord->implementation->finalizer (lrecord, 0); | |
| 562 xfree (lrecord); | |
| 563 return; | |
| 564 } | |
| 565 #endif /* Unused */ | |
| 566 | |
| 567 | |
| 568 static void | |
| 569 disksave_object_finalization_1 (void) | |
| 570 { | |
| 571 struct lcrecord_header *header; | |
| 572 | |
| 573 for (header = all_lcrecords; header; header = header->next) | |
| 574 { | |
| 442 | 575 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer && |
| 428 | 576 !header->free) |
| 442 | 577 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1); |
| 428 | 578 } |
| 579 } | |
| 580 | |
| 1204 | 581 /* Bitwise copy all parts of a Lisp object other than the header */ |
| 582 | |
| 583 void | |
| 584 copy_lisp_object (Lisp_Object dst, Lisp_Object src) | |
| 585 { | |
| 586 const struct lrecord_implementation *imp = | |
| 587 XRECORD_LHEADER_IMPLEMENTATION (src); | |
| 588 Bytecount size = lisp_object_size (src); | |
| 589 | |
| 590 assert (imp == XRECORD_LHEADER_IMPLEMENTATION (dst)); | |
| 591 assert (size == lisp_object_size (dst)); | |
| 592 | |
| 593 if (imp->basic_p) | |
| 594 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), | |
| 595 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
| 596 size - sizeof (struct lrecord_header)); | |
| 597 else | |
| 598 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lcrecord_header), | |
| 599 (char *) XRECORD_LHEADER (src) + sizeof (struct lcrecord_header), | |
| 600 size - sizeof (struct lcrecord_header)); | |
| 601 } | |
| 602 | |
| 428 | 603 |
| 604 /************************************************************************/ | |
| 605 /* Debugger support */ | |
| 606 /************************************************************************/ | |
| 607 /* Give gdb/dbx enough information to decode Lisp Objects. We make | |
| 608 sure certain symbols are always defined, so gdb doesn't complain | |
| 438 | 609 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc |
| 610 to see how this is used. */ | |
| 428 | 611 |
| 458 | 612 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS; |
| 613 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1; | |
| 428 | 614 |
| 615 #ifdef USE_UNION_TYPE | |
| 458 | 616 unsigned char dbg_USE_UNION_TYPE = 1; |
| 428 | 617 #else |
| 458 | 618 unsigned char dbg_USE_UNION_TYPE = 0; |
| 428 | 619 #endif |
| 620 | |
| 458 | 621 unsigned char dbg_valbits = VALBITS; |
| 622 unsigned char dbg_gctypebits = GCTYPEBITS; | |
| 623 | |
| 624 /* On some systems, the above definitions will be optimized away by | |
| 625 the compiler or linker unless they are referenced in some function. */ | |
| 626 long dbg_inhibit_dbg_symbol_deletion (void); | |
| 627 long | |
| 628 dbg_inhibit_dbg_symbol_deletion (void) | |
| 629 { | |
| 630 return | |
| 631 (dbg_valmask + | |
| 632 dbg_typemask + | |
| 633 dbg_USE_UNION_TYPE + | |
| 634 dbg_valbits + | |
| 635 dbg_gctypebits); | |
| 636 } | |
| 428 | 637 |
| 638 /* Macros turned into functions for ease of debugging. | |
| 639 Debuggers don't know about macros! */ | |
| 640 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); | |
| 641 int | |
| 642 dbg_eq (Lisp_Object obj1, Lisp_Object obj2) | |
| 643 { | |
| 644 return EQ (obj1, obj2); | |
| 645 } | |
| 646 | |
| 647 | |
| 648 /************************************************************************/ | |
| 649 /* Fixed-size type macros */ | |
| 650 /************************************************************************/ | |
| 651 | |
| 652 /* For fixed-size types that are commonly used, we malloc() large blocks | |
| 653 of memory at a time and subdivide them into chunks of the correct | |
| 654 size for an object of that type. This is more efficient than | |
| 655 malloc()ing each object separately because we save on malloc() time | |
| 656 and overhead due to the fewer number of malloc()ed blocks, and | |
| 657 also because we don't need any extra pointers within each object | |
| 658 to keep them threaded together for GC purposes. For less common | |
| 659 (and frequently large-size) types, we use lcrecords, which are | |
| 660 malloc()ed individually and chained together through a pointer | |
| 661 in the lcrecord header. lcrecords do not need to be fixed-size | |
| 662 (i.e. two objects of the same type need not have the same size; | |
| 663 however, the size of a particular object cannot vary dynamically). | |
| 664 It is also much easier to create a new lcrecord type because no | |
| 665 additional code needs to be added to alloc.c. Finally, lcrecords | |
| 666 may be more efficient when there are only a small number of them. | |
| 667 | |
| 668 The types that are stored in these large blocks (or "frob blocks") | |
| 1983 | 669 are cons, all number types except fixnum, compiled-function, symbol, |
| 670 marker, extent, event, and string. | |
| 428 | 671 |
| 672 Note that strings are special in that they are actually stored in | |
| 673 two parts: a structure containing information about the string, and | |
| 674 the actual data associated with the string. The former structure | |
| 675 (a struct Lisp_String) is a fixed-size structure and is managed the | |
| 676 same way as all the other such types. This structure contains a | |
| 677 pointer to the actual string data, which is stored in structures of | |
| 678 type struct string_chars_block. Each string_chars_block consists | |
| 679 of a pointer to a struct Lisp_String, followed by the data for that | |
| 440 | 680 string, followed by another pointer to a Lisp_String, followed by |
| 681 the data for that string, etc. At GC time, the data in these | |
| 682 blocks is compacted by searching sequentially through all the | |
| 428 | 683 blocks and compressing out any holes created by unmarked strings. |
| 684 Strings that are more than a certain size (bigger than the size of | |
| 685 a string_chars_block, although something like half as big might | |
| 686 make more sense) are malloc()ed separately and not stored in | |
| 687 string_chars_blocks. Furthermore, no one string stretches across | |
| 688 two string_chars_blocks. | |
| 689 | |
| 1204 | 690 Vectors are each malloc()ed separately as lcrecords. |
| 428 | 691 |
| 692 In the following discussion, we use conses, but it applies equally | |
| 693 well to the other fixed-size types. | |
| 694 | |
| 695 We store cons cells inside of cons_blocks, allocating a new | |
| 696 cons_block with malloc() whenever necessary. Cons cells reclaimed | |
| 697 by GC are put on a free list to be reallocated before allocating | |
| 698 any new cons cells from the latest cons_block. Each cons_block is | |
| 699 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least | |
| 700 the versions in malloc.c and gmalloc.c) really allocates in units | |
| 701 of powers of two and uses 4 bytes for its own overhead. | |
| 702 | |
| 703 What GC actually does is to search through all the cons_blocks, | |
| 704 from the most recently allocated to the oldest, and put all | |
| 705 cons cells that are not marked (whether or not they're already | |
| 706 free) on a cons_free_list. The cons_free_list is a stack, and | |
| 707 so the cons cells in the oldest-allocated cons_block end up | |
| 708 at the head of the stack and are the first to be reallocated. | |
| 709 If any cons_block is entirely free, it is freed with free() | |
| 710 and its cons cells removed from the cons_free_list. Because | |
| 711 the cons_free_list ends up basically in memory order, we have | |
| 712 a high locality of reference (assuming a reasonable turnover | |
| 713 of allocating and freeing) and have a reasonable probability | |
| 714 of entirely freeing up cons_blocks that have been more recently | |
| 715 allocated. This stage is called the "sweep stage" of GC, and | |
| 716 is executed after the "mark stage", which involves starting | |
| 717 from all places that are known to point to in-use Lisp objects | |
| 718 (e.g. the obarray, where are all symbols are stored; the | |
| 719 current catches and condition-cases; the backtrace list of | |
| 720 currently executing functions; the gcpro list; etc.) and | |
| 721 recursively marking all objects that are accessible. | |
| 722 | |
| 454 | 723 At the beginning of the sweep stage, the conses in the cons blocks |
| 724 are in one of three states: in use and marked, in use but not | |
| 725 marked, and not in use (already freed). Any conses that are marked | |
| 726 have been marked in the mark stage just executed, because as part | |
| 727 of the sweep stage we unmark any marked objects. The way we tell | |
| 728 whether or not a cons cell is in use is through the LRECORD_FREE_P | |
| 729 macro. This uses a special lrecord type `lrecord_type_free', | |
| 730 which is never associated with any valid object. | |
| 731 | |
| 732 Conses on the free_cons_list are threaded through a pointer stored | |
| 733 in the conses themselves. Because the cons is still in a | |
| 734 cons_block and needs to remain marked as not in use for the next | |
| 735 time that GC happens, we need room to store both the "free" | |
| 736 indicator and the chaining pointer. So this pointer is stored | |
| 737 after the lrecord header (actually where C places a pointer after | |
| 738 the lrecord header; they are not necessarily contiguous). This | |
| 739 implies that all fixed-size types must be big enough to contain at | |
| 740 least one pointer. This is true for all current fixed-size types, | |
| 741 with the possible exception of Lisp_Floats, for which we define the | |
| 742 meat of the struct using a union of a pointer and a double to | |
| 743 ensure adequate space for the free list chain pointer. | |
| 428 | 744 |
| 745 Some types of objects need additional "finalization" done | |
| 746 when an object is converted from in use to not in use; | |
| 747 this is the purpose of the ADDITIONAL_FREE_type macro. | |
| 748 For example, markers need to be removed from the chain | |
| 749 of markers that is kept in each buffer. This is because | |
| 750 markers in a buffer automatically disappear if the marker | |
| 751 is no longer referenced anywhere (the same does not | |
| 752 apply to extents, however). | |
| 753 | |
| 754 WARNING: Things are in an extremely bizarre state when | |
| 755 the ADDITIONAL_FREE_type macros are called, so beware! | |
| 756 | |
| 454 | 757 When ERROR_CHECK_GC is defined, we do things differently so as to |
| 758 maximize our chances of catching places where there is insufficient | |
| 759 GCPROing. The thing we want to avoid is having an object that | |
| 760 we're using but didn't GCPRO get freed by GC and then reallocated | |
| 761 while we're in the process of using it -- this will result in | |
| 762 something seemingly unrelated getting trashed, and is extremely | |
| 763 difficult to track down. If the object gets freed but not | |
| 764 reallocated, we can usually catch this because we set most of the | |
| 765 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set | |
| 766 to the invalid type `lrecord_type_free', however, and a pointer | |
| 767 used to chain freed objects together is stored after the lrecord | |
| 768 header; we play some tricks with this pointer to make it more | |
| 428 | 769 bogus, so crashes are more likely to occur right away.) |
| 770 | |
| 771 We want freed objects to stay free as long as possible, | |
| 772 so instead of doing what we do above, we maintain the | |
| 773 free objects in a first-in first-out queue. We also | |
| 774 don't recompute the free list each GC, unlike above; | |
| 775 this ensures that the queue ordering is preserved. | |
| 776 [This means that we are likely to have worse locality | |
| 777 of reference, and that we can never free a frob block | |
| 778 once it's allocated. (Even if we know that all cells | |
| 779 in it are free, there's no easy way to remove all those | |
| 780 cells from the free list because the objects on the | |
| 781 free list are unlikely to be in memory order.)] | |
| 782 Furthermore, we never take objects off the free list | |
| 783 unless there's a large number (usually 1000, but | |
| 784 varies depending on type) of them already on the list. | |
| 785 This way, we ensure that an object that gets freed will | |
| 786 remain free for the next 1000 (or whatever) times that | |
| 440 | 787 an object of that type is allocated. */ |
| 428 | 788 |
| 789 #ifndef MALLOC_OVERHEAD | |
| 790 #ifdef GNU_MALLOC | |
| 791 #define MALLOC_OVERHEAD 0 | |
| 792 #elif defined (rcheck) | |
| 793 #define MALLOC_OVERHEAD 20 | |
| 794 #else | |
| 795 #define MALLOC_OVERHEAD 8 | |
| 796 #endif | |
| 797 #endif /* MALLOC_OVERHEAD */ | |
| 798 | |
| 799 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) | |
| 800 /* If we released our reserve (due to running out of memory), | |
| 801 and we have a fair amount free once again, | |
| 802 try to set aside another reserve in case we run out once more. | |
| 803 | |
| 804 This is called when a relocatable block is freed in ralloc.c. */ | |
| 805 void refill_memory_reserve (void); | |
| 806 void | |
| 442 | 807 refill_memory_reserve (void) |
| 428 | 808 { |
| 809 if (breathing_space == 0) | |
| 810 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); | |
| 811 } | |
| 812 #endif | |
| 813 | |
| 814 #ifdef ALLOC_NO_POOLS | |
| 815 # define TYPE_ALLOC_SIZE(type, structtype) 1 | |
| 816 #else | |
| 817 # define TYPE_ALLOC_SIZE(type, structtype) \ | |
| 818 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \ | |
| 819 / sizeof (structtype)) | |
| 820 #endif /* ALLOC_NO_POOLS */ | |
| 821 | |
| 822 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ | |
| 823 \ | |
| 824 struct type##_block \ | |
| 825 { \ | |
| 826 struct type##_block *prev; \ | |
| 827 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ | |
| 828 }; \ | |
| 829 \ | |
| 830 static struct type##_block *current_##type##_block; \ | |
| 831 static int current_##type##_block_index; \ | |
| 832 \ | |
| 454 | 833 static Lisp_Free *type##_free_list; \ |
| 834 static Lisp_Free *type##_free_list_tail; \ | |
| 428 | 835 \ |
| 836 static void \ | |
| 837 init_##type##_alloc (void) \ | |
| 838 { \ | |
| 839 current_##type##_block = 0; \ | |
| 840 current_##type##_block_index = \ | |
| 841 countof (current_##type##_block->block); \ | |
| 842 type##_free_list = 0; \ | |
| 843 type##_free_list_tail = 0; \ | |
| 844 } \ | |
| 845 \ | |
| 846 static int gc_count_num_##type##_in_use; \ | |
| 847 static int gc_count_num_##type##_freelist | |
| 848 | |
| 849 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ | |
| 850 if (current_##type##_block_index \ | |
| 851 == countof (current_##type##_block->block)) \ | |
| 852 { \ | |
| 853 struct type##_block *AFTFB_new = (struct type##_block *) \ | |
| 854 allocate_lisp_storage (sizeof (struct type##_block)); \ | |
| 855 AFTFB_new->prev = current_##type##_block; \ | |
| 856 current_##type##_block = AFTFB_new; \ | |
| 857 current_##type##_block_index = 0; \ | |
| 858 } \ | |
| 859 (result) = \ | |
| 860 &(current_##type##_block->block[current_##type##_block_index++]); \ | |
| 861 } while (0) | |
| 862 | |
| 863 /* Allocate an instance of a type that is stored in blocks. | |
| 864 TYPE is the "name" of the type, STRUCTTYPE is the corresponding | |
| 865 structure type. */ | |
| 866 | |
| 867 #ifdef ERROR_CHECK_GC | |
| 868 | |
| 869 /* Note: if you get crashes in this function, suspect incorrect calls | |
| 870 to free_cons() and friends. This happened once because the cons | |
| 871 cell was not GC-protected and was getting collected before | |
| 872 free_cons() was called. */ | |
| 873 | |
| 454 | 874 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
| 875 if (gc_count_num_##type##_freelist > \ | |
| 876 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \ | |
| 877 { \ | |
| 878 result = (structtype *) type##_free_list; \ | |
| 1204 | 879 assert (LRECORD_FREE_P (result)); \ |
| 880 /* Before actually using the chain pointer, we complement \ | |
| 881 all its bits; see PUT_FIXED_TYPE_ON_FREE_LIST(). */ \ | |
| 454 | 882 type##_free_list = (Lisp_Free *) \ |
| 883 (~ (EMACS_UINT) (type##_free_list->chain)); \ | |
| 884 gc_count_num_##type##_freelist--; \ | |
| 885 } \ | |
| 886 else \ | |
| 887 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
| 888 MARK_LRECORD_AS_NOT_FREE (result); \ | |
| 428 | 889 } while (0) |
| 890 | |
| 891 #else /* !ERROR_CHECK_GC */ | |
| 892 | |
| 454 | 893 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
| 428 | 894 if (type##_free_list) \ |
| 895 { \ | |
| 454 | 896 result = (structtype *) type##_free_list; \ |
| 897 type##_free_list = type##_free_list->chain; \ | |
| 428 | 898 } \ |
| 899 else \ | |
| 900 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
| 454 | 901 MARK_LRECORD_AS_NOT_FREE (result); \ |
| 428 | 902 } while (0) |
| 903 | |
| 904 #endif /* !ERROR_CHECK_GC */ | |
| 905 | |
| 454 | 906 |
| 428 | 907 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \ |
| 908 do \ | |
| 909 { \ | |
| 910 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
| 911 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
| 912 } while (0) | |
| 913 | |
| 914 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \ | |
| 915 do \ | |
| 916 { \ | |
| 917 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
| 918 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
| 919 } while (0) | |
| 920 | |
| 454 | 921 |
| 922 /* Lisp_Free is the type to represent a free list member inside a frob | |
| 923 block of any lisp object type. */ | |
| 924 typedef struct Lisp_Free | |
| 925 { | |
| 926 struct lrecord_header lheader; | |
| 927 struct Lisp_Free *chain; | |
| 928 } Lisp_Free; | |
| 929 | |
| 930 #define LRECORD_FREE_P(ptr) \ | |
| 771 | 931 (((struct lrecord_header *) ptr)->type == lrecord_type_free) |
| 454 | 932 |
| 933 #define MARK_LRECORD_AS_FREE(ptr) \ | |
| 771 | 934 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free)) |
| 454 | 935 |
| 936 #ifdef ERROR_CHECK_GC | |
| 937 #define MARK_LRECORD_AS_NOT_FREE(ptr) \ | |
| 771 | 938 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined)) |
| 428 | 939 #else |
| 454 | 940 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING |
| 428 | 941 #endif |
| 942 | |
| 943 #ifdef ERROR_CHECK_GC | |
| 944 | |
| 454 | 945 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
| 946 if (type##_free_list_tail) \ | |
| 947 { \ | |
| 948 /* When we store the chain pointer, we complement all \ | |
| 949 its bits; this should significantly increase its \ | |
| 950 bogosity in case someone tries to use the value, and \ | |
| 951 should make us crash faster if someone overwrites the \ | |
| 952 pointer because when it gets un-complemented in \ | |
| 953 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \ | |
| 954 extremely bogus. */ \ | |
| 955 type##_free_list_tail->chain = \ | |
| 956 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \ | |
| 957 } \ | |
| 958 else \ | |
| 959 type##_free_list = (Lisp_Free *) (ptr); \ | |
| 960 type##_free_list_tail = (Lisp_Free *) (ptr); \ | |
| 961 } while (0) | |
| 428 | 962 |
| 963 #else /* !ERROR_CHECK_GC */ | |
| 964 | |
| 454 | 965 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
| 966 ((Lisp_Free *) (ptr))->chain = type##_free_list; \ | |
| 967 type##_free_list = (Lisp_Free *) (ptr); \ | |
| 968 } while (0) \ | |
| 428 | 969 |
| 970 #endif /* !ERROR_CHECK_GC */ | |
| 971 | |
| 972 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ | |
| 973 | |
| 974 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \ | |
| 975 structtype *FFT_ptr = (ptr); \ | |
| 1204 | 976 gc_checking_assert (!LRECORD_FREE_P (FFT_ptr)); \ |
| 2367 | 977 gc_checking_assert (!DUMPEDP (FFT_ptr)); \ |
| 428 | 978 ADDITIONAL_FREE_##type (FFT_ptr); \ |
| 979 deadbeef_memory (FFT_ptr, sizeof (structtype)); \ | |
| 980 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \ | |
| 454 | 981 MARK_LRECORD_AS_FREE (FFT_ptr); \ |
| 428 | 982 } while (0) |
| 983 | |
| 984 /* Like FREE_FIXED_TYPE() but used when we are explicitly | |
| 985 freeing a structure through free_cons(), free_marker(), etc. | |
| 986 rather than through the normal process of sweeping. | |
| 987 We attempt to undo the changes made to the allocation counters | |
| 988 as a result of this structure being allocated. This is not | |
| 989 completely necessary but helps keep things saner: e.g. this way, | |
| 990 repeatedly allocating and freeing a cons will not result in | |
| 991 the consing-since-gc counter advancing, which would cause a GC | |
| 1204 | 992 and somewhat defeat the purpose of explicitly freeing. |
| 993 | |
| 994 We also disable this mechanism entirely when ALLOC_NO_POOLS is | |
| 995 set, which is used for Purify and the like. */ | |
| 996 | |
| 997 #ifndef ALLOC_NO_POOLS | |
| 428 | 998 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \ |
| 999 do { FREE_FIXED_TYPE (type, structtype, ptr); \ | |
| 1000 DECREMENT_CONS_COUNTER (sizeof (structtype)); \ | |
| 1001 gc_count_num_##type##_freelist++; \ | |
| 1002 } while (0) | |
| 1204 | 1003 #else |
| 1004 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) | |
| 1005 #endif | |
| 428 | 1006 |
| 1007 | |
| 1008 | |
| 1009 /************************************************************************/ | |
| 1010 /* Cons allocation */ | |
| 1011 /************************************************************************/ | |
| 1012 | |
| 440 | 1013 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons); |
| 428 | 1014 /* conses are used and freed so often that we set this really high */ |
| 1015 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ | |
| 1016 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 | |
| 1017 | |
| 1018 static Lisp_Object | |
| 1019 mark_cons (Lisp_Object obj) | |
| 1020 { | |
| 1021 if (NILP (XCDR (obj))) | |
| 1022 return XCAR (obj); | |
| 1023 | |
| 1024 mark_object (XCAR (obj)); | |
| 1025 return XCDR (obj); | |
| 1026 } | |
| 1027 | |
| 1028 static int | |
| 1029 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) | |
| 1030 { | |
| 442 | 1031 depth++; |
| 1032 while (internal_equal (XCAR (ob1), XCAR (ob2), depth)) | |
| 428 | 1033 { |
| 1034 ob1 = XCDR (ob1); | |
| 1035 ob2 = XCDR (ob2); | |
| 1036 if (! CONSP (ob1) || ! CONSP (ob2)) | |
| 442 | 1037 return internal_equal (ob1, ob2, depth); |
| 428 | 1038 } |
| 1039 return 0; | |
| 1040 } | |
| 1041 | |
| 1204 | 1042 static const struct memory_description cons_description[] = { |
| 853 | 1043 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) }, |
| 1044 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) }, | |
| 428 | 1045 { XD_END } |
| 1046 }; | |
| 1047 | |
| 934 | 1048 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, |
| 1049 1, /*dumpable-flag*/ | |
| 1050 mark_cons, print_cons, 0, | |
| 1051 cons_equal, | |
| 1052 /* | |
| 1053 * No `hash' method needed. | |
| 1054 * internal_hash knows how to | |
| 1055 * handle conses. | |
| 1056 */ | |
| 1057 0, | |
| 1058 cons_description, | |
| 1059 Lisp_Cons); | |
| 428 | 1060 |
| 1061 DEFUN ("cons", Fcons, 2, 2, 0, /* | |
| 1062 Create a new cons, give it CAR and CDR as components, and return it. | |
| 1063 */ | |
| 1064 (car, cdr)) | |
| 1065 { | |
| 1066 /* This cannot GC. */ | |
| 1067 Lisp_Object val; | |
| 440 | 1068 Lisp_Cons *c; |
| 1069 | |
| 1070 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); | |
| 442 | 1071 set_lheader_implementation (&c->lheader, &lrecord_cons); |
| 793 | 1072 val = wrap_cons (c); |
| 853 | 1073 XSETCAR (val, car); |
| 1074 XSETCDR (val, cdr); | |
| 428 | 1075 return val; |
| 1076 } | |
| 1077 | |
| 1078 /* This is identical to Fcons() but it used for conses that we're | |
| 1079 going to free later, and is useful when trying to track down | |
| 1080 "real" consing. */ | |
| 1081 Lisp_Object | |
| 1082 noseeum_cons (Lisp_Object car, Lisp_Object cdr) | |
| 1083 { | |
| 1084 Lisp_Object val; | |
| 440 | 1085 Lisp_Cons *c; |
| 1086 | |
| 1087 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); | |
| 442 | 1088 set_lheader_implementation (&c->lheader, &lrecord_cons); |
| 793 | 1089 val = wrap_cons (c); |
| 428 | 1090 XCAR (val) = car; |
| 1091 XCDR (val) = cdr; | |
| 1092 return val; | |
| 1093 } | |
| 1094 | |
| 1095 DEFUN ("list", Flist, 0, MANY, 0, /* | |
| 1096 Return a newly created list with specified arguments as elements. | |
| 1097 Any number of arguments, even zero arguments, are allowed. | |
| 1098 */ | |
| 1099 (int nargs, Lisp_Object *args)) | |
| 1100 { | |
| 1101 Lisp_Object val = Qnil; | |
| 1102 Lisp_Object *argp = args + nargs; | |
| 1103 | |
| 1104 while (argp > args) | |
| 1105 val = Fcons (*--argp, val); | |
| 1106 return val; | |
| 1107 } | |
| 1108 | |
| 1109 Lisp_Object | |
| 1110 list1 (Lisp_Object obj0) | |
| 1111 { | |
| 1112 /* This cannot GC. */ | |
| 1113 return Fcons (obj0, Qnil); | |
| 1114 } | |
| 1115 | |
| 1116 Lisp_Object | |
| 1117 list2 (Lisp_Object obj0, Lisp_Object obj1) | |
| 1118 { | |
| 1119 /* This cannot GC. */ | |
| 1120 return Fcons (obj0, Fcons (obj1, Qnil)); | |
| 1121 } | |
| 1122 | |
| 1123 Lisp_Object | |
| 1124 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1125 { | |
| 1126 /* This cannot GC. */ | |
| 1127 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil))); | |
| 1128 } | |
| 1129 | |
| 1130 Lisp_Object | |
| 1131 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1132 { | |
| 1133 /* This cannot GC. */ | |
| 1134 return Fcons (obj0, Fcons (obj1, obj2)); | |
| 1135 } | |
| 1136 | |
| 1137 Lisp_Object | |
| 1138 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist) | |
| 1139 { | |
| 1140 return Fcons (Fcons (key, value), alist); | |
| 1141 } | |
| 1142 | |
| 1143 Lisp_Object | |
| 1144 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3) | |
| 1145 { | |
| 1146 /* This cannot GC. */ | |
| 1147 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil)))); | |
| 1148 } | |
| 1149 | |
| 1150 Lisp_Object | |
| 1151 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
| 1152 Lisp_Object obj4) | |
| 1153 { | |
| 1154 /* This cannot GC. */ | |
| 1155 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil))))); | |
| 1156 } | |
| 1157 | |
| 1158 Lisp_Object | |
| 1159 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
| 1160 Lisp_Object obj4, Lisp_Object obj5) | |
| 1161 { | |
| 1162 /* This cannot GC. */ | |
| 1163 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil)))))); | |
| 1164 } | |
| 1165 | |
| 1166 DEFUN ("make-list", Fmake_list, 2, 2, 0, /* | |
| 444 | 1167 Return a new list of length LENGTH, with each element being OBJECT. |
| 428 | 1168 */ |
| 444 | 1169 (length, object)) |
| 428 | 1170 { |
| 1171 CHECK_NATNUM (length); | |
| 1172 | |
| 1173 { | |
| 1174 Lisp_Object val = Qnil; | |
| 647 | 1175 EMACS_INT size = XINT (length); |
| 428 | 1176 |
| 1177 while (size--) | |
| 444 | 1178 val = Fcons (object, val); |
| 428 | 1179 return val; |
| 1180 } | |
| 1181 } | |
| 1182 | |
| 1183 | |
| 1184 /************************************************************************/ | |
| 1185 /* Float allocation */ | |
| 1186 /************************************************************************/ | |
| 1187 | |
| 1983 | 1188 /*** With enhanced number support, these are short floats */ |
| 1189 | |
| 440 | 1190 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float); |
| 428 | 1191 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 |
| 1192 | |
| 1193 Lisp_Object | |
| 1194 make_float (double float_value) | |
| 1195 { | |
| 440 | 1196 Lisp_Float *f; |
| 1197 | |
| 1198 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f); | |
| 1199 | |
| 1200 /* Avoid dump-time `uninitialized memory read' purify warnings. */ | |
| 1201 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) | |
| 1202 xzero (*f); | |
| 1203 | |
| 442 | 1204 set_lheader_implementation (&f->lheader, &lrecord_float); |
| 428 | 1205 float_data (f) = float_value; |
| 793 | 1206 return wrap_float (f); |
| 428 | 1207 } |
| 1208 | |
| 1209 | |
| 1210 /************************************************************************/ | |
| 1983 | 1211 /* Enhanced number allocation */ |
| 1212 /************************************************************************/ | |
| 1213 | |
| 1214 /*** Bignum ***/ | |
| 1215 #ifdef HAVE_BIGNUM | |
| 1216 DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum); | |
| 1217 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250 | |
| 1218 | |
| 1219 /* WARNING: This function returns a bignum even if its argument fits into a | |
| 1220 fixnum. See Fcanonicalize_number(). */ | |
| 1221 Lisp_Object | |
| 1222 make_bignum (long bignum_value) | |
| 1223 { | |
| 1224 Lisp_Bignum *b; | |
| 1225 | |
| 1226 ALLOCATE_FIXED_TYPE (bignum, Lisp_Bignum, b); | |
| 1227 set_lheader_implementation (&b->lheader, &lrecord_bignum); | |
| 1228 bignum_init (bignum_data (b)); | |
| 1229 bignum_set_long (bignum_data (b), bignum_value); | |
| 1230 return wrap_bignum (b); | |
| 1231 } | |
| 1232 | |
| 1233 /* WARNING: This function returns a bignum even if its argument fits into a | |
| 1234 fixnum. See Fcanonicalize_number(). */ | |
| 1235 Lisp_Object | |
| 1236 make_bignum_bg (bignum bg) | |
| 1237 { | |
| 1238 Lisp_Bignum *b; | |
| 1239 | |
| 1240 ALLOCATE_FIXED_TYPE (bignum, Lisp_Bignum, b); | |
| 1241 set_lheader_implementation (&b->lheader, &lrecord_bignum); | |
| 1242 bignum_init (bignum_data (b)); | |
| 1243 bignum_set (bignum_data (b), bg); | |
| 1244 return wrap_bignum (b); | |
| 1245 } | |
| 1246 #endif /* HAVE_BIGNUM */ | |
| 1247 | |
| 1248 /*** Ratio ***/ | |
| 1249 #ifdef HAVE_RATIO | |
| 1250 DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio); | |
| 1251 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250 | |
| 1252 | |
| 1253 Lisp_Object | |
| 1254 make_ratio (long numerator, unsigned long denominator) | |
| 1255 { | |
| 1256 Lisp_Ratio *r; | |
| 1257 | |
| 1258 ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); | |
| 1259 set_lheader_implementation (&r->lheader, &lrecord_ratio); | |
| 1260 ratio_init (ratio_data (r)); | |
| 1261 ratio_set_long_ulong (ratio_data (r), numerator, denominator); | |
| 1262 ratio_canonicalize (ratio_data (r)); | |
| 1263 return wrap_ratio (r); | |
| 1264 } | |
| 1265 | |
| 1266 Lisp_Object | |
| 1267 make_ratio_bg (bignum numerator, bignum denominator) | |
| 1268 { | |
| 1269 Lisp_Ratio *r; | |
| 1270 | |
| 1271 ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); | |
| 1272 set_lheader_implementation (&r->lheader, &lrecord_ratio); | |
| 1273 ratio_init (ratio_data (r)); | |
| 1274 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator); | |
| 1275 ratio_canonicalize (ratio_data (r)); | |
| 1276 return wrap_ratio (r); | |
| 1277 } | |
| 1278 | |
| 1279 Lisp_Object | |
| 1280 make_ratio_rt (ratio rat) | |
| 1281 { | |
| 1282 Lisp_Ratio *r; | |
| 1283 | |
| 1284 ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); | |
| 1285 set_lheader_implementation (&r->lheader, &lrecord_ratio); | |
| 1286 ratio_init (ratio_data (r)); | |
| 1287 ratio_set (ratio_data (r), rat); | |
| 1288 return wrap_ratio (r); | |
| 1289 } | |
| 1290 #endif /* HAVE_RATIO */ | |
| 1291 | |
| 1292 /*** Bigfloat ***/ | |
| 1293 #ifdef HAVE_BIGFLOAT | |
| 1294 DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat); | |
| 1295 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250 | |
| 1296 | |
| 1297 /* This function creates a bigfloat with the default precision if the | |
| 1298 PRECISION argument is zero. */ | |
| 1299 Lisp_Object | |
| 1300 make_bigfloat (double float_value, unsigned long precision) | |
| 1301 { | |
| 1302 Lisp_Bigfloat *f; | |
| 1303 | |
| 1304 ALLOCATE_FIXED_TYPE (bigfloat, Lisp_Bigfloat, f); | |
| 1305 set_lheader_implementation (&f->lheader, &lrecord_bigfloat); | |
| 1306 if (precision == 0UL) | |
| 1307 bigfloat_init (bigfloat_data (f)); | |
| 1308 else | |
| 1309 bigfloat_init_prec (bigfloat_data (f), precision); | |
| 1310 bigfloat_set_double (bigfloat_data (f), float_value); | |
| 1311 return wrap_bigfloat (f); | |
| 1312 } | |
| 1313 | |
| 1314 /* This function creates a bigfloat with the precision of its argument */ | |
| 1315 Lisp_Object | |
| 1316 make_bigfloat_bf (bigfloat float_value) | |
| 1317 { | |
| 1318 Lisp_Bigfloat *f; | |
| 1319 | |
| 1320 ALLOCATE_FIXED_TYPE (bigfloat, Lisp_Bigfloat, f); | |
| 1321 set_lheader_implementation (&f->lheader, &lrecord_bigfloat); | |
| 1322 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value)); | |
| 1323 bigfloat_set (bigfloat_data (f), float_value); | |
| 1324 return wrap_bigfloat (f); | |
| 1325 } | |
| 1326 #endif /* HAVE_BIGFLOAT */ | |
| 1327 | |
| 1328 /************************************************************************/ | |
| 428 | 1329 /* Vector allocation */ |
| 1330 /************************************************************************/ | |
| 1331 | |
| 1332 static Lisp_Object | |
| 1333 mark_vector (Lisp_Object obj) | |
| 1334 { | |
| 1335 Lisp_Vector *ptr = XVECTOR (obj); | |
| 1336 int len = vector_length (ptr); | |
| 1337 int i; | |
| 1338 | |
| 1339 for (i = 0; i < len - 1; i++) | |
| 1340 mark_object (ptr->contents[i]); | |
| 1341 return (len > 0) ? ptr->contents[len - 1] : Qnil; | |
| 1342 } | |
| 1343 | |
| 665 | 1344 static Bytecount |
| 442 | 1345 size_vector (const void *lheader) |
| 428 | 1346 { |
| 456 | 1347 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents, |
| 442 | 1348 ((Lisp_Vector *) lheader)->size); |
| 428 | 1349 } |
| 1350 | |
| 1351 static int | |
| 1352 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 1353 { | |
| 1354 int len = XVECTOR_LENGTH (obj1); | |
| 1355 if (len != XVECTOR_LENGTH (obj2)) | |
| 1356 return 0; | |
| 1357 | |
| 1358 { | |
| 1359 Lisp_Object *ptr1 = XVECTOR_DATA (obj1); | |
| 1360 Lisp_Object *ptr2 = XVECTOR_DATA (obj2); | |
| 1361 while (len--) | |
| 1362 if (!internal_equal (*ptr1++, *ptr2++, depth + 1)) | |
| 1363 return 0; | |
| 1364 } | |
| 1365 return 1; | |
| 1366 } | |
| 1367 | |
| 665 | 1368 static Hashcode |
| 442 | 1369 vector_hash (Lisp_Object obj, int depth) |
| 1370 { | |
| 1371 return HASH2 (XVECTOR_LENGTH (obj), | |
| 1372 internal_array_hash (XVECTOR_DATA (obj), | |
| 1373 XVECTOR_LENGTH (obj), | |
| 1374 depth + 1)); | |
| 1375 } | |
| 1376 | |
| 1204 | 1377 static const struct memory_description vector_description[] = { |
| 440 | 1378 { XD_LONG, offsetof (Lisp_Vector, size) }, |
| 1379 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) }, | |
| 428 | 1380 { XD_END } |
| 1381 }; | |
| 1382 | |
| 1204 | 1383 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("vector", vector, |
| 1384 1, /*dumpable-flag*/ | |
| 1385 mark_vector, print_vector, 0, | |
| 1386 vector_equal, | |
| 1387 vector_hash, | |
| 1388 vector_description, | |
| 1389 size_vector, Lisp_Vector); | |
| 428 | 1390 /* #### should allocate `small' vectors from a frob-block */ |
| 1391 static Lisp_Vector * | |
| 665 | 1392 make_vector_internal (Elemcount sizei) |
| 428 | 1393 { |
| 1204 | 1394 /* no `next' field; we use lcrecords */ |
| 665 | 1395 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, |
| 1204 | 1396 contents, sizei); |
| 1397 Lisp_Vector *p = | |
| 1398 (Lisp_Vector *) basic_alloc_lcrecord (sizem, &lrecord_vector); | |
| 428 | 1399 |
| 1400 p->size = sizei; | |
| 1401 return p; | |
| 1402 } | |
| 1403 | |
| 1404 Lisp_Object | |
| 665 | 1405 make_vector (Elemcount length, Lisp_Object object) |
| 428 | 1406 { |
| 1407 Lisp_Vector *vecp = make_vector_internal (length); | |
| 1408 Lisp_Object *p = vector_data (vecp); | |
| 1409 | |
| 1410 while (length--) | |
| 444 | 1411 *p++ = object; |
| 428 | 1412 |
| 793 | 1413 return wrap_vector (vecp); |
| 428 | 1414 } |
| 1415 | |
| 1416 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /* | |
| 444 | 1417 Return a new vector of length LENGTH, with each element being OBJECT. |
| 428 | 1418 See also the function `vector'. |
| 1419 */ | |
| 444 | 1420 (length, object)) |
| 428 | 1421 { |
| 1422 CONCHECK_NATNUM (length); | |
| 444 | 1423 return make_vector (XINT (length), object); |
| 428 | 1424 } |
| 1425 | |
| 1426 DEFUN ("vector", Fvector, 0, MANY, 0, /* | |
| 1427 Return a newly created vector with specified arguments as elements. | |
| 1428 Any number of arguments, even zero arguments, are allowed. | |
| 1429 */ | |
| 1430 (int nargs, Lisp_Object *args)) | |
| 1431 { | |
| 1432 Lisp_Vector *vecp = make_vector_internal (nargs); | |
| 1433 Lisp_Object *p = vector_data (vecp); | |
| 1434 | |
| 1435 while (nargs--) | |
| 1436 *p++ = *args++; | |
| 1437 | |
| 793 | 1438 return wrap_vector (vecp); |
| 428 | 1439 } |
| 1440 | |
| 1441 Lisp_Object | |
| 1442 vector1 (Lisp_Object obj0) | |
| 1443 { | |
| 1444 return Fvector (1, &obj0); | |
| 1445 } | |
| 1446 | |
| 1447 Lisp_Object | |
| 1448 vector2 (Lisp_Object obj0, Lisp_Object obj1) | |
| 1449 { | |
| 1450 Lisp_Object args[2]; | |
| 1451 args[0] = obj0; | |
| 1452 args[1] = obj1; | |
| 1453 return Fvector (2, args); | |
| 1454 } | |
| 1455 | |
| 1456 Lisp_Object | |
| 1457 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1458 { | |
| 1459 Lisp_Object args[3]; | |
| 1460 args[0] = obj0; | |
| 1461 args[1] = obj1; | |
| 1462 args[2] = obj2; | |
| 1463 return Fvector (3, args); | |
| 1464 } | |
| 1465 | |
| 1466 #if 0 /* currently unused */ | |
| 1467 | |
| 1468 Lisp_Object | |
| 1469 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1470 Lisp_Object obj3) | |
| 1471 { | |
| 1472 Lisp_Object args[4]; | |
| 1473 args[0] = obj0; | |
| 1474 args[1] = obj1; | |
| 1475 args[2] = obj2; | |
| 1476 args[3] = obj3; | |
| 1477 return Fvector (4, args); | |
| 1478 } | |
| 1479 | |
| 1480 Lisp_Object | |
| 1481 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1482 Lisp_Object obj3, Lisp_Object obj4) | |
| 1483 { | |
| 1484 Lisp_Object args[5]; | |
| 1485 args[0] = obj0; | |
| 1486 args[1] = obj1; | |
| 1487 args[2] = obj2; | |
| 1488 args[3] = obj3; | |
| 1489 args[4] = obj4; | |
| 1490 return Fvector (5, args); | |
| 1491 } | |
| 1492 | |
| 1493 Lisp_Object | |
| 1494 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1495 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5) | |
| 1496 { | |
| 1497 Lisp_Object args[6]; | |
| 1498 args[0] = obj0; | |
| 1499 args[1] = obj1; | |
| 1500 args[2] = obj2; | |
| 1501 args[3] = obj3; | |
| 1502 args[4] = obj4; | |
| 1503 args[5] = obj5; | |
| 1504 return Fvector (6, args); | |
| 1505 } | |
| 1506 | |
| 1507 Lisp_Object | |
| 1508 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1509 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
| 1510 Lisp_Object obj6) | |
| 1511 { | |
| 1512 Lisp_Object args[7]; | |
| 1513 args[0] = obj0; | |
| 1514 args[1] = obj1; | |
| 1515 args[2] = obj2; | |
| 1516 args[3] = obj3; | |
| 1517 args[4] = obj4; | |
| 1518 args[5] = obj5; | |
| 1519 args[6] = obj6; | |
| 1520 return Fvector (7, args); | |
| 1521 } | |
| 1522 | |
| 1523 Lisp_Object | |
| 1524 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1525 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
| 1526 Lisp_Object obj6, Lisp_Object obj7) | |
| 1527 { | |
| 1528 Lisp_Object args[8]; | |
| 1529 args[0] = obj0; | |
| 1530 args[1] = obj1; | |
| 1531 args[2] = obj2; | |
| 1532 args[3] = obj3; | |
| 1533 args[4] = obj4; | |
| 1534 args[5] = obj5; | |
| 1535 args[6] = obj6; | |
| 1536 args[7] = obj7; | |
| 1537 return Fvector (8, args); | |
| 1538 } | |
| 1539 #endif /* unused */ | |
| 1540 | |
| 1541 /************************************************************************/ | |
| 1542 /* Bit Vector allocation */ | |
| 1543 /************************************************************************/ | |
| 1544 | |
| 1545 /* #### should allocate `small' bit vectors from a frob-block */ | |
| 440 | 1546 static Lisp_Bit_Vector * |
| 665 | 1547 make_bit_vector_internal (Elemcount sizei) |
| 428 | 1548 { |
| 1204 | 1549 /* no `next' field; we use lcrecords */ |
| 665 | 1550 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei); |
| 1551 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, | |
| 1204 | 1552 unsigned long, |
| 1553 bits, num_longs); | |
| 1554 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) | |
| 1555 basic_alloc_lcrecord (sizem, &lrecord_bit_vector); | |
| 428 | 1556 |
| 1557 bit_vector_length (p) = sizei; | |
| 1558 return p; | |
| 1559 } | |
| 1560 | |
| 1561 Lisp_Object | |
| 665 | 1562 make_bit_vector (Elemcount length, Lisp_Object bit) |
| 428 | 1563 { |
| 440 | 1564 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
| 665 | 1565 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length); |
| 428 | 1566 |
| 444 | 1567 CHECK_BIT (bit); |
| 1568 | |
| 1569 if (ZEROP (bit)) | |
| 428 | 1570 memset (p->bits, 0, num_longs * sizeof (long)); |
| 1571 else | |
| 1572 { | |
| 665 | 1573 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1); |
| 428 | 1574 memset (p->bits, ~0, num_longs * sizeof (long)); |
| 1575 /* But we have to make sure that the unused bits in the | |
| 1576 last long are 0, so that equal/hash is easy. */ | |
| 1577 if (bits_in_last) | |
| 1578 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1; | |
| 1579 } | |
| 1580 | |
| 793 | 1581 return wrap_bit_vector (p); |
| 428 | 1582 } |
| 1583 | |
| 1584 Lisp_Object | |
| 665 | 1585 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length) |
| 428 | 1586 { |
| 665 | 1587 Elemcount i; |
| 428 | 1588 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
| 1589 | |
| 1590 for (i = 0; i < length; i++) | |
| 1591 set_bit_vector_bit (p, i, bytevec[i]); | |
| 1592 | |
| 793 | 1593 return wrap_bit_vector (p); |
| 428 | 1594 } |
| 1595 | |
| 1596 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /* | |
| 444 | 1597 Return a new bit vector of length LENGTH. with each bit set to BIT. |
| 1598 BIT must be one of the integers 0 or 1. See also the function `bit-vector'. | |
| 428 | 1599 */ |
| 444 | 1600 (length, bit)) |
| 428 | 1601 { |
| 1602 CONCHECK_NATNUM (length); | |
| 1603 | |
| 444 | 1604 return make_bit_vector (XINT (length), bit); |
| 428 | 1605 } |
| 1606 | |
| 1607 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /* | |
| 1608 Return a newly created bit vector with specified arguments as elements. | |
| 1609 Any number of arguments, even zero arguments, are allowed. | |
| 444 | 1610 Each argument must be one of the integers 0 or 1. |
| 428 | 1611 */ |
| 1612 (int nargs, Lisp_Object *args)) | |
| 1613 { | |
| 1614 int i; | |
| 1615 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs); | |
| 1616 | |
| 1617 for (i = 0; i < nargs; i++) | |
| 1618 { | |
| 1619 CHECK_BIT (args[i]); | |
| 1620 set_bit_vector_bit (p, i, !ZEROP (args[i])); | |
| 1621 } | |
| 1622 | |
| 793 | 1623 return wrap_bit_vector (p); |
| 428 | 1624 } |
| 1625 | |
| 1626 | |
| 1627 /************************************************************************/ | |
| 1628 /* Compiled-function allocation */ | |
| 1629 /************************************************************************/ | |
| 1630 | |
| 1631 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); | |
| 1632 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 | |
| 1633 | |
| 1634 static Lisp_Object | |
| 1635 make_compiled_function (void) | |
| 1636 { | |
| 1637 Lisp_Compiled_Function *f; | |
| 1638 | |
| 1639 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f); | |
| 442 | 1640 set_lheader_implementation (&f->lheader, &lrecord_compiled_function); |
| 428 | 1641 |
| 1642 f->stack_depth = 0; | |
| 1643 f->specpdl_depth = 0; | |
| 1644 f->flags.documentationp = 0; | |
| 1645 f->flags.interactivep = 0; | |
| 1646 f->flags.domainp = 0; /* I18N3 */ | |
| 1647 f->instructions = Qzero; | |
| 1648 f->constants = Qzero; | |
| 1649 f->arglist = Qnil; | |
| 1739 | 1650 f->args = NULL; |
| 1651 f->max_args = f->min_args = f->args_in_array = 0; | |
| 428 | 1652 f->doc_and_interactive = Qnil; |
| 1653 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 1654 f->annotated = Qnil; | |
| 1655 #endif | |
| 793 | 1656 return wrap_compiled_function (f); |
| 428 | 1657 } |
| 1658 | |
| 1659 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* | |
| 1660 Return a new compiled-function object. | |
| 1661 Usage: (arglist instructions constants stack-depth | |
| 1662 &optional doc-string interactive) | |
| 1663 Note that, unlike all other emacs-lisp functions, calling this with five | |
| 1664 arguments is NOT the same as calling it with six arguments, the last of | |
| 1665 which is nil. If the INTERACTIVE arg is specified as nil, then that means | |
| 1666 that this function was defined with `(interactive)'. If the arg is not | |
| 1667 specified, then that means the function is not interactive. | |
| 1668 This is terrible behavior which is retained for compatibility with old | |
| 1669 `.elc' files which expect these semantics. | |
| 1670 */ | |
| 1671 (int nargs, Lisp_Object *args)) | |
| 1672 { | |
| 1673 /* In a non-insane world this function would have this arglist... | |
| 1674 (arglist instructions constants stack_depth &optional doc_string interactive) | |
| 1675 */ | |
| 1676 Lisp_Object fun = make_compiled_function (); | |
| 1677 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 1678 | |
| 1679 Lisp_Object arglist = args[0]; | |
| 1680 Lisp_Object instructions = args[1]; | |
| 1681 Lisp_Object constants = args[2]; | |
| 1682 Lisp_Object stack_depth = args[3]; | |
| 1683 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; | |
| 1684 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; | |
| 1685 | |
| 1686 if (nargs < 4 || nargs > 6) | |
| 1687 return Fsignal (Qwrong_number_of_arguments, | |
| 1688 list2 (intern ("make-byte-code"), make_int (nargs))); | |
| 1689 | |
| 1690 /* Check for valid formal parameter list now, to allow us to use | |
| 1691 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */ | |
| 1692 { | |
| 814 | 1693 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 1694 { |
| 1695 CHECK_SYMBOL (symbol); | |
| 1696 if (EQ (symbol, Qt) || | |
| 1697 EQ (symbol, Qnil) || | |
| 1698 SYMBOL_IS_KEYWORD (symbol)) | |
| 563 | 1699 invalid_constant_2 |
| 428 | 1700 ("Invalid constant symbol in formal parameter list", |
| 1701 symbol, arglist); | |
| 1702 } | |
| 1703 } | |
| 1704 f->arglist = arglist; | |
| 1705 | |
| 1706 /* `instructions' is a string or a cons (string . int) for a | |
| 1707 lazy-loaded function. */ | |
| 1708 if (CONSP (instructions)) | |
| 1709 { | |
| 1710 CHECK_STRING (XCAR (instructions)); | |
| 1711 CHECK_INT (XCDR (instructions)); | |
| 1712 } | |
| 1713 else | |
| 1714 { | |
| 1715 CHECK_STRING (instructions); | |
| 1716 } | |
| 1717 f->instructions = instructions; | |
| 1718 | |
| 1719 if (!NILP (constants)) | |
| 1720 CHECK_VECTOR (constants); | |
| 1721 f->constants = constants; | |
| 1722 | |
| 1723 CHECK_NATNUM (stack_depth); | |
| 442 | 1724 f->stack_depth = (unsigned short) XINT (stack_depth); |
| 428 | 1725 |
| 1726 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 1727 if (!NILP (Vcurrent_compiled_function_annotation)) | |
| 1728 f->annotated = Fcopy (Vcurrent_compiled_function_annotation); | |
| 1729 else if (!NILP (Vload_file_name_internal_the_purecopy)) | |
| 1730 f->annotated = Vload_file_name_internal_the_purecopy; | |
| 1731 else if (!NILP (Vload_file_name_internal)) | |
| 1732 { | |
| 1733 struct gcpro gcpro1; | |
| 1734 GCPRO1 (fun); /* don't let fun get reaped */ | |
| 1735 Vload_file_name_internal_the_purecopy = | |
| 1736 Ffile_name_nondirectory (Vload_file_name_internal); | |
| 1737 f->annotated = Vload_file_name_internal_the_purecopy; | |
| 1738 UNGCPRO; | |
| 1739 } | |
| 1740 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 1741 | |
| 1742 /* doc_string may be nil, string, int, or a cons (string . int). | |
| 1743 interactive may be list or string (or unbound). */ | |
| 1744 f->doc_and_interactive = Qunbound; | |
| 1745 #ifdef I18N3 | |
| 1746 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0) | |
| 1747 f->doc_and_interactive = Vfile_domain; | |
| 1748 #endif | |
| 1749 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0) | |
| 1750 { | |
| 1751 f->doc_and_interactive | |
| 1752 = (UNBOUNDP (f->doc_and_interactive) ? interactive : | |
| 1753 Fcons (interactive, f->doc_and_interactive)); | |
| 1754 } | |
| 1755 if ((f->flags.documentationp = !NILP (doc_string)) != 0) | |
| 1756 { | |
| 1757 f->doc_and_interactive | |
| 1758 = (UNBOUNDP (f->doc_and_interactive) ? doc_string : | |
| 1759 Fcons (doc_string, f->doc_and_interactive)); | |
| 1760 } | |
| 1761 if (UNBOUNDP (f->doc_and_interactive)) | |
| 1762 f->doc_and_interactive = Qnil; | |
| 1763 | |
| 1764 return fun; | |
| 1765 } | |
| 1766 | |
| 1767 | |
| 1768 /************************************************************************/ | |
| 1769 /* Symbol allocation */ | |
| 1770 /************************************************************************/ | |
| 1771 | |
| 440 | 1772 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol); |
| 428 | 1773 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 |
| 1774 | |
| 1775 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* | |
| 1776 Return a newly allocated uninterned symbol whose name is NAME. | |
| 1777 Its value and function definition are void, and its property list is nil. | |
| 1778 */ | |
| 1779 (name)) | |
| 1780 { | |
| 440 | 1781 Lisp_Symbol *p; |
| 428 | 1782 |
| 1783 CHECK_STRING (name); | |
| 1784 | |
| 440 | 1785 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p); |
| 442 | 1786 set_lheader_implementation (&p->lheader, &lrecord_symbol); |
| 793 | 1787 p->name = name; |
| 428 | 1788 p->plist = Qnil; |
| 1789 p->value = Qunbound; | |
| 1790 p->function = Qunbound; | |
| 1791 symbol_next (p) = 0; | |
| 793 | 1792 return wrap_symbol (p); |
| 428 | 1793 } |
| 1794 | |
| 1795 | |
| 1796 /************************************************************************/ | |
| 1797 /* Extent allocation */ | |
| 1798 /************************************************************************/ | |
| 1799 | |
| 1800 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); | |
| 1801 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 | |
| 1802 | |
| 1803 struct extent * | |
| 1804 allocate_extent (void) | |
| 1805 { | |
| 1806 struct extent *e; | |
| 1807 | |
| 1808 ALLOCATE_FIXED_TYPE (extent, struct extent, e); | |
| 442 | 1809 set_lheader_implementation (&e->lheader, &lrecord_extent); |
| 428 | 1810 extent_object (e) = Qnil; |
| 1811 set_extent_start (e, -1); | |
| 1812 set_extent_end (e, -1); | |
| 1813 e->plist = Qnil; | |
| 1814 | |
| 1815 xzero (e->flags); | |
| 1816 | |
| 1817 extent_face (e) = Qnil; | |
| 1818 e->flags.end_open = 1; /* default is for endpoints to behave like markers */ | |
| 1819 e->flags.detachable = 1; | |
| 1820 | |
| 1821 return e; | |
| 1822 } | |
| 1823 | |
| 1824 | |
| 1825 /************************************************************************/ | |
| 1826 /* Event allocation */ | |
| 1827 /************************************************************************/ | |
| 1828 | |
| 440 | 1829 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event); |
| 428 | 1830 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 |
| 1831 | |
| 1832 Lisp_Object | |
| 1833 allocate_event (void) | |
| 1834 { | |
| 440 | 1835 Lisp_Event *e; |
| 1836 | |
| 1837 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e); | |
| 442 | 1838 set_lheader_implementation (&e->lheader, &lrecord_event); |
| 428 | 1839 |
| 793 | 1840 return wrap_event (e); |
| 428 | 1841 } |
| 1842 | |
| 1204 | 1843 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 1844 DECLARE_FIXED_TYPE_ALLOC (key_data, Lisp_Key_Data); |
| 1845 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_key_data 1000 | |
| 1846 | |
| 1847 Lisp_Object | |
| 1204 | 1848 make_key_data (void) |
| 934 | 1849 { |
| 1850 Lisp_Key_Data *d; | |
| 1851 | |
| 1852 ALLOCATE_FIXED_TYPE (key_data, Lisp_Key_Data, d); | |
| 1204 | 1853 xzero (*d); |
| 934 | 1854 set_lheader_implementation (&d->lheader, &lrecord_key_data); |
| 1204 | 1855 d->keysym = Qnil; |
| 1856 | |
| 1857 return wrap_key_data (d); | |
| 934 | 1858 } |
| 1859 | |
| 1860 DECLARE_FIXED_TYPE_ALLOC (button_data, Lisp_Button_Data); | |
| 1861 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_button_data 1000 | |
| 1862 | |
| 1863 Lisp_Object | |
| 1204 | 1864 make_button_data (void) |
| 934 | 1865 { |
| 1866 Lisp_Button_Data *d; | |
| 1867 | |
| 1868 ALLOCATE_FIXED_TYPE (button_data, Lisp_Button_Data, d); | |
| 1204 | 1869 xzero (*d); |
| 934 | 1870 set_lheader_implementation (&d->lheader, &lrecord_button_data); |
| 1871 | |
| 1204 | 1872 return wrap_button_data (d); |
| 934 | 1873 } |
| 1874 | |
| 1875 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data); | |
| 1876 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000 | |
| 1877 | |
| 1878 Lisp_Object | |
| 1204 | 1879 make_motion_data (void) |
| 934 | 1880 { |
| 1881 Lisp_Motion_Data *d; | |
| 1882 | |
| 1883 ALLOCATE_FIXED_TYPE (motion_data, Lisp_Motion_Data, d); | |
| 1204 | 1884 xzero (*d); |
| 934 | 1885 set_lheader_implementation (&d->lheader, &lrecord_motion_data); |
| 1886 | |
| 1204 | 1887 return wrap_motion_data (d); |
| 934 | 1888 } |
| 1889 | |
| 1890 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data); | |
| 1891 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_process_data 1000 | |
| 1892 | |
| 1893 Lisp_Object | |
| 1204 | 1894 make_process_data (void) |
| 934 | 1895 { |
| 1896 Lisp_Process_Data *d; | |
| 1897 | |
| 1898 ALLOCATE_FIXED_TYPE (process_data, Lisp_Process_Data, d); | |
| 1204 | 1899 xzero (*d); |
| 934 | 1900 set_lheader_implementation (&d->lheader, &lrecord_process_data); |
| 1204 | 1901 d->process = Qnil; |
| 1902 | |
| 1903 return wrap_process_data (d); | |
| 934 | 1904 } |
| 1905 | |
| 1906 DECLARE_FIXED_TYPE_ALLOC (timeout_data, Lisp_Timeout_Data); | |
| 1907 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_timeout_data 1000 | |
| 1908 | |
| 1909 Lisp_Object | |
| 1204 | 1910 make_timeout_data (void) |
| 934 | 1911 { |
| 1912 Lisp_Timeout_Data *d; | |
| 1913 | |
| 1914 ALLOCATE_FIXED_TYPE (timeout_data, Lisp_Timeout_Data, d); | |
| 1204 | 1915 xzero (*d); |
| 934 | 1916 set_lheader_implementation (&d->lheader, &lrecord_timeout_data); |
| 1204 | 1917 d->function = Qnil; |
| 1918 d->object = Qnil; | |
| 1919 | |
| 1920 return wrap_timeout_data (d); | |
| 934 | 1921 } |
| 1922 | |
| 1923 DECLARE_FIXED_TYPE_ALLOC (magic_data, Lisp_Magic_Data); | |
| 1924 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_data 1000 | |
| 1925 | |
| 1926 Lisp_Object | |
| 1204 | 1927 make_magic_data (void) |
| 934 | 1928 { |
| 1929 Lisp_Magic_Data *d; | |
| 1930 | |
| 1931 ALLOCATE_FIXED_TYPE (magic_data, Lisp_Magic_Data, d); | |
| 1204 | 1932 xzero (*d); |
| 934 | 1933 set_lheader_implementation (&d->lheader, &lrecord_magic_data); |
| 1934 | |
| 1204 | 1935 return wrap_magic_data (d); |
| 934 | 1936 } |
| 1937 | |
| 1938 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data); | |
| 1939 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_eval_data 1000 | |
| 1940 | |
| 1941 Lisp_Object | |
| 1204 | 1942 make_magic_eval_data (void) |
| 934 | 1943 { |
| 1944 Lisp_Magic_Eval_Data *d; | |
| 1945 | |
| 1946 ALLOCATE_FIXED_TYPE (magic_eval_data, Lisp_Magic_Eval_Data, d); | |
| 1204 | 1947 xzero (*d); |
| 934 | 1948 set_lheader_implementation (&d->lheader, &lrecord_magic_eval_data); |
| 1204 | 1949 d->object = Qnil; |
| 1950 | |
| 1951 return wrap_magic_eval_data (d); | |
| 934 | 1952 } |
| 1953 | |
| 1954 DECLARE_FIXED_TYPE_ALLOC (eval_data, Lisp_Eval_Data); | |
| 1955 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_eval_data 1000 | |
| 1956 | |
| 1957 Lisp_Object | |
| 1204 | 1958 make_eval_data (void) |
| 934 | 1959 { |
| 1960 Lisp_Eval_Data *d; | |
| 1961 | |
| 1962 ALLOCATE_FIXED_TYPE (eval_data, Lisp_Eval_Data, d); | |
| 1204 | 1963 xzero (*d); |
| 934 | 1964 set_lheader_implementation (&d->lheader, &lrecord_eval_data); |
| 1204 | 1965 d->function = Qnil; |
| 1966 d->object = Qnil; | |
| 1967 | |
| 1968 return wrap_eval_data (d); | |
| 934 | 1969 } |
| 1970 | |
| 1971 DECLARE_FIXED_TYPE_ALLOC (misc_user_data, Lisp_Misc_User_Data); | |
| 1972 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_misc_user_data 1000 | |
| 1973 | |
| 1974 Lisp_Object | |
| 1204 | 1975 make_misc_user_data (void) |
| 934 | 1976 { |
| 1977 Lisp_Misc_User_Data *d; | |
| 1978 | |
| 1979 ALLOCATE_FIXED_TYPE (misc_user_data, Lisp_Misc_User_Data, d); | |
| 1204 | 1980 xzero (*d); |
| 934 | 1981 set_lheader_implementation (&d->lheader, &lrecord_misc_user_data); |
| 1204 | 1982 d->function = Qnil; |
| 1983 d->object = Qnil; | |
| 1984 | |
| 1985 return wrap_misc_user_data (d); | |
| 934 | 1986 } |
| 1204 | 1987 |
| 1988 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 428 | 1989 |
| 1990 /************************************************************************/ | |
| 1991 /* Marker allocation */ | |
| 1992 /************************************************************************/ | |
| 1993 | |
| 440 | 1994 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker); |
| 428 | 1995 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 |
| 1996 | |
| 1997 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* | |
| 1998 Return a new marker which does not point at any place. | |
| 1999 */ | |
| 2000 ()) | |
| 2001 { | |
| 440 | 2002 Lisp_Marker *p; |
| 2003 | |
| 2004 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); | |
| 442 | 2005 set_lheader_implementation (&p->lheader, &lrecord_marker); |
| 428 | 2006 p->buffer = 0; |
| 665 | 2007 p->membpos = 0; |
| 428 | 2008 marker_next (p) = 0; |
| 2009 marker_prev (p) = 0; | |
| 2010 p->insertion_type = 0; | |
| 793 | 2011 return wrap_marker (p); |
| 428 | 2012 } |
| 2013 | |
| 2014 Lisp_Object | |
| 2015 noseeum_make_marker (void) | |
| 2016 { | |
| 440 | 2017 Lisp_Marker *p; |
| 2018 | |
| 2019 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); | |
| 442 | 2020 set_lheader_implementation (&p->lheader, &lrecord_marker); |
| 428 | 2021 p->buffer = 0; |
| 665 | 2022 p->membpos = 0; |
| 428 | 2023 marker_next (p) = 0; |
| 2024 marker_prev (p) = 0; | |
| 2025 p->insertion_type = 0; | |
| 793 | 2026 return wrap_marker (p); |
| 428 | 2027 } |
| 2028 | |
| 2029 | |
| 2030 /************************************************************************/ | |
| 2031 /* String allocation */ | |
| 2032 /************************************************************************/ | |
| 2033 | |
| 2034 /* The data for "short" strings generally resides inside of structs of type | |
| 2035 string_chars_block. The Lisp_String structure is allocated just like any | |
| 1204 | 2036 other basic lrecord, and these are freelisted when they get garbage |
| 2037 collected. The data for short strings get compacted, but the data for | |
| 2038 large strings do not. | |
| 428 | 2039 |
| 2040 Previously Lisp_String structures were relocated, but this caused a lot | |
| 2041 of bus-errors because the C code didn't include enough GCPRO's for | |
| 2042 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so | |
| 2043 that the reference would get relocated). | |
| 2044 | |
| 2045 This new method makes things somewhat bigger, but it is MUCH safer. */ | |
| 2046 | |
| 438 | 2047 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String); |
| 428 | 2048 /* strings are used and freed quite often */ |
| 2049 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ | |
| 2050 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 | |
| 2051 | |
| 2052 static Lisp_Object | |
| 2053 mark_string (Lisp_Object obj) | |
| 2054 { | |
| 793 | 2055 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj)))) |
| 2056 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj))); | |
| 2057 return XSTRING_PLIST (obj); | |
| 428 | 2058 } |
| 2059 | |
| 2060 static int | |
| 2286 | 2061 string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) |
| 428 | 2062 { |
| 2063 Bytecount len; | |
| 2064 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && | |
| 2065 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); | |
| 2066 } | |
| 2067 | |
| 1204 | 2068 static const struct memory_description string_description[] = { |
| 793 | 2069 { XD_BYTECOUNT, offsetof (Lisp_String, size_) }, |
| 2070 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) }, | |
| 440 | 2071 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) }, |
| 428 | 2072 { XD_END } |
| 2073 }; | |
| 2074 | |
| 442 | 2075 /* We store the string's extent info as the first element of the string's |
| 2076 property list; and the string's MODIFF as the first or second element | |
| 2077 of the string's property list (depending on whether the extent info | |
| 2078 is present), but only if the string has been modified. This is ugly | |
| 2079 but it reduces the memory allocated for the string in the vast | |
| 2080 majority of cases, where the string is never modified and has no | |
| 2081 extent info. | |
| 2082 | |
| 2083 #### This means you can't use an int as a key in a string's plist. */ | |
| 2084 | |
| 2085 static Lisp_Object * | |
| 2086 string_plist_ptr (Lisp_Object string) | |
| 2087 { | |
| 793 | 2088 Lisp_Object *ptr = &XSTRING_PLIST (string); |
| 442 | 2089 |
| 2090 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
| 2091 ptr = &XCDR (*ptr); | |
| 2092 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
| 2093 ptr = &XCDR (*ptr); | |
| 2094 return ptr; | |
| 2095 } | |
| 2096 | |
| 2097 static Lisp_Object | |
| 2098 string_getprop (Lisp_Object string, Lisp_Object property) | |
| 2099 { | |
| 2100 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME); | |
| 2101 } | |
| 2102 | |
| 2103 static int | |
| 2104 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value) | |
| 2105 { | |
| 2106 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME); | |
| 2107 return 1; | |
| 2108 } | |
| 2109 | |
| 2110 static int | |
| 2111 string_remprop (Lisp_Object string, Lisp_Object property) | |
| 2112 { | |
| 2113 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME); | |
| 2114 } | |
| 2115 | |
| 2116 static Lisp_Object | |
| 2117 string_plist (Lisp_Object string) | |
| 2118 { | |
| 2119 return *string_plist_ptr (string); | |
| 2120 } | |
| 2121 | |
| 2122 /* No `finalize', or `hash' methods. | |
| 2123 internal_hash() already knows how to hash strings and finalization | |
| 2124 is done with the ADDITIONAL_FREE_string macro, which is the | |
| 2125 standard way to do finalization when using | |
| 2126 SWEEP_FIXED_TYPE_BLOCK(). */ | |
| 934 | 2127 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string, |
| 2128 1, /*dumpable-flag*/ | |
| 2129 mark_string, print_string, | |
| 2130 0, string_equal, 0, | |
| 2131 string_description, | |
| 2132 string_getprop, | |
| 2133 string_putprop, | |
| 2134 string_remprop, | |
| 2135 string_plist, | |
| 2136 Lisp_String); | |
| 428 | 2137 /* String blocks contain this many useful bytes. */ |
| 2138 #define STRING_CHARS_BLOCK_SIZE \ | |
| 814 | 2139 ((Bytecount) (8192 - MALLOC_OVERHEAD - \ |
| 2140 ((2 * sizeof (struct string_chars_block *)) \ | |
| 2141 + sizeof (EMACS_INT)))) | |
| 428 | 2142 /* Block header for small strings. */ |
| 2143 struct string_chars_block | |
| 2144 { | |
| 2145 EMACS_INT pos; | |
| 2146 struct string_chars_block *next; | |
| 2147 struct string_chars_block *prev; | |
| 2148 /* Contents of string_chars_block->string_chars are interleaved | |
| 2149 string_chars structures (see below) and the actual string data */ | |
| 2150 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE]; | |
| 2151 }; | |
| 2152 | |
| 2153 static struct string_chars_block *first_string_chars_block; | |
| 2154 static struct string_chars_block *current_string_chars_block; | |
| 2155 | |
| 2156 /* If SIZE is the length of a string, this returns how many bytes | |
| 2157 * the string occupies in string_chars_block->string_chars | |
| 2158 * (including alignment padding). | |
| 2159 */ | |
| 438 | 2160 #define STRING_FULLSIZE(size) \ |
| 826 | 2161 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *) |
| 428 | 2162 |
| 2163 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE) | |
| 2164 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size))) | |
| 2165 | |
| 454 | 2166 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL) |
| 2167 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL)) | |
| 2168 | |
| 428 | 2169 struct string_chars |
| 2170 { | |
| 438 | 2171 Lisp_String *string; |
| 428 | 2172 unsigned char chars[1]; |
| 2173 }; | |
| 2174 | |
| 2175 struct unused_string_chars | |
| 2176 { | |
| 438 | 2177 Lisp_String *string; |
| 428 | 2178 EMACS_INT fullsize; |
| 2179 }; | |
| 2180 | |
| 2181 static void | |
| 2182 init_string_chars_alloc (void) | |
| 2183 { | |
| 2184 first_string_chars_block = xnew (struct string_chars_block); | |
| 2185 first_string_chars_block->prev = 0; | |
| 2186 first_string_chars_block->next = 0; | |
| 2187 first_string_chars_block->pos = 0; | |
| 2188 current_string_chars_block = first_string_chars_block; | |
| 2189 } | |
| 2190 | |
| 1550 | 2191 static Ibyte * |
| 2192 allocate_big_string_chars (Bytecount length) | |
| 2193 { | |
| 2194 Ibyte *p = xnew_array (Ibyte, length); | |
| 2195 INCREMENT_CONS_COUNTER (length, "string chars"); | |
| 2196 return p; | |
| 2197 } | |
| 2198 | |
| 428 | 2199 static struct string_chars * |
| 793 | 2200 allocate_string_chars_struct (Lisp_Object string_it_goes_with, |
| 814 | 2201 Bytecount fullsize) |
| 428 | 2202 { |
| 2203 struct string_chars *s_chars; | |
| 2204 | |
| 438 | 2205 if (fullsize <= |
| 2206 (countof (current_string_chars_block->string_chars) | |
| 2207 - current_string_chars_block->pos)) | |
| 428 | 2208 { |
| 2209 /* This string can fit in the current string chars block */ | |
| 2210 s_chars = (struct string_chars *) | |
| 2211 (current_string_chars_block->string_chars | |
| 2212 + current_string_chars_block->pos); | |
| 2213 current_string_chars_block->pos += fullsize; | |
| 2214 } | |
| 2215 else | |
| 2216 { | |
| 2217 /* Make a new current string chars block */ | |
| 2218 struct string_chars_block *new_scb = xnew (struct string_chars_block); | |
| 2219 | |
| 2220 current_string_chars_block->next = new_scb; | |
| 2221 new_scb->prev = current_string_chars_block; | |
| 2222 new_scb->next = 0; | |
| 2223 current_string_chars_block = new_scb; | |
| 2224 new_scb->pos = fullsize; | |
| 2225 s_chars = (struct string_chars *) | |
| 2226 current_string_chars_block->string_chars; | |
| 2227 } | |
| 2228 | |
| 793 | 2229 s_chars->string = XSTRING (string_it_goes_with); |
| 428 | 2230 |
| 2231 INCREMENT_CONS_COUNTER (fullsize, "string chars"); | |
| 2232 | |
| 2233 return s_chars; | |
| 2234 } | |
| 2235 | |
| 771 | 2236 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN |
| 2237 void | |
| 2238 sledgehammer_check_ascii_begin (Lisp_Object str) | |
| 2239 { | |
| 2240 Bytecount i; | |
| 2241 | |
| 2242 for (i = 0; i < XSTRING_LENGTH (str); i++) | |
| 2243 { | |
| 826 | 2244 if (!byte_ascii_p (string_byte (str, i))) |
| 771 | 2245 break; |
| 2246 } | |
| 2247 | |
| 2248 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) || | |
| 2249 (i > MAX_STRING_ASCII_BEGIN && | |
| 2250 (Bytecount) XSTRING_ASCII_BEGIN (str) == | |
| 2251 (Bytecount) MAX_STRING_ASCII_BEGIN)); | |
| 2252 } | |
| 2253 #endif | |
| 2254 | |
| 2255 /* You do NOT want to be calling this! (And if you do, you must call | |
| 851 | 2256 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use ALLOCA () |
| 771 | 2257 instead and then call make_string() like the rest of the world. */ |
| 2258 | |
| 428 | 2259 Lisp_Object |
| 2260 make_uninit_string (Bytecount length) | |
| 2261 { | |
| 438 | 2262 Lisp_String *s; |
| 814 | 2263 Bytecount fullsize = STRING_FULLSIZE (length); |
| 428 | 2264 |
| 438 | 2265 assert (length >= 0 && fullsize > 0); |
| 428 | 2266 |
| 2267 /* Allocate the string header */ | |
| 438 | 2268 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
| 793 | 2269 xzero (*s); |
| 771 | 2270 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
| 793 | 2271 |
| 826 | 2272 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize) |
| 1550 | 2273 ? allocate_big_string_chars (length + 1) |
| 793 | 2274 : allocate_string_chars_struct (wrap_string (s), |
| 2275 fullsize)->chars); | |
| 438 | 2276 |
| 826 | 2277 set_lispstringp_length (s, length); |
| 428 | 2278 s->plist = Qnil; |
| 793 | 2279 set_string_byte (wrap_string (s), length, 0); |
| 2280 | |
| 2281 return wrap_string (s); | |
| 428 | 2282 } |
| 2283 | |
| 2284 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
| 2285 static void verify_string_chars_integrity (void); | |
| 2286 #endif | |
| 2287 | |
| 2288 /* Resize the string S so that DELTA bytes can be inserted starting | |
| 2289 at POS. If DELTA < 0, it means deletion starting at POS. If | |
| 2290 POS < 0, resize the string but don't copy any characters. Use | |
| 2291 this if you're planning on completely overwriting the string. | |
| 2292 */ | |
| 2293 | |
| 2294 void | |
| 793 | 2295 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta) |
| 428 | 2296 { |
| 438 | 2297 Bytecount oldfullsize, newfullsize; |
| 428 | 2298 #ifdef VERIFY_STRING_CHARS_INTEGRITY |
| 2299 verify_string_chars_integrity (); | |
| 2300 #endif | |
| 2301 | |
| 800 | 2302 #ifdef ERROR_CHECK_TEXT |
| 428 | 2303 if (pos >= 0) |
| 2304 { | |
| 793 | 2305 assert (pos <= XSTRING_LENGTH (s)); |
| 428 | 2306 if (delta < 0) |
| 793 | 2307 assert (pos + (-delta) <= XSTRING_LENGTH (s)); |
| 428 | 2308 } |
| 2309 else | |
| 2310 { | |
| 2311 if (delta < 0) | |
| 793 | 2312 assert ((-delta) <= XSTRING_LENGTH (s)); |
| 428 | 2313 } |
| 800 | 2314 #endif /* ERROR_CHECK_TEXT */ |
| 428 | 2315 |
| 2316 if (delta == 0) | |
| 2317 /* simplest case: no size change. */ | |
| 2318 return; | |
| 438 | 2319 |
| 2320 if (pos >= 0 && delta < 0) | |
| 2321 /* If DELTA < 0, the functions below will delete the characters | |
| 2322 before POS. We want to delete characters *after* POS, however, | |
| 2323 so convert this to the appropriate form. */ | |
| 2324 pos += -delta; | |
| 2325 | |
| 793 | 2326 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s)); |
| 2327 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); | |
| 438 | 2328 |
| 2329 if (BIG_STRING_FULLSIZE_P (oldfullsize)) | |
| 428 | 2330 { |
| 438 | 2331 if (BIG_STRING_FULLSIZE_P (newfullsize)) |
| 428 | 2332 { |
| 440 | 2333 /* Both strings are big. We can just realloc(). |
| 2334 But careful! If the string is shrinking, we have to | |
| 2335 memmove() _before_ realloc(), and if growing, we have to | |
| 2336 memmove() _after_ realloc() - otherwise the access is | |
| 2337 illegal, and we might crash. */ | |
| 793 | 2338 Bytecount len = XSTRING_LENGTH (s) + 1 - pos; |
| 440 | 2339 |
| 2340 if (delta < 0 && pos >= 0) | |
| 793 | 2341 memmove (XSTRING_DATA (s) + pos + delta, |
| 2342 XSTRING_DATA (s) + pos, len); | |
| 2343 XSET_STRING_DATA | |
| 867 | 2344 (s, (Ibyte *) xrealloc (XSTRING_DATA (s), |
| 793 | 2345 XSTRING_LENGTH (s) + delta + 1)); |
| 440 | 2346 if (delta > 0 && pos >= 0) |
| 793 | 2347 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, |
| 2348 len); | |
| 1550 | 2349 /* Bump the cons counter. |
| 2350 Conservative; Martin let the increment be delta. */ | |
| 2351 INCREMENT_CONS_COUNTER (newfullsize, "string chars"); | |
| 428 | 2352 } |
| 438 | 2353 else /* String has been demoted from BIG_STRING. */ |
| 428 | 2354 { |
| 867 | 2355 Ibyte *new_data = |
| 438 | 2356 allocate_string_chars_struct (s, newfullsize)->chars; |
| 867 | 2357 Ibyte *old_data = XSTRING_DATA (s); |
| 438 | 2358 |
| 2359 if (pos >= 0) | |
| 2360 { | |
| 2361 memcpy (new_data, old_data, pos); | |
| 2362 memcpy (new_data + pos + delta, old_data + pos, | |
| 793 | 2363 XSTRING_LENGTH (s) + 1 - pos); |
| 438 | 2364 } |
| 793 | 2365 XSET_STRING_DATA (s, new_data); |
| 1726 | 2366 xfree (old_data, Ibyte *); |
| 438 | 2367 } |
| 2368 } | |
| 2369 else /* old string is small */ | |
| 2370 { | |
| 2371 if (oldfullsize == newfullsize) | |
| 2372 { | |
| 2373 /* special case; size change but the necessary | |
| 2374 allocation size won't change (up or down; code | |
| 2375 somewhere depends on there not being any unused | |
| 2376 allocation space, modulo any alignment | |
| 2377 constraints). */ | |
| 428 | 2378 if (pos >= 0) |
| 2379 { | |
| 867 | 2380 Ibyte *addroff = pos + XSTRING_DATA (s); |
| 428 | 2381 |
| 2382 memmove (addroff + delta, addroff, | |
| 2383 /* +1 due to zero-termination. */ | |
| 793 | 2384 XSTRING_LENGTH (s) + 1 - pos); |
| 428 | 2385 } |
| 2386 } | |
| 2387 else | |
| 2388 { | |
| 867 | 2389 Ibyte *old_data = XSTRING_DATA (s); |
| 2390 Ibyte *new_data = | |
| 438 | 2391 BIG_STRING_FULLSIZE_P (newfullsize) |
| 1550 | 2392 ? allocate_big_string_chars (XSTRING_LENGTH (s) + delta + 1) |
| 438 | 2393 : allocate_string_chars_struct (s, newfullsize)->chars; |
| 2394 | |
| 428 | 2395 if (pos >= 0) |
| 2396 { | |
| 438 | 2397 memcpy (new_data, old_data, pos); |
| 2398 memcpy (new_data + pos + delta, old_data + pos, | |
| 793 | 2399 XSTRING_LENGTH (s) + 1 - pos); |
| 428 | 2400 } |
| 793 | 2401 XSET_STRING_DATA (s, new_data); |
| 438 | 2402 |
| 2403 { | |
| 2404 /* We need to mark this chunk of the string_chars_block | |
| 2405 as unused so that compact_string_chars() doesn't | |
| 2406 freak. */ | |
| 2407 struct string_chars *old_s_chars = (struct string_chars *) | |
| 2408 ((char *) old_data - offsetof (struct string_chars, chars)); | |
| 2409 /* Sanity check to make sure we aren't hosed by strange | |
| 2410 alignment/padding. */ | |
| 793 | 2411 assert (old_s_chars->string == XSTRING (s)); |
| 454 | 2412 MARK_STRING_CHARS_AS_FREE (old_s_chars); |
| 438 | 2413 ((struct unused_string_chars *) old_s_chars)->fullsize = |
| 2414 oldfullsize; | |
| 2415 } | |
| 428 | 2416 } |
| 438 | 2417 } |
| 2418 | |
| 793 | 2419 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta); |
| 438 | 2420 /* If pos < 0, the string won't be zero-terminated. |
| 2421 Terminate now just to make sure. */ | |
| 793 | 2422 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0'; |
| 438 | 2423 |
| 2424 if (pos >= 0) | |
| 793 | 2425 /* We also have to adjust all of the extent indices after the |
| 2426 place we did the change. We say "pos - 1" because | |
| 2427 adjust_extents() is exclusive of the starting position | |
| 2428 passed to it. */ | |
| 2429 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta); | |
| 428 | 2430 |
| 2431 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
| 2432 verify_string_chars_integrity (); | |
| 2433 #endif | |
| 2434 } | |
| 2435 | |
| 2436 #ifdef MULE | |
| 2437 | |
| 771 | 2438 /* WARNING: If you modify an existing string, you must call |
| 2439 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */ | |
| 428 | 2440 void |
| 867 | 2441 set_string_char (Lisp_Object s, Charcount i, Ichar c) |
| 428 | 2442 { |
| 867 | 2443 Ibyte newstr[MAX_ICHAR_LEN]; |
| 771 | 2444 Bytecount bytoff = string_index_char_to_byte (s, i); |
| 867 | 2445 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff); |
| 2446 Bytecount newlen = set_itext_ichar (newstr, c); | |
| 428 | 2447 |
| 793 | 2448 sledgehammer_check_ascii_begin (s); |
| 428 | 2449 if (oldlen != newlen) |
| 2450 resize_string (s, bytoff, newlen - oldlen); | |
| 793 | 2451 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */ |
| 2452 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen); | |
| 771 | 2453 if (oldlen != newlen) |
| 2454 { | |
| 793 | 2455 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s)) |
| 771 | 2456 /* Everything starting with the new char is no longer part of |
| 2457 ascii_begin */ | |
| 793 | 2458 XSET_STRING_ASCII_BEGIN (s, i); |
| 2459 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s)) | |
| 771 | 2460 /* We've extended ascii_begin, and we have to figure out how much by */ |
| 2461 { | |
| 2462 Bytecount j; | |
| 814 | 2463 for (j = (Bytecount) i + 1; j < XSTRING_LENGTH (s); j++) |
| 771 | 2464 { |
| 826 | 2465 if (!byte_ascii_p (XSTRING_DATA (s)[j])) |
| 771 | 2466 break; |
| 2467 } | |
| 814 | 2468 XSET_STRING_ASCII_BEGIN (s, min (j, (Bytecount) MAX_STRING_ASCII_BEGIN)); |
| 771 | 2469 } |
| 2470 } | |
| 793 | 2471 sledgehammer_check_ascii_begin (s); |
| 428 | 2472 } |
| 2473 | |
| 2474 #endif /* MULE */ | |
| 2475 | |
| 2476 DEFUN ("make-string", Fmake_string, 2, 2, 0, /* | |
| 444 | 2477 Return a new string consisting of LENGTH copies of CHARACTER. |
| 2478 LENGTH must be a non-negative integer. | |
| 428 | 2479 */ |
| 444 | 2480 (length, character)) |
| 428 | 2481 { |
| 2482 CHECK_NATNUM (length); | |
| 444 | 2483 CHECK_CHAR_COERCE_INT (character); |
| 428 | 2484 { |
| 867 | 2485 Ibyte init_str[MAX_ICHAR_LEN]; |
| 2486 int len = set_itext_ichar (init_str, XCHAR (character)); | |
| 428 | 2487 Lisp_Object val = make_uninit_string (len * XINT (length)); |
| 2488 | |
| 2489 if (len == 1) | |
| 771 | 2490 { |
| 2491 /* Optimize the single-byte case */ | |
| 2492 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val)); | |
| 793 | 2493 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN, |
| 2494 len * XINT (length))); | |
| 771 | 2495 } |
| 428 | 2496 else |
| 2497 { | |
| 647 | 2498 EMACS_INT i; |
| 867 | 2499 Ibyte *ptr = XSTRING_DATA (val); |
| 428 | 2500 |
| 2501 for (i = XINT (length); i; i--) | |
| 2502 { | |
| 867 | 2503 Ibyte *init_ptr = init_str; |
| 428 | 2504 switch (len) |
| 2505 { | |
| 2506 case 4: *ptr++ = *init_ptr++; | |
| 2507 case 3: *ptr++ = *init_ptr++; | |
| 2508 case 2: *ptr++ = *init_ptr++; | |
| 2509 case 1: *ptr++ = *init_ptr++; | |
| 2510 } | |
| 2511 } | |
| 2512 } | |
| 771 | 2513 sledgehammer_check_ascii_begin (val); |
| 428 | 2514 return val; |
| 2515 } | |
| 2516 } | |
| 2517 | |
| 2518 DEFUN ("string", Fstring, 0, MANY, 0, /* | |
| 2519 Concatenate all the argument characters and make the result a string. | |
| 2520 */ | |
| 2521 (int nargs, Lisp_Object *args)) | |
| 2522 { | |
| 2367 | 2523 Ibyte *storage = alloca_ibytes (nargs * MAX_ICHAR_LEN); |
| 867 | 2524 Ibyte *p = storage; |
| 428 | 2525 |
| 2526 for (; nargs; nargs--, args++) | |
| 2527 { | |
| 2528 Lisp_Object lisp_char = *args; | |
| 2529 CHECK_CHAR_COERCE_INT (lisp_char); | |
| 867 | 2530 p += set_itext_ichar (p, XCHAR (lisp_char)); |
| 428 | 2531 } |
| 2532 return make_string (storage, p - storage); | |
| 2533 } | |
| 2534 | |
| 771 | 2535 /* Initialize the ascii_begin member of a string to the correct value. */ |
| 2536 | |
| 2537 void | |
| 2538 init_string_ascii_begin (Lisp_Object string) | |
| 2539 { | |
| 2540 #ifdef MULE | |
| 2541 int i; | |
| 2542 Bytecount length = XSTRING_LENGTH (string); | |
| 867 | 2543 Ibyte *contents = XSTRING_DATA (string); |
| 771 | 2544 |
| 2545 for (i = 0; i < length; i++) | |
| 2546 { | |
| 826 | 2547 if (!byte_ascii_p (contents[i])) |
| 771 | 2548 break; |
| 2549 } | |
| 793 | 2550 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN)); |
| 771 | 2551 #else |
| 793 | 2552 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string), |
| 2553 MAX_STRING_ASCII_BEGIN)); | |
| 771 | 2554 #endif |
| 2555 sledgehammer_check_ascii_begin (string); | |
| 2556 } | |
| 428 | 2557 |
| 2558 /* Take some raw memory, which MUST already be in internal format, | |
| 2559 and package it up into a Lisp string. */ | |
| 2560 Lisp_Object | |
| 867 | 2561 make_string (const Ibyte *contents, Bytecount length) |
| 428 | 2562 { |
| 2563 Lisp_Object val; | |
| 2564 | |
| 2565 /* Make sure we find out about bad make_string's when they happen */ | |
| 800 | 2566 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
| 428 | 2567 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
| 2568 #endif | |
| 2569 | |
| 2570 val = make_uninit_string (length); | |
| 2571 memcpy (XSTRING_DATA (val), contents, length); | |
| 771 | 2572 init_string_ascii_begin (val); |
| 2573 sledgehammer_check_ascii_begin (val); | |
| 428 | 2574 return val; |
| 2575 } | |
| 2576 | |
| 2577 /* Take some raw memory, encoded in some external data format, | |
| 2578 and convert it into a Lisp string. */ | |
| 2579 Lisp_Object | |
| 442 | 2580 make_ext_string (const Extbyte *contents, EMACS_INT length, |
| 440 | 2581 Lisp_Object coding_system) |
| 428 | 2582 { |
| 440 | 2583 Lisp_Object string; |
| 2584 TO_INTERNAL_FORMAT (DATA, (contents, length), | |
| 2585 LISP_STRING, string, | |
| 2586 coding_system); | |
| 2587 return string; | |
| 428 | 2588 } |
| 2589 | |
| 2590 Lisp_Object | |
| 867 | 2591 build_intstring (const Ibyte *str) |
| 771 | 2592 { |
| 2593 /* Some strlen's crash and burn if passed null. */ | |
| 814 | 2594 return make_string (str, (str ? qxestrlen (str) : (Bytecount) 0)); |
| 771 | 2595 } |
| 2596 | |
| 2597 Lisp_Object | |
| 867 | 2598 build_string (const CIbyte *str) |
| 428 | 2599 { |
| 2600 /* Some strlen's crash and burn if passed null. */ | |
| 867 | 2601 return make_string ((const Ibyte *) str, (str ? strlen (str) : 0)); |
| 428 | 2602 } |
| 2603 | |
| 2604 Lisp_Object | |
| 593 | 2605 build_ext_string (const Extbyte *str, Lisp_Object coding_system) |
| 428 | 2606 { |
| 2607 /* Some strlen's crash and burn if passed null. */ | |
| 2367 | 2608 return make_ext_string ((const Extbyte *) str, |
| 2609 (str ? dfc_external_data_len (str, coding_system) : | |
| 2610 0), | |
| 440 | 2611 coding_system); |
| 428 | 2612 } |
| 2613 | |
| 2614 Lisp_Object | |
| 867 | 2615 build_msg_intstring (const Ibyte *str) |
| 428 | 2616 { |
| 771 | 2617 return build_intstring (GETTEXT (str)); |
| 2618 } | |
| 2619 | |
| 2620 Lisp_Object | |
| 867 | 2621 build_msg_string (const CIbyte *str) |
| 771 | 2622 { |
| 2623 return build_string (CGETTEXT (str)); | |
| 428 | 2624 } |
| 2625 | |
| 2626 Lisp_Object | |
| 867 | 2627 make_string_nocopy (const Ibyte *contents, Bytecount length) |
| 428 | 2628 { |
| 438 | 2629 Lisp_String *s; |
| 428 | 2630 Lisp_Object val; |
| 2631 | |
| 2632 /* Make sure we find out about bad make_string_nocopy's when they happen */ | |
| 800 | 2633 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
| 428 | 2634 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
| 2635 #endif | |
| 2636 | |
| 2637 /* Allocate the string header */ | |
| 438 | 2638 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
| 771 | 2639 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
| 2640 SET_C_READONLY_RECORD_HEADER (&s->u.lheader); | |
| 428 | 2641 s->plist = Qnil; |
| 867 | 2642 set_lispstringp_data (s, (Ibyte *) contents); |
| 826 | 2643 set_lispstringp_length (s, length); |
| 793 | 2644 val = wrap_string (s); |
| 771 | 2645 init_string_ascii_begin (val); |
| 2646 sledgehammer_check_ascii_begin (val); | |
| 2647 | |
| 428 | 2648 return val; |
| 2649 } | |
| 2650 | |
| 2651 | |
| 2652 /************************************************************************/ | |
| 2653 /* lcrecord lists */ | |
| 2654 /************************************************************************/ | |
| 2655 | |
| 2656 /* Lcrecord lists are used to manage the allocation of particular | |
| 1204 | 2657 sorts of lcrecords, to avoid calling basic_alloc_lcrecord() (and thus |
| 428 | 2658 malloc() and garbage-collection junk) as much as possible. |
| 2659 It is similar to the Blocktype class. | |
| 2660 | |
| 1204 | 2661 See detailed comment in lcrecord.h. |
| 2662 */ | |
| 2663 | |
| 2664 const struct memory_description free_description[] = { | |
| 2665 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, 0, | |
| 2666 XD_FLAG_FREE_LISP_OBJECT }, | |
| 2667 { XD_END } | |
| 2668 }; | |
| 2669 | |
| 2670 DEFINE_LRECORD_IMPLEMENTATION ("free", free, | |
| 2671 0, /*dumpable-flag*/ | |
| 2672 0, internal_object_printer, | |
| 2673 0, 0, 0, free_description, | |
| 2674 struct free_lcrecord_header); | |
| 2675 | |
| 2676 const struct memory_description lcrecord_list_description[] = { | |
| 2677 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, 0, | |
| 2678 XD_FLAG_FREE_LISP_OBJECT }, | |
| 2679 { XD_END } | |
| 2680 }; | |
| 428 | 2681 |
| 2682 static Lisp_Object | |
| 2683 mark_lcrecord_list (Lisp_Object obj) | |
| 2684 { | |
| 2685 struct lcrecord_list *list = XLCRECORD_LIST (obj); | |
| 2686 Lisp_Object chain = list->free; | |
| 2687 | |
| 2688 while (!NILP (chain)) | |
| 2689 { | |
| 2690 struct lrecord_header *lheader = XRECORD_LHEADER (chain); | |
| 2691 struct free_lcrecord_header *free_header = | |
| 2692 (struct free_lcrecord_header *) lheader; | |
| 2693 | |
| 442 | 2694 gc_checking_assert |
| 2695 (/* There should be no other pointers to the free list. */ | |
| 2696 ! MARKED_RECORD_HEADER_P (lheader) | |
| 2697 && | |
| 2698 /* Only lcrecords should be here. */ | |
| 1204 | 2699 ! list->implementation->basic_p |
| 442 | 2700 && |
| 2701 /* Only free lcrecords should be here. */ | |
| 2702 free_header->lcheader.free | |
| 2703 && | |
| 2704 /* The type of the lcrecord must be right. */ | |
| 1204 | 2705 lheader->type == lrecord_type_free |
| 442 | 2706 && |
| 2707 /* So must the size. */ | |
| 1204 | 2708 (list->implementation->static_size == 0 || |
| 2709 list->implementation->static_size == list->size) | |
| 442 | 2710 ); |
| 428 | 2711 |
| 2712 MARK_RECORD_HEADER (lheader); | |
| 2713 chain = free_header->chain; | |
| 2714 } | |
| 2715 | |
| 2716 return Qnil; | |
| 2717 } | |
| 2718 | |
| 934 | 2719 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list, |
| 2720 0, /*dumpable-flag*/ | |
| 2721 mark_lcrecord_list, internal_object_printer, | |
| 1204 | 2722 0, 0, 0, lcrecord_list_description, |
| 2723 struct lcrecord_list); | |
| 934 | 2724 |
| 428 | 2725 Lisp_Object |
| 665 | 2726 make_lcrecord_list (Elemcount size, |
| 442 | 2727 const struct lrecord_implementation *implementation) |
| 428 | 2728 { |
| 1204 | 2729 /* Don't use alloc_lcrecord_type() avoid infinite recursion |
| 2730 allocating this, */ | |
| 2731 struct lcrecord_list *p = (struct lcrecord_list *) | |
| 2732 basic_alloc_lcrecord (sizeof (struct lcrecord_list), | |
| 2733 &lrecord_lcrecord_list); | |
| 428 | 2734 |
| 2735 p->implementation = implementation; | |
| 2736 p->size = size; | |
| 2737 p->free = Qnil; | |
| 793 | 2738 return wrap_lcrecord_list (p); |
| 428 | 2739 } |
| 2740 | |
| 2741 Lisp_Object | |
| 1204 | 2742 alloc_managed_lcrecord (Lisp_Object lcrecord_list) |
| 428 | 2743 { |
| 2744 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
| 2745 if (!NILP (list->free)) | |
| 2746 { | |
| 2747 Lisp_Object val = list->free; | |
| 2748 struct free_lcrecord_header *free_header = | |
| 2749 (struct free_lcrecord_header *) XPNTR (val); | |
| 1204 | 2750 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
| 428 | 2751 |
| 2752 #ifdef ERROR_CHECK_GC | |
| 1204 | 2753 /* Major overkill here. */ |
| 428 | 2754 /* There should be no other pointers to the free list. */ |
| 442 | 2755 assert (! MARKED_RECORD_HEADER_P (lheader)); |
| 428 | 2756 /* Only free lcrecords should be here. */ |
| 2757 assert (free_header->lcheader.free); | |
| 1204 | 2758 assert (lheader->type == lrecord_type_free); |
| 2759 /* Only lcrecords should be here. */ | |
| 2760 assert (! (list->implementation->basic_p)); | |
| 2761 #if 0 /* Not used anymore, now that we set the type of the header to | |
| 2762 lrecord_type_free. */ | |
| 428 | 2763 /* The type of the lcrecord must be right. */ |
| 442 | 2764 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation); |
| 1204 | 2765 #endif /* 0 */ |
| 428 | 2766 /* So must the size. */ |
| 1204 | 2767 assert (list->implementation->static_size == 0 || |
| 2768 list->implementation->static_size == list->size); | |
| 428 | 2769 #endif /* ERROR_CHECK_GC */ |
| 442 | 2770 |
| 428 | 2771 list->free = free_header->chain; |
| 2772 free_header->lcheader.free = 0; | |
| 1204 | 2773 /* Put back the correct type, as we set it to lrecord_type_free. */ |
| 2774 lheader->type = list->implementation->lrecord_type_index; | |
| 2775 zero_sized_lcrecord (free_header, list->size); | |
| 428 | 2776 return val; |
| 2777 } | |
| 2778 else | |
| 1204 | 2779 return wrap_pointer_1 (basic_alloc_lcrecord (list->size, |
| 2780 list->implementation)); | |
| 428 | 2781 } |
| 2782 | |
| 771 | 2783 /* "Free" a Lisp object LCRECORD by placing it on its associated free list |
| 1204 | 2784 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the |
| 771 | 2785 same LCRECORD_LIST as its parameter, it will return an object from the |
| 2786 free list, which may be this one. Be VERY VERY SURE there are no | |
| 2787 pointers to this object hanging around anywhere where they might be | |
| 2788 used! | |
| 2789 | |
| 2790 The first thing this does before making any global state change is to | |
| 2791 call the finalize method of the object, if it exists. */ | |
| 2792 | |
| 428 | 2793 void |
| 2794 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) | |
| 2795 { | |
| 2796 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
| 2797 struct free_lcrecord_header *free_header = | |
| 2798 (struct free_lcrecord_header *) XPNTR (lcrecord); | |
| 442 | 2799 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
| 2800 const struct lrecord_implementation *implementation | |
| 428 | 2801 = LHEADER_IMPLEMENTATION (lheader); |
| 2802 | |
| 771 | 2803 /* Finalizer methods may try to free objects within them, which typically |
| 2804 won't be marked and thus are scheduled for demolition. Putting them | |
| 2805 on the free list would be very bad, as we'd have xfree()d memory in | |
| 2806 the list. Even if for some reason the objects are still live | |
| 2807 (generally a logic error!), we still will have problems putting such | |
| 2808 an object on the free list right now (e.g. we'd have to avoid calling | |
| 2809 the finalizer twice, etc.). So basically, those finalizers should not | |
| 2810 be freeing any objects if during GC. Abort now to catch those | |
| 2811 problems. */ | |
| 2812 gc_checking_assert (!gc_in_progress); | |
| 2813 | |
| 428 | 2814 /* Make sure the size is correct. This will catch, for example, |
| 2815 putting a window configuration on the wrong free list. */ | |
| 1204 | 2816 gc_checking_assert (detagged_lisp_object_size (lheader) == list->size); |
| 771 | 2817 /* Make sure the object isn't already freed. */ |
| 2818 gc_checking_assert (!free_header->lcheader.free); | |
| 2367 | 2819 /* Freeing stuff in dumped memory is bad. If you trip this, you |
| 2820 may need to check for this before freeing. */ | |
| 2821 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); | |
| 771 | 2822 |
| 428 | 2823 if (implementation->finalizer) |
| 2824 implementation->finalizer (lheader, 0); | |
| 1204 | 2825 /* Yes, there are two ways to indicate freeness -- the type is |
| 2826 lrecord_type_free or the ->free flag is set. We used to do only the | |
| 2827 latter; now we do the former as well for KKCC purposes. Probably | |
| 2828 safer in any case, as we will lose quicker this way than keeping | |
| 2829 around an lrecord of apparently correct type but bogus junk in it. */ | |
| 2830 MARK_LRECORD_AS_FREE (lheader); | |
| 428 | 2831 free_header->chain = list->free; |
| 2832 free_header->lcheader.free = 1; | |
| 2833 list->free = lcrecord; | |
| 2834 } | |
| 2835 | |
| 771 | 2836 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)]; |
| 2837 | |
| 2838 void * | |
| 2839 alloc_automanaged_lcrecord (Bytecount size, | |
| 2840 const struct lrecord_implementation *imp) | |
| 2841 { | |
| 2842 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero)) | |
| 2843 all_lcrecord_lists[imp->lrecord_type_index] = | |
| 2844 make_lcrecord_list (size, imp); | |
| 2845 | |
| 1204 | 2846 return XPNTR (alloc_managed_lcrecord |
| 771 | 2847 (all_lcrecord_lists[imp->lrecord_type_index])); |
| 2848 } | |
| 2849 | |
| 2850 void | |
| 2851 free_lcrecord (Lisp_Object rec) | |
| 2852 { | |
| 2853 int type = XRECORD_LHEADER (rec)->type; | |
| 2854 | |
| 2855 assert (!EQ (all_lcrecord_lists[type], Qzero)); | |
| 2856 | |
| 2857 free_managed_lcrecord (all_lcrecord_lists[type], rec); | |
| 2858 } | |
| 428 | 2859 |
| 2860 | |
| 2861 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /* | |
| 2862 Kept for compatibility, returns its argument. | |
| 2863 Old: | |
| 2864 Make a copy of OBJECT in pure storage. | |
| 2865 Recursively copies contents of vectors and cons cells. | |
| 2866 Does not copy symbols. | |
| 2867 */ | |
| 444 | 2868 (object)) |
| 428 | 2869 { |
| 444 | 2870 return object; |
| 428 | 2871 } |
| 2872 | |
| 2873 | |
| 2874 /************************************************************************/ | |
| 2875 /* Garbage Collection */ | |
| 2876 /************************************************************************/ | |
| 2877 | |
| 442 | 2878 /* All the built-in lisp object types are enumerated in `enum lrecord_type'. |
| 2879 Additional ones may be defined by a module (none yet). We leave some | |
| 2880 room in `lrecord_implementations_table' for such new lisp object types. */ | |
| 647 | 2881 const struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; |
| 2882 int lrecord_type_count = lrecord_type_last_built_in_type; | |
| 1676 | 2883 #ifndef USE_KKCC |
| 442 | 2884 /* Object marker functions are in the lrecord_implementation structure. |
| 2885 But copying them to a parallel array is much more cache-friendly. | |
| 2886 This hack speeds up (garbage-collect) by about 5%. */ | |
| 2887 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); | |
| 1676 | 2888 #endif /* not USE_KKCC */ |
| 428 | 2889 |
| 2890 struct gcpro *gcprolist; | |
| 2891 | |
| 771 | 2892 /* We want the staticpro list relocated, but not the pointers found |
| 2893 therein, because they refer to locations in the global data segment, not | |
| 2894 in the heap; we only dump heap objects. Hence we use a trivial | |
| 2895 description, as for pointerless objects. (Note that the data segment | |
| 2896 objects, which are global variables like Qfoo or Vbar, themselves are | |
| 2897 pointers to heap objects. Each needs to be described to pdump as a | |
| 2898 "root pointer"; this happens in the call to staticpro(). */ | |
| 1204 | 2899 static const struct memory_description staticpro_description_1[] = { |
| 452 | 2900 { XD_END } |
| 2901 }; | |
| 2902 | |
| 1204 | 2903 static const struct sized_memory_description staticpro_description = { |
| 452 | 2904 sizeof (Lisp_Object *), |
| 2905 staticpro_description_1 | |
| 2906 }; | |
| 2907 | |
| 1204 | 2908 static const struct memory_description staticpros_description_1[] = { |
| 452 | 2909 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description), |
| 2910 { XD_END } | |
| 2911 }; | |
| 2912 | |
| 1204 | 2913 static const struct sized_memory_description staticpros_description = { |
| 452 | 2914 sizeof (Lisp_Object_ptr_dynarr), |
| 2915 staticpros_description_1 | |
| 2916 }; | |
| 2917 | |
| 771 | 2918 #ifdef DEBUG_XEMACS |
| 2919 | |
| 1204 | 2920 static const struct memory_description staticpro_one_name_description_1[] = { |
| 2367 | 2921 { XD_ASCII_STRING, 0 }, |
| 771 | 2922 { XD_END } |
| 2923 }; | |
| 2924 | |
| 1204 | 2925 static const struct sized_memory_description staticpro_one_name_description = { |
| 771 | 2926 sizeof (char *), |
| 2927 staticpro_one_name_description_1 | |
| 2928 }; | |
| 2929 | |
| 1204 | 2930 static const struct memory_description staticpro_names_description_1[] = { |
| 771 | 2931 XD_DYNARR_DESC (char_ptr_dynarr, &staticpro_one_name_description), |
| 2932 { XD_END } | |
| 2933 }; | |
| 2934 | |
| 1204 | 2935 |
| 2936 extern const struct sized_memory_description staticpro_names_description; | |
| 2937 | |
| 2938 const struct sized_memory_description staticpro_names_description = { | |
| 771 | 2939 sizeof (char_ptr_dynarr), |
| 2940 staticpro_names_description_1 | |
| 2941 }; | |
| 2942 | |
| 2943 /* Help debug crashes gc-marking a staticpro'ed object. */ | |
| 2944 | |
| 2945 Lisp_Object_ptr_dynarr *staticpros; | |
| 2946 char_ptr_dynarr *staticpro_names; | |
| 2947 | |
| 2948 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 2949 garbage collection, and for dumping. */ | |
| 2950 void | |
| 2951 staticpro_1 (Lisp_Object *varaddress, char *varname) | |
| 2952 { | |
| 2953 Dynarr_add (staticpros, varaddress); | |
| 2954 Dynarr_add (staticpro_names, varname); | |
| 1204 | 2955 dump_add_root_lisp_object (varaddress); |
| 771 | 2956 } |
| 2957 | |
| 2958 | |
| 2959 Lisp_Object_ptr_dynarr *staticpros_nodump; | |
| 2960 char_ptr_dynarr *staticpro_nodump_names; | |
| 2961 | |
| 2962 /* Mark the Lisp_Object at heap VARADDRESS as a root object for | |
| 2963 garbage collection, but not for dumping. (See below.) */ | |
| 2964 void | |
| 2965 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname) | |
| 2966 { | |
| 2967 Dynarr_add (staticpros_nodump, varaddress); | |
| 2968 Dynarr_add (staticpro_nodump_names, varname); | |
| 2969 } | |
| 2970 | |
| 996 | 2971 #ifdef HAVE_SHLIB |
| 2972 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object | |
| 2973 for garbage collection, but not for dumping. */ | |
| 2974 void | |
| 2975 unstaticpro_nodump_1 (Lisp_Object *varaddress, char *varname) | |
| 2976 { | |
| 2977 Dynarr_delete_object (staticpros, varaddress); | |
| 2978 Dynarr_delete_object (staticpro_names, varname); | |
| 2979 } | |
| 2980 #endif | |
| 2981 | |
| 771 | 2982 #else /* not DEBUG_XEMACS */ |
| 2983 | |
| 452 | 2984 Lisp_Object_ptr_dynarr *staticpros; |
| 2985 | |
| 2986 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 2987 garbage collection, and for dumping. */ | |
| 428 | 2988 void |
| 2989 staticpro (Lisp_Object *varaddress) | |
| 2990 { | |
| 452 | 2991 Dynarr_add (staticpros, varaddress); |
| 1204 | 2992 dump_add_root_lisp_object (varaddress); |
| 428 | 2993 } |
| 2994 | |
| 442 | 2995 |
| 452 | 2996 Lisp_Object_ptr_dynarr *staticpros_nodump; |
| 2997 | |
| 771 | 2998 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage |
| 2999 collection, but not for dumping. This is used for objects where the | |
| 3000 only sure pointer is in the heap (rather than in the global data | |
| 3001 segment, as must be the case for pdump root pointers), but not inside of | |
| 3002 another Lisp object (where it will be marked as a result of that Lisp | |
| 3003 object's mark method). The call to staticpro_nodump() must occur *BOTH* | |
| 3004 at initialization time and at "reinitialization" time (startup, after | |
| 3005 pdump load.) (For example, this is the case with the predicate symbols | |
| 3006 for specifier and coding system types. The pointer to this symbol is | |
| 3007 inside of a methods structure, which is allocated on the heap. The | |
| 3008 methods structure will be written out to the pdump data file, and may be | |
| 3009 reloaded at a different address.) | |
| 3010 | |
| 3011 #### The necessity for reinitialization is a bug in pdump. Pdump should | |
| 3012 automatically regenerate the staticpro()s for these symbols when it | |
| 3013 loads the data in. */ | |
| 3014 | |
| 428 | 3015 void |
| 3016 staticpro_nodump (Lisp_Object *varaddress) | |
| 3017 { | |
| 452 | 3018 Dynarr_add (staticpros_nodump, varaddress); |
| 428 | 3019 } |
| 3020 | |
| 996 | 3021 #ifdef HAVE_SHLIB |
| 3022 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3023 garbage collection, but not for dumping. */ | |
| 3024 void | |
| 3025 unstaticpro_nodump (Lisp_Object *varaddress) | |
| 3026 { | |
| 3027 Dynarr_delete_object (staticpros, varaddress); | |
| 3028 } | |
| 3029 #endif | |
| 3030 | |
| 771 | 3031 #endif /* not DEBUG_XEMACS */ |
| 3032 | |
| 442 | 3033 #ifdef ERROR_CHECK_GC |
| 3034 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ | |
| 3035 struct lrecord_header * GCLI_lh = (lheader); \ | |
| 3036 assert (GCLI_lh != 0); \ | |
| 647 | 3037 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \ |
| 442 | 3038 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \ |
| 3039 (MARKED_RECORD_HEADER_P (GCLI_lh) && \ | |
| 3040 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \ | |
| 3041 } while (0) | |
| 3042 #else | |
| 3043 #define GC_CHECK_LHEADER_INVARIANTS(lheader) | |
| 3044 #endif | |
| 3045 | |
| 934 | 3046 |
| 1204 | 3047 static const struct memory_description lisp_object_description_1[] = { |
| 3048 { XD_LISP_OBJECT, 0 }, | |
| 3049 { XD_END } | |
| 3050 }; | |
| 3051 | |
| 3052 const struct sized_memory_description lisp_object_description = { | |
| 3053 sizeof (Lisp_Object), | |
| 3054 lisp_object_description_1 | |
| 3055 }; | |
| 3056 | |
| 3057 #if defined (USE_KKCC) || defined (PDUMP) | |
| 934 | 3058 |
| 3059 /* This function extracts the value of a count variable described somewhere | |
| 3060 else in the description. It is converted corresponding to the type */ | |
| 1204 | 3061 EMACS_INT |
| 3062 lispdesc_indirect_count_1 (EMACS_INT code, | |
| 3063 const struct memory_description *idesc, | |
| 3064 const void *idata) | |
| 934 | 3065 { |
| 3066 EMACS_INT count; | |
| 3067 const void *irdata; | |
| 3068 | |
| 3069 int line = XD_INDIRECT_VAL (code); | |
| 3070 int delta = XD_INDIRECT_DELTA (code); | |
| 3071 | |
| 1204 | 3072 irdata = ((char *) idata) + |
| 3073 lispdesc_indirect_count (idesc[line].offset, idesc, idata); | |
| 934 | 3074 switch (idesc[line].type) |
| 3075 { | |
| 3076 case XD_BYTECOUNT: | |
| 1204 | 3077 count = * (Bytecount *) irdata; |
| 934 | 3078 break; |
| 3079 case XD_ELEMCOUNT: | |
| 1204 | 3080 count = * (Elemcount *) irdata; |
| 934 | 3081 break; |
| 3082 case XD_HASHCODE: | |
| 1204 | 3083 count = * (Hashcode *) irdata; |
| 934 | 3084 break; |
| 3085 case XD_INT: | |
| 1204 | 3086 count = * (int *) irdata; |
| 934 | 3087 break; |
| 3088 case XD_LONG: | |
| 1204 | 3089 count = * (long *) irdata; |
| 934 | 3090 break; |
| 3091 default: | |
| 3092 stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n", | |
| 1204 | 3093 idesc[line].type, line, (long) code); |
| 3094 #ifdef PDUMP | |
| 3095 if (in_pdump) | |
| 3096 pdump_backtrace (); | |
| 3097 #endif | |
| 934 | 3098 count = 0; /* warning suppression */ |
| 2500 | 3099 ABORT (); |
| 934 | 3100 } |
| 3101 count += delta; | |
| 3102 return count; | |
| 3103 } | |
| 3104 | |
| 1204 | 3105 /* SDESC is a "description map" (basically, a list of offsets used for |
| 3106 successive indirections) and OBJ is the first object to indirect off of. | |
| 3107 Return the description ultimately found. */ | |
| 3108 | |
| 3109 const struct sized_memory_description * | |
| 3110 lispdesc_indirect_description_1 (const void *obj, | |
| 3111 const struct sized_memory_description *sdesc) | |
| 934 | 3112 { |
| 3113 int pos; | |
| 3114 | |
| 1204 | 3115 for (pos = 0; sdesc[pos].size >= 0; pos++) |
| 3116 obj = * (const void **) ((const char *) obj + sdesc[pos].size); | |
| 3117 | |
| 3118 return (const struct sized_memory_description *) obj; | |
| 3119 } | |
| 3120 | |
| 3121 /* Compute the size of the data at RDATA, described by a single entry | |
| 3122 DESC1 in a description array. OBJ and DESC are used for | |
| 3123 XD_INDIRECT references. */ | |
| 3124 | |
| 3125 static Bytecount | |
| 3126 lispdesc_one_description_line_size (void *rdata, | |
| 3127 const struct memory_description *desc1, | |
| 3128 const void *obj, | |
| 3129 const struct memory_description *desc) | |
| 3130 { | |
| 3131 union_switcheroo: | |
| 3132 switch (desc1->type) | |
| 934 | 3133 { |
| 1204 | 3134 case XD_LISP_OBJECT_ARRAY: |
| 3135 { | |
| 3136 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); | |
| 3137 return (val * sizeof (Lisp_Object)); | |
| 3138 } | |
| 3139 case XD_LISP_OBJECT: | |
| 3140 case XD_LO_LINK: | |
| 3141 return sizeof (Lisp_Object); | |
| 3142 case XD_OPAQUE_PTR: | |
| 3143 return sizeof (void *); | |
| 2367 | 3144 case XD_BLOCK_PTR: |
| 1204 | 3145 { |
| 3146 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); | |
| 3147 return val * sizeof (void *); | |
| 3148 } | |
| 2367 | 3149 case XD_BLOCK_ARRAY: |
| 1204 | 3150 { |
| 3151 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); | |
| 3152 | |
| 3153 return (val * | |
| 2367 | 3154 lispdesc_block_size |
| 1204 | 3155 (rdata, lispdesc_indirect_description (obj, desc1->data2))); |
| 3156 } | |
| 3157 case XD_OPAQUE_DATA_PTR: | |
| 3158 return sizeof (void *); | |
| 3159 case XD_UNION_DYNAMIC_SIZE: | |
| 3160 { | |
| 3161 /* If an explicit size was given in the first-level structure | |
| 3162 description, use it; else compute size based on current union | |
| 3163 constant. */ | |
| 3164 const struct sized_memory_description *sdesc = | |
| 3165 lispdesc_indirect_description (obj, desc1->data2); | |
| 3166 if (sdesc->size) | |
| 3167 return sdesc->size; | |
| 3168 else | |
| 3169 { | |
| 3170 desc1 = lispdesc_process_xd_union (desc1, desc, obj); | |
| 3171 if (desc1) | |
| 3172 goto union_switcheroo; | |
| 934 | 3173 break; |
| 1204 | 3174 } |
| 3175 } | |
| 3176 case XD_UNION: | |
| 3177 { | |
| 3178 /* If an explicit size was given in the first-level structure | |
| 3179 description, use it; else compute size based on maximum of all | |
| 3180 possible structures. */ | |
| 3181 const struct sized_memory_description *sdesc = | |
| 3182 lispdesc_indirect_description (obj, desc1->data2); | |
| 3183 if (sdesc->size) | |
| 3184 return sdesc->size; | |
| 3185 else | |
| 3186 { | |
| 3187 int count; | |
| 3188 Bytecount max_size = -1, size; | |
| 3189 | |
| 3190 desc1 = sdesc->description; | |
| 3191 | |
| 3192 for (count = 0; desc1[count].type != XD_END; count++) | |
| 3193 { | |
| 3194 size = lispdesc_one_description_line_size (rdata, | |
| 3195 &desc1[count], | |
| 3196 obj, desc); | |
| 3197 if (size > max_size) | |
| 3198 max_size = size; | |
| 3199 } | |
| 3200 return max_size; | |
| 3201 } | |
| 934 | 3202 } |
| 2367 | 3203 case XD_ASCII_STRING: |
| 1204 | 3204 return sizeof (void *); |
| 3205 case XD_DOC_STRING: | |
| 3206 return sizeof (void *); | |
| 3207 case XD_INT_RESET: | |
| 3208 return sizeof (int); | |
| 3209 case XD_BYTECOUNT: | |
| 3210 return sizeof (Bytecount); | |
| 3211 case XD_ELEMCOUNT: | |
| 3212 return sizeof (Elemcount); | |
| 3213 case XD_HASHCODE: | |
| 3214 return sizeof (Hashcode); | |
| 3215 case XD_INT: | |
| 3216 return sizeof (int); | |
| 3217 case XD_LONG: | |
| 3218 return sizeof (long); | |
| 3219 default: | |
| 3220 stderr_out ("Unsupported dump type : %d\n", desc1->type); | |
| 2500 | 3221 ABORT (); |
| 934 | 3222 } |
| 3223 | |
| 1204 | 3224 return 0; |
| 934 | 3225 } |
| 3226 | |
| 3227 | |
| 1204 | 3228 /* Return the size of the memory block (NOT necessarily a structure!) |
| 3229 described by SDESC and pointed to by OBJ. If SDESC records an | |
| 3230 explicit size (i.e. non-zero), it is simply returned; otherwise, | |
| 3231 the size is calculated by the maximum offset and the size of the | |
| 3232 object at that offset, rounded up to the maximum alignment. In | |
| 3233 this case, we may need the object, for example when retrieving an | |
| 3234 "indirect count" of an inlined array (the count is not constant, | |
| 3235 but is specified by one of the elements of the memory block). (It | |
| 3236 is generally not a problem if we return an overly large size -- we | |
| 3237 will simply end up reserving more space than necessary; but if the | |
| 3238 size is too small we could be in serious trouble, in particular | |
| 3239 with nested inlined structures, where there may be alignment | |
| 3240 padding in the middle of a block. #### In fact there is an (at | |
| 3241 least theoretical) problem with an overly large size -- we may | |
| 3242 trigger a protection fault when reading from invalid memory. We | |
| 3243 need to handle this -- perhaps in a stupid but dependable way, | |
| 3244 i.e. by trapping SIGSEGV and SIGBUS.) */ | |
| 3245 | |
| 3246 Bytecount | |
| 2367 | 3247 lispdesc_block_size_1 (const void *obj, Bytecount size, |
| 3248 const struct memory_description *desc) | |
| 934 | 3249 { |
| 1204 | 3250 EMACS_INT max_offset = -1; |
| 934 | 3251 int max_offset_pos = -1; |
| 3252 int pos; | |
| 2367 | 3253 |
| 3254 if (size) | |
| 3255 return size; | |
| 934 | 3256 |
| 3257 for (pos = 0; desc[pos].type != XD_END; pos++) | |
| 3258 { | |
| 1204 | 3259 EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj); |
| 3260 if (offset == max_offset) | |
| 934 | 3261 { |
| 3262 stderr_out ("Two relocatable elements at same offset?\n"); | |
| 2500 | 3263 ABORT (); |
| 934 | 3264 } |
| 1204 | 3265 else if (offset > max_offset) |
| 934 | 3266 { |
| 1204 | 3267 max_offset = offset; |
| 934 | 3268 max_offset_pos = pos; |
| 3269 } | |
| 3270 } | |
| 3271 | |
| 3272 if (max_offset_pos < 0) | |
| 3273 return 0; | |
| 3274 | |
| 1204 | 3275 { |
| 3276 Bytecount size_at_max; | |
| 3277 size_at_max = | |
| 3278 lispdesc_one_description_line_size ((char *) obj + max_offset, | |
| 3279 &desc[max_offset_pos], obj, desc); | |
| 3280 | |
| 3281 /* We have no way of knowing the required alignment for this structure, | |
| 3282 so just make it maximally aligned. */ | |
| 3283 return MAX_ALIGN_SIZE (max_offset + size_at_max); | |
| 3284 } | |
| 3285 } | |
| 3286 | |
| 3287 #endif /* defined (USE_KKCC) || defined (PDUMP) */ | |
| 3288 | |
| 1276 | 3289 #define GC_CHECK_NOT_FREE(lheader) \ |
| 3290 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ | |
| 3291 ! ((struct lcrecord_header *) lheader)->free) | |
| 3292 | |
| 1204 | 3293 #ifdef USE_KKCC |
| 3294 /* The following functions implement the new mark algorithm. | |
| 3295 They mark objects according to their descriptions. They | |
| 3296 are modeled on the corresponding pdumper procedures. */ | |
| 3297 | |
| 1676 | 3298 /* Object memory descriptions are in the lrecord_implementation structure. |
| 3299 But copying them to a parallel array is much more cache-friendly. */ | |
| 3300 const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)]; | |
| 3301 | |
| 3302 /* the initial stack size in kkcc_gc_stack_entries */ | |
| 3303 #define KKCC_INIT_GC_STACK_SIZE 16384 | |
| 3304 | |
| 3305 typedef struct | |
| 3306 { | |
| 3307 void *data; | |
| 3308 const struct memory_description *desc; | |
| 3309 } kkcc_gc_stack_entry; | |
| 3310 | |
| 3311 static kkcc_gc_stack_entry *kkcc_gc_stack_ptr; | |
| 3312 static kkcc_gc_stack_entry *kkcc_gc_stack_top; | |
| 3313 static kkcc_gc_stack_entry *kkcc_gc_stack_last_entry; | |
| 3314 static int kkcc_gc_stack_size; | |
| 3315 | |
| 3316 static void | |
| 3317 kkcc_gc_stack_init (void) | |
| 3318 { | |
| 3319 kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE; | |
| 3320 kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) | |
| 3321 malloc (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); | |
| 3322 if (!kkcc_gc_stack_ptr) | |
| 3323 { | |
| 3324 stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size); | |
| 3325 exit(23); | |
| 3326 } | |
| 3327 kkcc_gc_stack_top = kkcc_gc_stack_ptr - 1; | |
| 3328 kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1; | |
| 3329 } | |
| 3330 | |
| 3331 static void | |
| 3332 kkcc_gc_stack_free (void) | |
| 3333 { | |
| 3334 free (kkcc_gc_stack_ptr); | |
| 3335 kkcc_gc_stack_ptr = 0; | |
| 3336 kkcc_gc_stack_top = 0; | |
| 3337 kkcc_gc_stack_size = 0; | |
| 3338 } | |
| 3339 | |
| 3340 static void | |
| 3341 kkcc_gc_stack_realloc (void) | |
| 3342 { | |
| 3343 int current_offset = (int)(kkcc_gc_stack_top - kkcc_gc_stack_ptr); | |
| 3344 kkcc_gc_stack_size *= 2; | |
| 3345 kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) | |
| 3346 realloc (kkcc_gc_stack_ptr, | |
| 3347 kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); | |
| 3348 if (!kkcc_gc_stack_ptr) | |
| 3349 { | |
| 3350 stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size); | |
| 3351 exit(23); | |
| 3352 } | |
| 3353 kkcc_gc_stack_top = kkcc_gc_stack_ptr + current_offset; | |
| 3354 kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1; | |
| 3355 } | |
| 3356 | |
| 3357 #define KKCC_GC_STACK_FULL (kkcc_gc_stack_top >= kkcc_gc_stack_last_entry) | |
| 3358 #define KKCC_GC_STACK_EMPTY (kkcc_gc_stack_top < kkcc_gc_stack_ptr) | |
| 3359 | |
| 3360 static void | |
| 3361 kkcc_gc_stack_push (void *data, const struct memory_description *desc) | |
| 3362 { | |
| 3363 if (KKCC_GC_STACK_FULL) | |
| 3364 kkcc_gc_stack_realloc(); | |
| 3365 kkcc_gc_stack_top++; | |
| 3366 kkcc_gc_stack_top->data = data; | |
| 3367 kkcc_gc_stack_top->desc = desc; | |
| 3368 } | |
| 3369 | |
| 3370 static kkcc_gc_stack_entry * | |
| 3371 kkcc_gc_stack_pop (void) | |
| 3372 { | |
| 3373 if (KKCC_GC_STACK_EMPTY) | |
| 3374 return 0; | |
| 3375 kkcc_gc_stack_top--; | |
| 3376 return kkcc_gc_stack_top + 1; | |
| 3377 } | |
| 3378 | |
| 3379 void | |
| 3380 kkcc_gc_stack_push_lisp_object (Lisp_Object obj) | |
| 3381 { | |
| 3382 if (XTYPE (obj) == Lisp_Type_Record) | |
| 3383 { | |
| 3384 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 3385 const struct memory_description *desc; | |
| 3386 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 3387 desc = RECORD_DESCRIPTION (lheader); | |
| 3388 if (! MARKED_RECORD_HEADER_P (lheader)) | |
| 3389 { | |
| 3390 MARK_RECORD_HEADER (lheader); | |
| 3391 kkcc_gc_stack_push((void*) lheader, desc); | |
| 3392 } | |
| 3393 } | |
| 3394 } | |
| 3395 | |
| 1265 | 3396 #ifdef ERROR_CHECK_GC |
| 3397 #define KKCC_DO_CHECK_FREE(obj, allow_free) \ | |
| 3398 do \ | |
| 3399 { \ | |
| 3400 if (!allow_free && XTYPE (obj) == Lisp_Type_Record) \ | |
| 3401 { \ | |
| 3402 struct lrecord_header *lheader = XRECORD_LHEADER (obj); \ | |
| 3403 GC_CHECK_NOT_FREE (lheader); \ | |
| 3404 } \ | |
| 3405 } while (0) | |
| 3406 #else | |
| 3407 #define KKCC_DO_CHECK_FREE(obj, allow_free) | |
| 3408 #endif | |
| 1204 | 3409 |
| 3410 #ifdef ERROR_CHECK_GC | |
| 1598 | 3411 static void |
| 1204 | 3412 mark_object_maybe_checking_free (Lisp_Object obj, int allow_free) |
| 3413 { | |
| 1265 | 3414 KKCC_DO_CHECK_FREE (obj, allow_free); |
| 1598 | 3415 kkcc_gc_stack_push_lisp_object (obj); |
| 1204 | 3416 } |
| 3417 #else | |
| 1643 | 3418 #define mark_object_maybe_checking_free(obj, allow_free) \ |
| 3419 kkcc_gc_stack_push_lisp_object (obj) | |
| 1204 | 3420 #endif /* ERROR_CHECK_GC */ |
| 3421 | |
| 934 | 3422 |
| 3423 /* This function loops all elements of a struct pointer and calls | |
| 3424 mark_with_description with each element. */ | |
| 3425 static void | |
| 3426 mark_struct_contents (const void *data, | |
| 1204 | 3427 const struct sized_memory_description *sdesc, |
| 3428 int count) | |
| 934 | 3429 { |
| 3430 int i; | |
| 3431 Bytecount elsize; | |
| 2367 | 3432 elsize = lispdesc_block_size (data, sdesc); |
| 934 | 3433 |
| 3434 for (i = 0; i < count; i++) | |
| 3435 { | |
| 1598 | 3436 kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description); |
| 934 | 3437 } |
| 3438 } | |
| 3439 | |
| 1598 | 3440 |
| 3441 /* This function implements the KKCC mark algorithm. | |
| 3442 Instead of calling mark_object, all the alive Lisp_Objects are pushed | |
| 3443 on the kkcc_gc_stack. This function processes all elements on the stack | |
| 3444 according to their descriptions. */ | |
| 3445 static void | |
| 3446 kkcc_marking (void) | |
| 3447 { | |
| 3448 kkcc_gc_stack_entry *stack_entry = 0; | |
| 3449 void *data = 0; | |
| 3450 const struct memory_description *desc = 0; | |
| 3451 int pos; | |
| 3452 | |
| 3453 while ((stack_entry = kkcc_gc_stack_pop ()) != 0) | |
| 3454 { | |
| 3455 data = stack_entry->data; | |
| 3456 desc = stack_entry->desc; | |
| 3457 | |
| 3458 for (pos = 0; desc[pos].type != XD_END; pos++) | |
| 3459 { | |
| 3460 const struct memory_description *desc1 = &desc[pos]; | |
| 3461 const void *rdata = | |
| 3462 (const char *) data + lispdesc_indirect_count (desc1->offset, | |
| 3463 desc, data); | |
| 3464 union_switcheroo: | |
| 3465 | |
| 3466 /* If the flag says don't mark, then don't mark. */ | |
| 3467 if ((desc1->flags) & XD_FLAG_NO_KKCC) | |
| 3468 continue; | |
| 3469 | |
| 3470 switch (desc1->type) | |
| 3471 { | |
| 3472 case XD_BYTECOUNT: | |
| 3473 case XD_ELEMCOUNT: | |
| 3474 case XD_HASHCODE: | |
| 3475 case XD_INT: | |
| 3476 case XD_LONG: | |
| 3477 case XD_INT_RESET: | |
| 3478 case XD_LO_LINK: | |
| 3479 case XD_OPAQUE_PTR: | |
| 3480 case XD_OPAQUE_DATA_PTR: | |
| 2367 | 3481 case XD_ASCII_STRING: |
| 1598 | 3482 case XD_DOC_STRING: |
| 3483 break; | |
| 3484 case XD_LISP_OBJECT: | |
| 3485 { | |
| 3486 const Lisp_Object *stored_obj = (const Lisp_Object *) rdata; | |
| 3487 | |
| 3488 /* Because of the way that tagged objects work (pointers and | |
| 3489 Lisp_Objects have the same representation), XD_LISP_OBJECT | |
| 3490 can be used for untagged pointers. They might be NULL, | |
| 3491 though. */ | |
| 3492 if (EQ (*stored_obj, Qnull_pointer)) | |
| 3493 break; | |
| 3494 mark_object_maybe_checking_free | |
| 3495 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT); | |
| 3496 | |
| 3497 break; | |
| 3498 } | |
| 3499 case XD_LISP_OBJECT_ARRAY: | |
| 3500 { | |
| 3501 int i; | |
| 3502 EMACS_INT count = | |
| 3503 lispdesc_indirect_count (desc1->data1, desc, data); | |
| 3504 | |
| 3505 for (i = 0; i < count; i++) | |
| 3506 { | |
| 3507 const Lisp_Object *stored_obj = | |
| 3508 (const Lisp_Object *) rdata + i; | |
| 3509 | |
| 3510 if (EQ (*stored_obj, Qnull_pointer)) | |
| 3511 break; | |
| 3512 | |
| 3513 mark_object_maybe_checking_free | |
| 3514 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT); | |
| 3515 } | |
| 3516 break; | |
| 3517 } | |
| 2367 | 3518 case XD_BLOCK_PTR: |
| 1598 | 3519 { |
| 3520 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, | |
| 3521 data); | |
| 3522 const struct sized_memory_description *sdesc = | |
| 3523 lispdesc_indirect_description (data, desc1->data2); | |
| 3524 const char *dobj = * (const char **) rdata; | |
| 3525 if (dobj) | |
| 3526 mark_struct_contents (dobj, sdesc, count); | |
| 3527 break; | |
| 3528 } | |
| 2367 | 3529 case XD_BLOCK_ARRAY: |
| 1598 | 3530 { |
| 3531 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, | |
| 3532 data); | |
| 3533 const struct sized_memory_description *sdesc = | |
| 3534 lispdesc_indirect_description (data, desc1->data2); | |
| 3535 | |
| 3536 mark_struct_contents (rdata, sdesc, count); | |
| 3537 break; | |
| 3538 } | |
| 3539 case XD_UNION: | |
| 3540 case XD_UNION_DYNAMIC_SIZE: | |
| 3541 desc1 = lispdesc_process_xd_union (desc1, desc, data); | |
| 3542 if (desc1) | |
| 3543 goto union_switcheroo; | |
| 3544 break; | |
| 3545 | |
| 3546 default: | |
| 3547 stderr_out ("Unsupported description type : %d\n", desc1->type); | |
| 2500 | 3548 ABORT (); |
| 1598 | 3549 } |
| 3550 } | |
| 3551 } | |
| 3552 } | |
| 934 | 3553 #endif /* USE_KKCC */ |
| 3554 | |
| 428 | 3555 /* Mark reference to a Lisp_Object. If the object referred to has not been |
| 3556 seen yet, recursively mark all the references contained in it. */ | |
| 3557 | |
| 3558 void | |
| 2286 | 3559 mark_object ( |
| 3560 #ifdef USE_KKCC | |
| 3561 Lisp_Object UNUSED (obj) | |
| 3562 #else | |
| 3563 Lisp_Object obj | |
| 3564 #endif | |
| 3565 ) | |
| 428 | 3566 { |
| 1598 | 3567 #ifdef USE_KKCC |
| 3568 /* this code should never be reached when configured for KKCC */ | |
| 3569 stderr_out ("KKCC: Invalid mark_object call.\n"); | |
| 3570 stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n"); | |
| 2500 | 3571 ABORT (); |
| 1676 | 3572 #else /* not USE_KKCC */ |
| 1598 | 3573 |
| 428 | 3574 tail_recurse: |
| 3575 | |
| 3576 /* Checks we used to perform */ | |
| 3577 /* if (EQ (obj, Qnull_pointer)) return; */ | |
| 3578 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ | |
| 3579 /* if (PURIFIED (XPNTR (obj))) return; */ | |
| 3580 | |
| 3581 if (XTYPE (obj) == Lisp_Type_Record) | |
| 3582 { | |
| 3583 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 442 | 3584 |
| 3585 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 3586 | |
| 1204 | 3587 /* We handle this separately, above, so we can mark free objects */ |
| 1265 | 3588 GC_CHECK_NOT_FREE (lheader); |
| 1204 | 3589 |
| 442 | 3590 /* All c_readonly objects have their mark bit set, |
| 3591 so that we only need to check the mark bit here. */ | |
| 3592 if (! MARKED_RECORD_HEADER_P (lheader)) | |
| 428 | 3593 { |
| 3594 MARK_RECORD_HEADER (lheader); | |
| 442 | 3595 |
| 1598 | 3596 if (RECORD_MARKER (lheader)) |
| 3597 { | |
| 3598 obj = RECORD_MARKER (lheader) (obj); | |
| 3599 if (!NILP (obj)) goto tail_recurse; | |
| 3600 } | |
| 428 | 3601 } |
| 3602 } | |
| 1676 | 3603 #endif /* not KKCC */ |
| 428 | 3604 } |
| 3605 | |
| 3606 | |
| 3607 static int gc_count_num_short_string_in_use; | |
| 647 | 3608 static Bytecount gc_count_string_total_size; |
| 3609 static Bytecount gc_count_short_string_total_size; | |
| 428 | 3610 |
| 3611 /* static int gc_count_total_records_used, gc_count_records_total_size; */ | |
| 3612 | |
| 3613 | |
| 3614 /* stats on lcrecords in use - kinda kludgy */ | |
| 3615 | |
| 3616 static struct | |
| 3617 { | |
| 3618 int instances_in_use; | |
| 3619 int bytes_in_use; | |
| 3620 int instances_freed; | |
| 3621 int bytes_freed; | |
| 3622 int instances_on_free_list; | |
| 707 | 3623 } lcrecord_stats [countof (lrecord_implementations_table) |
| 3624 + MODULE_DEFINABLE_TYPE_COUNT]; | |
| 428 | 3625 |
| 3626 static void | |
| 442 | 3627 tick_lcrecord_stats (const struct lrecord_header *h, int free_p) |
| 428 | 3628 { |
| 647 | 3629 int type_index = h->type; |
| 428 | 3630 |
| 3631 if (((struct lcrecord_header *) h)->free) | |
| 3632 { | |
| 442 | 3633 gc_checking_assert (!free_p); |
| 428 | 3634 lcrecord_stats[type_index].instances_on_free_list++; |
| 3635 } | |
| 3636 else | |
| 3637 { | |
| 1204 | 3638 Bytecount sz = detagged_lisp_object_size (h); |
| 3639 | |
| 428 | 3640 if (free_p) |
| 3641 { | |
| 3642 lcrecord_stats[type_index].instances_freed++; | |
| 3643 lcrecord_stats[type_index].bytes_freed += sz; | |
| 3644 } | |
| 3645 else | |
| 3646 { | |
| 3647 lcrecord_stats[type_index].instances_in_use++; | |
| 3648 lcrecord_stats[type_index].bytes_in_use += sz; | |
| 3649 } | |
| 3650 } | |
| 3651 } | |
| 3652 | |
| 3653 | |
| 3654 /* Free all unmarked records */ | |
| 3655 static void | |
| 3656 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) | |
| 3657 { | |
| 3658 struct lcrecord_header *header; | |
| 3659 int num_used = 0; | |
| 3660 /* int total_size = 0; */ | |
| 3661 | |
| 3662 xzero (lcrecord_stats); /* Reset all statistics to 0. */ | |
| 3663 | |
| 3664 /* First go through and call all the finalize methods. | |
| 3665 Then go through and free the objects. There used to | |
| 3666 be only one loop here, with the call to the finalizer | |
| 3667 occurring directly before the xfree() below. That | |
| 3668 is marginally faster but much less safe -- if the | |
| 3669 finalize method for an object needs to reference any | |
| 3670 other objects contained within it (and many do), | |
| 3671 we could easily be screwed by having already freed that | |
| 3672 other object. */ | |
| 3673 | |
| 3674 for (header = *prev; header; header = header->next) | |
| 3675 { | |
| 3676 struct lrecord_header *h = &(header->lheader); | |
| 442 | 3677 |
| 3678 GC_CHECK_LHEADER_INVARIANTS (h); | |
| 3679 | |
| 3680 if (! MARKED_RECORD_HEADER_P (h) && ! header->free) | |
| 428 | 3681 { |
| 3682 if (LHEADER_IMPLEMENTATION (h)->finalizer) | |
| 3683 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); | |
| 3684 } | |
| 3685 } | |
| 3686 | |
| 3687 for (header = *prev; header; ) | |
| 3688 { | |
| 3689 struct lrecord_header *h = &(header->lheader); | |
| 442 | 3690 if (MARKED_RECORD_HEADER_P (h)) |
| 428 | 3691 { |
| 442 | 3692 if (! C_READONLY_RECORD_HEADER_P (h)) |
| 428 | 3693 UNMARK_RECORD_HEADER (h); |
| 3694 num_used++; | |
| 3695 /* total_size += n->implementation->size_in_bytes (h);*/ | |
| 440 | 3696 /* #### May modify header->next on a C_READONLY lcrecord */ |
| 428 | 3697 prev = &(header->next); |
| 3698 header = *prev; | |
| 3699 tick_lcrecord_stats (h, 0); | |
| 3700 } | |
| 3701 else | |
| 3702 { | |
| 3703 struct lcrecord_header *next = header->next; | |
| 3704 *prev = next; | |
| 3705 tick_lcrecord_stats (h, 1); | |
| 3706 /* used to call finalizer right here. */ | |
| 1726 | 3707 xfree (header, struct lcrecord_header *); |
| 428 | 3708 header = next; |
| 3709 } | |
| 3710 } | |
| 3711 *used = num_used; | |
| 3712 /* *total = total_size; */ | |
| 3713 } | |
| 3714 | |
| 3715 /* And the Lord said: Thou shalt use the `c-backslash-region' command | |
| 3716 to make macros prettier. */ | |
| 3717 | |
| 3718 #ifdef ERROR_CHECK_GC | |
| 3719 | |
| 771 | 3720 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 428 | 3721 do { \ |
| 3722 struct typename##_block *SFTB_current; \ | |
| 3723 int SFTB_limit; \ | |
| 3724 int num_free = 0, num_used = 0; \ | |
| 3725 \ | |
| 444 | 3726 for (SFTB_current = current_##typename##_block, \ |
| 428 | 3727 SFTB_limit = current_##typename##_block_index; \ |
| 3728 SFTB_current; \ | |
| 3729 ) \ | |
| 3730 { \ | |
| 3731 int SFTB_iii; \ | |
| 3732 \ | |
| 3733 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 3734 { \ | |
| 3735 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 3736 \ | |
| 454 | 3737 if (LRECORD_FREE_P (SFTB_victim)) \ |
| 428 | 3738 { \ |
| 3739 num_free++; \ | |
| 3740 } \ | |
| 3741 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3742 { \ | |
| 3743 num_used++; \ | |
| 3744 } \ | |
| 442 | 3745 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
| 428 | 3746 { \ |
| 3747 num_free++; \ | |
| 3748 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 3749 } \ | |
| 3750 else \ | |
| 3751 { \ | |
| 3752 num_used++; \ | |
| 3753 UNMARK_##typename (SFTB_victim); \ | |
| 3754 } \ | |
| 3755 } \ | |
| 3756 SFTB_current = SFTB_current->prev; \ | |
| 3757 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 3758 } \ | |
| 3759 \ | |
| 3760 gc_count_num_##typename##_in_use = num_used; \ | |
| 3761 gc_count_num_##typename##_freelist = num_free; \ | |
| 3762 } while (0) | |
| 3763 | |
| 3764 #else /* !ERROR_CHECK_GC */ | |
| 3765 | |
| 771 | 3766 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 3767 do { \ | |
| 3768 struct typename##_block *SFTB_current; \ | |
| 3769 struct typename##_block **SFTB_prev; \ | |
| 3770 int SFTB_limit; \ | |
| 3771 int num_free = 0, num_used = 0; \ | |
| 3772 \ | |
| 3773 typename##_free_list = 0; \ | |
| 3774 \ | |
| 3775 for (SFTB_prev = ¤t_##typename##_block, \ | |
| 3776 SFTB_current = current_##typename##_block, \ | |
| 3777 SFTB_limit = current_##typename##_block_index; \ | |
| 3778 SFTB_current; \ | |
| 3779 ) \ | |
| 3780 { \ | |
| 3781 int SFTB_iii; \ | |
| 3782 int SFTB_empty = 1; \ | |
| 3783 Lisp_Free *SFTB_old_free_list = typename##_free_list; \ | |
| 3784 \ | |
| 3785 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 3786 { \ | |
| 3787 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 3788 \ | |
| 3789 if (LRECORD_FREE_P (SFTB_victim)) \ | |
| 3790 { \ | |
| 3791 num_free++; \ | |
| 3792 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ | |
| 3793 } \ | |
| 3794 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3795 { \ | |
| 3796 SFTB_empty = 0; \ | |
| 3797 num_used++; \ | |
| 3798 } \ | |
| 3799 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 3800 { \ | |
| 3801 num_free++; \ | |
| 3802 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 3803 } \ | |
| 3804 else \ | |
| 3805 { \ | |
| 3806 SFTB_empty = 0; \ | |
| 3807 num_used++; \ | |
| 3808 UNMARK_##typename (SFTB_victim); \ | |
| 3809 } \ | |
| 3810 } \ | |
| 3811 if (!SFTB_empty) \ | |
| 3812 { \ | |
| 3813 SFTB_prev = &(SFTB_current->prev); \ | |
| 3814 SFTB_current = SFTB_current->prev; \ | |
| 3815 } \ | |
| 3816 else if (SFTB_current == current_##typename##_block \ | |
| 3817 && !SFTB_current->prev) \ | |
| 3818 { \ | |
| 3819 /* No real point in freeing sole allocation block */ \ | |
| 3820 break; \ | |
| 3821 } \ | |
| 3822 else \ | |
| 3823 { \ | |
| 3824 struct typename##_block *SFTB_victim_block = SFTB_current; \ | |
| 3825 if (SFTB_victim_block == current_##typename##_block) \ | |
| 3826 current_##typename##_block_index \ | |
| 3827 = countof (current_##typename##_block->block); \ | |
| 3828 SFTB_current = SFTB_current->prev; \ | |
| 3829 { \ | |
| 3830 *SFTB_prev = SFTB_current; \ | |
| 1726 | 3831 xfree (SFTB_victim_block, struct typename##_block *); \ |
| 771 | 3832 /* Restore free list to what it was before victim was swept */ \ |
| 3833 typename##_free_list = SFTB_old_free_list; \ | |
| 3834 num_free -= SFTB_limit; \ | |
| 3835 } \ | |
| 3836 } \ | |
| 3837 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 3838 } \ | |
| 3839 \ | |
| 3840 gc_count_num_##typename##_in_use = num_used; \ | |
| 3841 gc_count_num_##typename##_freelist = num_free; \ | |
| 428 | 3842 } while (0) |
| 3843 | |
| 3844 #endif /* !ERROR_CHECK_GC */ | |
| 3845 | |
| 771 | 3846 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ |
| 3847 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader) | |
| 3848 | |
| 428 | 3849 |
| 3850 | |
| 3851 | |
| 3852 static void | |
| 3853 sweep_conses (void) | |
| 3854 { | |
| 3855 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3856 #define ADDITIONAL_FREE_cons(ptr) | |
| 3857 | |
| 440 | 3858 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons); |
| 428 | 3859 } |
| 3860 | |
| 3861 /* Explicitly free a cons cell. */ | |
| 3862 void | |
| 853 | 3863 free_cons (Lisp_Object cons) |
| 428 | 3864 { |
| 853 | 3865 Lisp_Cons *ptr = XCONS (cons); |
| 3866 | |
| 428 | 3867 #ifdef ERROR_CHECK_GC |
| 3868 /* If the CAR is not an int, then it will be a pointer, which will | |
| 3869 always be four-byte aligned. If this cons cell has already been | |
| 3870 placed on the free list, however, its car will probably contain | |
| 3871 a chain pointer to the next cons on the list, which has cleverly | |
| 3872 had all its 0's and 1's inverted. This allows for a quick | |
| 1204 | 3873 check to make sure we're not freeing something already freed. |
| 3874 | |
| 3875 NOTE: This check may not be necessary. Freeing an object sets its | |
| 3876 type to lrecord_type_free, which will trip up the XCONS() above -- as | |
| 3877 well as a check in FREE_FIXED_TYPE(). */ | |
| 853 | 3878 if (POINTER_TYPE_P (XTYPE (cons_car (ptr)))) |
| 3879 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr))); | |
| 428 | 3880 #endif /* ERROR_CHECK_GC */ |
| 3881 | |
| 440 | 3882 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr); |
| 428 | 3883 } |
| 3884 | |
| 3885 /* explicitly free a list. You **must make sure** that you have | |
| 3886 created all the cons cells that make up this list and that there | |
| 3887 are no pointers to any of these cons cells anywhere else. If there | |
| 3888 are, you will lose. */ | |
| 3889 | |
| 3890 void | |
| 3891 free_list (Lisp_Object list) | |
| 3892 { | |
| 3893 Lisp_Object rest, next; | |
| 3894 | |
| 3895 for (rest = list; !NILP (rest); rest = next) | |
| 3896 { | |
| 3897 next = XCDR (rest); | |
| 853 | 3898 free_cons (rest); |
| 428 | 3899 } |
| 3900 } | |
| 3901 | |
| 3902 /* explicitly free an alist. You **must make sure** that you have | |
| 3903 created all the cons cells that make up this alist and that there | |
| 3904 are no pointers to any of these cons cells anywhere else. If there | |
| 3905 are, you will lose. */ | |
| 3906 | |
| 3907 void | |
| 3908 free_alist (Lisp_Object alist) | |
| 3909 { | |
| 3910 Lisp_Object rest, next; | |
| 3911 | |
| 3912 for (rest = alist; !NILP (rest); rest = next) | |
| 3913 { | |
| 3914 next = XCDR (rest); | |
| 853 | 3915 free_cons (XCAR (rest)); |
| 3916 free_cons (rest); | |
| 428 | 3917 } |
| 3918 } | |
| 3919 | |
| 3920 static void | |
| 3921 sweep_compiled_functions (void) | |
| 3922 { | |
| 3923 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 945 | 3924 #define ADDITIONAL_FREE_compiled_function(ptr) \ |
| 1726 | 3925 if (ptr->args_in_array) xfree (ptr->args, Lisp_Object *) |
| 428 | 3926 |
| 3927 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); | |
| 3928 } | |
| 3929 | |
| 3930 static void | |
| 3931 sweep_floats (void) | |
| 3932 { | |
| 3933 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3934 #define ADDITIONAL_FREE_float(ptr) | |
| 3935 | |
| 440 | 3936 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float); |
| 428 | 3937 } |
| 3938 | |
| 1983 | 3939 #ifdef HAVE_BIGNUM |
| 3940 static void | |
| 3941 sweep_bignums (void) | |
| 3942 { | |
| 3943 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3944 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data) | |
| 3945 | |
| 3946 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum); | |
| 3947 } | |
| 3948 #endif /* HAVE_BIGNUM */ | |
| 3949 | |
| 3950 #ifdef HAVE_RATIO | |
| 3951 static void | |
| 3952 sweep_ratios (void) | |
| 3953 { | |
| 3954 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3955 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data) | |
| 3956 | |
| 3957 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio); | |
| 3958 } | |
| 3959 #endif /* HAVE_RATIO */ | |
| 3960 | |
| 3961 #ifdef HAVE_BIGFLOAT | |
| 3962 static void | |
| 3963 sweep_bigfloats (void) | |
| 3964 { | |
| 3965 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3966 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf) | |
| 3967 | |
| 3968 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat); | |
| 3969 } | |
| 3970 #endif | |
| 3971 | |
| 428 | 3972 static void |
| 3973 sweep_symbols (void) | |
| 3974 { | |
| 3975 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3976 #define ADDITIONAL_FREE_symbol(ptr) | |
| 3977 | |
| 440 | 3978 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol); |
| 428 | 3979 } |
| 3980 | |
| 3981 static void | |
| 3982 sweep_extents (void) | |
| 3983 { | |
| 3984 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3985 #define ADDITIONAL_FREE_extent(ptr) | |
| 3986 | |
| 3987 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent); | |
| 3988 } | |
| 3989 | |
| 3990 static void | |
| 3991 sweep_events (void) | |
| 3992 { | |
| 3993 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 3994 #define ADDITIONAL_FREE_event(ptr) | |
| 3995 | |
| 440 | 3996 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event); |
| 428 | 3997 } |
| 3998 | |
| 1204 | 3999 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4000 |
| 4001 static void | |
| 4002 sweep_key_data (void) | |
| 4003 { | |
| 4004 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4005 #define ADDITIONAL_FREE_key_data(ptr) | |
| 4006 | |
| 4007 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data); | |
| 4008 } | |
| 4009 | |
| 1204 | 4010 void |
| 4011 free_key_data (Lisp_Object ptr) | |
| 4012 { | |
| 4013 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (key_data, Lisp_Key_Data, XKEY_DATA (ptr)); | |
| 4014 } | |
| 4015 | |
| 934 | 4016 static void |
| 4017 sweep_button_data (void) | |
| 4018 { | |
| 4019 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4020 #define ADDITIONAL_FREE_button_data(ptr) | |
| 4021 | |
| 4022 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data); | |
| 4023 } | |
| 4024 | |
| 1204 | 4025 void |
| 4026 free_button_data (Lisp_Object ptr) | |
| 4027 { | |
| 4028 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (button_data, Lisp_Button_Data, XBUTTON_DATA (ptr)); | |
| 4029 } | |
| 4030 | |
| 934 | 4031 static void |
| 4032 sweep_motion_data (void) | |
| 4033 { | |
| 4034 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4035 #define ADDITIONAL_FREE_motion_data(ptr) | |
| 4036 | |
| 4037 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data); | |
| 4038 } | |
| 4039 | |
| 1204 | 4040 void |
| 4041 free_motion_data (Lisp_Object ptr) | |
| 4042 { | |
| 4043 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (motion_data, Lisp_Motion_Data, XMOTION_DATA (ptr)); | |
| 4044 } | |
| 4045 | |
| 934 | 4046 static void |
| 4047 sweep_process_data (void) | |
| 4048 { | |
| 4049 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4050 #define ADDITIONAL_FREE_process_data(ptr) | |
| 4051 | |
| 4052 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data); | |
| 4053 } | |
| 4054 | |
| 1204 | 4055 void |
| 4056 free_process_data (Lisp_Object ptr) | |
| 4057 { | |
| 4058 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (process_data, Lisp_Process_Data, XPROCESS_DATA (ptr)); | |
| 4059 } | |
| 4060 | |
| 934 | 4061 static void |
| 4062 sweep_timeout_data (void) | |
| 4063 { | |
| 4064 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4065 #define ADDITIONAL_FREE_timeout_data(ptr) | |
| 4066 | |
| 4067 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data); | |
| 4068 } | |
| 4069 | |
| 1204 | 4070 void |
| 4071 free_timeout_data (Lisp_Object ptr) | |
| 4072 { | |
| 4073 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (timeout_data, Lisp_Timeout_Data, XTIMEOUT_DATA (ptr)); | |
| 4074 } | |
| 4075 | |
| 934 | 4076 static void |
| 4077 sweep_magic_data (void) | |
| 4078 { | |
| 4079 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4080 #define ADDITIONAL_FREE_magic_data(ptr) | |
| 4081 | |
| 4082 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data); | |
| 4083 } | |
| 4084 | |
| 1204 | 4085 void |
| 4086 free_magic_data (Lisp_Object ptr) | |
| 4087 { | |
| 4088 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_data, Lisp_Magic_Data, XMAGIC_DATA (ptr)); | |
| 4089 } | |
| 4090 | |
| 934 | 4091 static void |
| 4092 sweep_magic_eval_data (void) | |
| 4093 { | |
| 4094 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4095 #define ADDITIONAL_FREE_magic_eval_data(ptr) | |
| 4096 | |
| 4097 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data); | |
| 4098 } | |
| 4099 | |
| 1204 | 4100 void |
| 4101 free_magic_eval_data (Lisp_Object ptr) | |
| 4102 { | |
| 4103 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_eval_data, Lisp_Magic_Eval_Data, XMAGIC_EVAL_DATA (ptr)); | |
| 4104 } | |
| 4105 | |
| 934 | 4106 static void |
| 4107 sweep_eval_data (void) | |
| 4108 { | |
| 4109 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4110 #define ADDITIONAL_FREE_eval_data(ptr) | |
| 4111 | |
| 4112 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data); | |
| 4113 } | |
| 4114 | |
| 1204 | 4115 void |
| 4116 free_eval_data (Lisp_Object ptr) | |
| 4117 { | |
| 4118 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (eval_data, Lisp_Eval_Data, XEVAL_DATA (ptr)); | |
| 4119 } | |
| 4120 | |
| 934 | 4121 static void |
| 4122 sweep_misc_user_data (void) | |
| 4123 { | |
| 4124 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4125 #define ADDITIONAL_FREE_misc_user_data(ptr) | |
| 4126 | |
| 4127 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data); | |
| 4128 } | |
| 4129 | |
| 1204 | 4130 void |
| 4131 free_misc_user_data (Lisp_Object ptr) | |
| 4132 { | |
| 4133 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (misc_user_data, Lisp_Misc_User_Data, XMISC_USER_DATA (ptr)); | |
| 4134 } | |
| 4135 | |
| 4136 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 934 | 4137 |
| 428 | 4138 static void |
| 4139 sweep_markers (void) | |
| 4140 { | |
| 4141 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4142 #define ADDITIONAL_FREE_marker(ptr) \ | |
| 4143 do { Lisp_Object tem; \ | |
| 793 | 4144 tem = wrap_marker (ptr); \ |
| 428 | 4145 unchain_marker (tem); \ |
| 4146 } while (0) | |
| 4147 | |
| 440 | 4148 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker); |
| 428 | 4149 } |
| 4150 | |
| 4151 /* Explicitly free a marker. */ | |
| 4152 void | |
| 1204 | 4153 free_marker (Lisp_Object ptr) |
| 428 | 4154 { |
| 1204 | 4155 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, XMARKER (ptr)); |
| 428 | 4156 } |
| 4157 | |
| 4158 | |
| 4159 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) | |
| 4160 | |
| 4161 static void | |
| 4162 verify_string_chars_integrity (void) | |
| 4163 { | |
| 4164 struct string_chars_block *sb; | |
| 4165 | |
| 4166 /* Scan each existing string block sequentially, string by string. */ | |
| 4167 for (sb = first_string_chars_block; sb; sb = sb->next) | |
| 4168 { | |
| 4169 int pos = 0; | |
| 4170 /* POS is the index of the next string in the block. */ | |
| 4171 while (pos < sb->pos) | |
| 4172 { | |
| 4173 struct string_chars *s_chars = | |
| 4174 (struct string_chars *) &(sb->string_chars[pos]); | |
| 438 | 4175 Lisp_String *string; |
| 428 | 4176 int size; |
| 4177 int fullsize; | |
| 4178 | |
| 454 | 4179 /* If the string_chars struct is marked as free (i.e. the |
| 4180 STRING pointer is NULL) then this is an unused chunk of | |
| 4181 string storage. (See below.) */ | |
| 4182 | |
| 4183 if (STRING_CHARS_FREE_P (s_chars)) | |
| 428 | 4184 { |
| 4185 fullsize = ((struct unused_string_chars *) s_chars)->fullsize; | |
| 4186 pos += fullsize; | |
| 4187 continue; | |
| 4188 } | |
| 4189 | |
| 4190 string = s_chars->string; | |
| 4191 /* Must be 32-bit aligned. */ | |
| 4192 assert ((((int) string) & 3) == 0); | |
| 4193 | |
| 793 | 4194 size = string->size_; |
| 428 | 4195 fullsize = STRING_FULLSIZE (size); |
| 4196 | |
| 4197 assert (!BIG_STRING_FULLSIZE_P (fullsize)); | |
| 793 | 4198 assert (string->data_ == s_chars->chars); |
| 428 | 4199 pos += fullsize; |
| 4200 } | |
| 4201 assert (pos == sb->pos); | |
| 4202 } | |
| 4203 } | |
| 4204 | |
| 1204 | 4205 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */ |
| 428 | 4206 |
| 4207 /* Compactify string chars, relocating the reference to each -- | |
| 4208 free any empty string_chars_block we see. */ | |
| 4209 static void | |
| 4210 compact_string_chars (void) | |
| 4211 { | |
| 4212 struct string_chars_block *to_sb = first_string_chars_block; | |
| 4213 int to_pos = 0; | |
| 4214 struct string_chars_block *from_sb; | |
| 4215 | |
| 4216 /* Scan each existing string block sequentially, string by string. */ | |
| 4217 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next) | |
| 4218 { | |
| 4219 int from_pos = 0; | |
| 4220 /* FROM_POS is the index of the next string in the block. */ | |
| 4221 while (from_pos < from_sb->pos) | |
| 4222 { | |
| 4223 struct string_chars *from_s_chars = | |
| 4224 (struct string_chars *) &(from_sb->string_chars[from_pos]); | |
| 4225 struct string_chars *to_s_chars; | |
| 438 | 4226 Lisp_String *string; |
| 428 | 4227 int size; |
| 4228 int fullsize; | |
| 4229 | |
| 454 | 4230 /* If the string_chars struct is marked as free (i.e. the |
| 4231 STRING pointer is NULL) then this is an unused chunk of | |
| 4232 string storage. This happens under Mule when a string's | |
| 4233 size changes in such a way that its fullsize changes. | |
| 4234 (Strings can change size because a different-length | |
| 4235 character can be substituted for another character.) | |
| 4236 In this case, after the bogus string pointer is the | |
| 4237 "fullsize" of this entry, i.e. how many bytes to skip. */ | |
| 4238 | |
| 4239 if (STRING_CHARS_FREE_P (from_s_chars)) | |
| 428 | 4240 { |
| 4241 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize; | |
| 4242 from_pos += fullsize; | |
| 4243 continue; | |
| 4244 } | |
| 4245 | |
| 4246 string = from_s_chars->string; | |
| 1204 | 4247 gc_checking_assert (!(LRECORD_FREE_P (string))); |
| 428 | 4248 |
| 793 | 4249 size = string->size_; |
| 428 | 4250 fullsize = STRING_FULLSIZE (size); |
| 4251 | |
| 442 | 4252 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize)); |
| 428 | 4253 |
| 4254 /* Just skip it if it isn't marked. */ | |
| 771 | 4255 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader))) |
| 428 | 4256 { |
| 4257 from_pos += fullsize; | |
| 4258 continue; | |
| 4259 } | |
| 4260 | |
| 4261 /* If it won't fit in what's left of TO_SB, close TO_SB out | |
| 4262 and go on to the next string_chars_block. We know that TO_SB | |
| 4263 cannot advance past FROM_SB here since FROM_SB is large enough | |
| 4264 to currently contain this string. */ | |
| 4265 if ((to_pos + fullsize) > countof (to_sb->string_chars)) | |
| 4266 { | |
| 4267 to_sb->pos = to_pos; | |
| 4268 to_sb = to_sb->next; | |
| 4269 to_pos = 0; | |
| 4270 } | |
| 4271 | |
| 4272 /* Compute new address of this string | |
| 4273 and update TO_POS for the space being used. */ | |
| 4274 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]); | |
| 4275 | |
| 4276 /* Copy the string_chars to the new place. */ | |
| 4277 if (from_s_chars != to_s_chars) | |
| 4278 memmove (to_s_chars, from_s_chars, fullsize); | |
| 4279 | |
| 4280 /* Relocate FROM_S_CHARS's reference */ | |
| 826 | 4281 set_lispstringp_data (string, &(to_s_chars->chars[0])); |
| 428 | 4282 |
| 4283 from_pos += fullsize; | |
| 4284 to_pos += fullsize; | |
| 4285 } | |
| 4286 } | |
| 4287 | |
| 4288 /* Set current to the last string chars block still used and | |
| 4289 free any that follow. */ | |
| 4290 { | |
| 4291 struct string_chars_block *victim; | |
| 4292 | |
| 4293 for (victim = to_sb->next; victim; ) | |
| 4294 { | |
| 4295 struct string_chars_block *next = victim->next; | |
| 1726 | 4296 xfree (victim, struct string_chars_block *); |
| 428 | 4297 victim = next; |
| 4298 } | |
| 4299 | |
| 4300 current_string_chars_block = to_sb; | |
| 4301 current_string_chars_block->pos = to_pos; | |
| 4302 current_string_chars_block->next = 0; | |
| 4303 } | |
| 4304 } | |
| 4305 | |
| 4306 #if 1 /* Hack to debug missing purecopy's */ | |
| 4307 static int debug_string_purity; | |
| 4308 | |
| 4309 static void | |
| 793 | 4310 debug_string_purity_print (Lisp_Object p) |
| 428 | 4311 { |
| 4312 Charcount i; | |
| 826 | 4313 Charcount s = string_char_length (p); |
| 442 | 4314 stderr_out ("\""); |
| 428 | 4315 for (i = 0; i < s; i++) |
| 4316 { | |
| 867 | 4317 Ichar ch = string_ichar (p, i); |
| 428 | 4318 if (ch < 32 || ch >= 126) |
| 4319 stderr_out ("\\%03o", ch); | |
| 4320 else if (ch == '\\' || ch == '\"') | |
| 4321 stderr_out ("\\%c", ch); | |
| 4322 else | |
| 4323 stderr_out ("%c", ch); | |
| 4324 } | |
| 4325 stderr_out ("\"\n"); | |
| 4326 } | |
| 4327 #endif /* 1 */ | |
| 4328 | |
| 4329 | |
| 4330 static void | |
| 4331 sweep_strings (void) | |
| 4332 { | |
| 647 | 4333 int num_small_used = 0; |
| 4334 Bytecount num_small_bytes = 0, num_bytes = 0; | |
| 428 | 4335 int debug = debug_string_purity; |
| 4336 | |
| 793 | 4337 #define UNMARK_string(ptr) do { \ |
| 4338 Lisp_String *p = (ptr); \ | |
| 4339 Bytecount size = p->size_; \ | |
| 4340 UNMARK_RECORD_HEADER (&(p->u.lheader)); \ | |
| 4341 num_bytes += size; \ | |
| 4342 if (!BIG_STRING_SIZE_P (size)) \ | |
| 4343 { \ | |
| 4344 num_small_bytes += size; \ | |
| 4345 num_small_used++; \ | |
| 4346 } \ | |
| 4347 if (debug) \ | |
| 4348 debug_string_purity_print (wrap_string (p)); \ | |
| 438 | 4349 } while (0) |
| 4350 #define ADDITIONAL_FREE_string(ptr) do { \ | |
| 793 | 4351 Bytecount size = ptr->size_; \ |
| 438 | 4352 if (BIG_STRING_SIZE_P (size)) \ |
| 1726 | 4353 xfree (ptr->data_, Ibyte *); \ |
| 438 | 4354 } while (0) |
| 4355 | |
| 771 | 4356 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); |
| 428 | 4357 |
| 4358 gc_count_num_short_string_in_use = num_small_used; | |
| 4359 gc_count_string_total_size = num_bytes; | |
| 4360 gc_count_short_string_total_size = num_small_bytes; | |
| 4361 } | |
| 4362 | |
| 4363 | |
| 4364 /* I hate duplicating all this crap! */ | |
| 4365 int | |
| 4366 marked_p (Lisp_Object obj) | |
| 4367 { | |
| 4368 /* Checks we used to perform. */ | |
| 4369 /* if (EQ (obj, Qnull_pointer)) return 1; */ | |
| 4370 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ | |
| 4371 /* if (PURIFIED (XPNTR (obj))) return 1; */ | |
| 4372 | |
| 4373 if (XTYPE (obj) == Lisp_Type_Record) | |
| 4374 { | |
| 4375 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 442 | 4376 |
| 4377 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 4378 | |
| 4379 return MARKED_RECORD_HEADER_P (lheader); | |
| 428 | 4380 } |
| 4381 return 1; | |
| 4382 } | |
| 4383 | |
| 4384 static void | |
| 4385 gc_sweep (void) | |
| 4386 { | |
| 4387 /* Free all unmarked records. Do this at the very beginning, | |
| 4388 before anything else, so that the finalize methods can safely | |
| 4389 examine items in the objects. sweep_lcrecords_1() makes | |
| 4390 sure to call all the finalize methods *before* freeing anything, | |
| 4391 to complete the safety. */ | |
| 4392 { | |
| 4393 int ignored; | |
| 4394 sweep_lcrecords_1 (&all_lcrecords, &ignored); | |
| 4395 } | |
| 4396 | |
| 4397 compact_string_chars (); | |
| 4398 | |
| 4399 /* Finalize methods below (called through the ADDITIONAL_FREE_foo | |
| 4400 macros) must be *extremely* careful to make sure they're not | |
| 4401 referencing freed objects. The only two existing finalize | |
| 4402 methods (for strings and markers) pass muster -- the string | |
| 4403 finalizer doesn't look at anything but its own specially- | |
| 4404 created block, and the marker finalizer only looks at live | |
| 4405 buffers (which will never be freed) and at the markers before | |
| 4406 and after it in the chain (which, by induction, will never be | |
| 4407 freed because if so, they would have already removed themselves | |
| 4408 from the chain). */ | |
| 4409 | |
| 4410 /* Put all unmarked strings on free list, free'ing the string chars | |
| 4411 of large unmarked strings */ | |
| 4412 sweep_strings (); | |
| 4413 | |
| 4414 /* Put all unmarked conses on free list */ | |
| 4415 sweep_conses (); | |
| 4416 | |
| 4417 /* Free all unmarked compiled-function objects */ | |
| 4418 sweep_compiled_functions (); | |
| 4419 | |
| 4420 /* Put all unmarked floats on free list */ | |
| 4421 sweep_floats (); | |
| 4422 | |
| 1983 | 4423 #ifdef HAVE_BIGNUM |
| 4424 /* Put all unmarked bignums on free list */ | |
| 4425 sweep_bignums (); | |
| 4426 #endif | |
| 4427 | |
| 4428 #ifdef HAVE_RATIO | |
| 4429 /* Put all unmarked ratios on free list */ | |
| 4430 sweep_ratios (); | |
| 4431 #endif | |
| 4432 | |
| 4433 #ifdef HAVE_BIGFLOAT | |
| 4434 /* Put all unmarked bigfloats on free list */ | |
| 4435 sweep_bigfloats (); | |
| 4436 #endif | |
| 4437 | |
| 428 | 4438 /* Put all unmarked symbols on free list */ |
| 4439 sweep_symbols (); | |
| 4440 | |
| 4441 /* Put all unmarked extents on free list */ | |
| 4442 sweep_extents (); | |
| 4443 | |
| 4444 /* Put all unmarked markers on free list. | |
| 4445 Dechain each one first from the buffer into which it points. */ | |
| 4446 sweep_markers (); | |
| 4447 | |
| 4448 sweep_events (); | |
| 4449 | |
| 1204 | 4450 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4451 sweep_key_data (); |
| 4452 sweep_button_data (); | |
| 4453 sweep_motion_data (); | |
| 4454 sweep_process_data (); | |
| 4455 sweep_timeout_data (); | |
| 4456 sweep_magic_data (); | |
| 4457 sweep_magic_eval_data (); | |
| 4458 sweep_eval_data (); | |
| 4459 sweep_misc_user_data (); | |
| 1204 | 4460 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 934 | 4461 |
| 428 | 4462 #ifdef PDUMP |
| 442 | 4463 pdump_objects_unmark (); |
| 428 | 4464 #endif |
| 4465 } | |
| 4466 | |
| 4467 /* Clearing for disksave. */ | |
| 4468 | |
| 4469 void | |
| 4470 disksave_object_finalization (void) | |
| 4471 { | |
| 4472 /* It's important that certain information from the environment not get | |
| 4473 dumped with the executable (pathnames, environment variables, etc.). | |
| 4474 To make it easier to tell when this has happened with strings(1) we | |
| 4475 clear some known-to-be-garbage blocks of memory, so that leftover | |
| 4476 results of old evaluation don't look like potential problems. | |
| 4477 But first we set some notable variables to nil and do one more GC, | |
| 4478 to turn those strings into garbage. | |
| 440 | 4479 */ |
| 428 | 4480 |
| 4481 /* Yeah, this list is pretty ad-hoc... */ | |
| 4482 Vprocess_environment = Qnil; | |
| 771 | 4483 env_initted = 0; |
| 428 | 4484 Vexec_directory = Qnil; |
| 4485 Vdata_directory = Qnil; | |
| 4486 Vsite_directory = Qnil; | |
| 4487 Vdoc_directory = Qnil; | |
| 4488 Vexec_path = Qnil; | |
| 4489 Vload_path = Qnil; | |
| 4490 /* Vdump_load_path = Qnil; */ | |
| 4491 /* Release hash tables for locate_file */ | |
| 4492 Flocate_file_clear_hashing (Qt); | |
| 771 | 4493 uncache_home_directory (); |
| 776 | 4494 zero_out_command_line_status_vars (); |
| 872 | 4495 clear_default_devices (); |
| 428 | 4496 |
| 4497 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \ | |
| 4498 defined(LOADHIST_BUILTIN)) | |
| 4499 Vload_history = Qnil; | |
| 4500 #endif | |
| 4501 Vshell_file_name = Qnil; | |
| 4502 | |
| 4503 garbage_collect_1 (); | |
| 4504 | |
| 4505 /* Run the disksave finalization methods of all live objects. */ | |
| 4506 disksave_object_finalization_1 (); | |
| 4507 | |
| 4508 /* Zero out the uninitialized (really, unused) part of the containers | |
| 4509 for the live strings. */ | |
| 4510 { | |
| 4511 struct string_chars_block *scb; | |
| 4512 for (scb = first_string_chars_block; scb; scb = scb->next) | |
| 4513 { | |
| 4514 int count = sizeof (scb->string_chars) - scb->pos; | |
| 4515 | |
| 4516 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE); | |
| 440 | 4517 if (count != 0) |
| 4518 { | |
| 4519 /* from the block's fill ptr to the end */ | |
| 4520 memset ((scb->string_chars + scb->pos), 0, count); | |
| 4521 } | |
| 428 | 4522 } |
| 4523 } | |
| 4524 | |
| 4525 /* There, that ought to be enough... */ | |
| 4526 | |
| 4527 } | |
| 4528 | |
| 4529 | |
| 771 | 4530 int |
| 4531 begin_gc_forbidden (void) | |
| 4532 { | |
| 853 | 4533 return internal_bind_int (&gc_currently_forbidden, 1); |
| 771 | 4534 } |
| 4535 | |
| 4536 void | |
| 4537 end_gc_forbidden (int count) | |
| 4538 { | |
| 4539 unbind_to (count); | |
| 4540 } | |
| 4541 | |
| 428 | 4542 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */ |
| 4543 static int gc_hooks_inhibited; | |
| 4544 | |
| 611 | 4545 struct post_gc_action |
| 4546 { | |
| 4547 void (*fun) (void *); | |
| 4548 void *arg; | |
| 4549 }; | |
| 4550 | |
| 4551 typedef struct post_gc_action post_gc_action; | |
| 4552 | |
| 4553 typedef struct | |
| 4554 { | |
| 4555 Dynarr_declare (post_gc_action); | |
| 4556 } post_gc_action_dynarr; | |
| 4557 | |
| 4558 static post_gc_action_dynarr *post_gc_actions; | |
| 4559 | |
| 4560 /* Register an action to be called at the end of GC. | |
| 4561 gc_in_progress is 0 when this is called. | |
| 4562 This is used when it is discovered that an action needs to be taken, | |
| 4563 but it's during GC, so it's not safe. (e.g. in a finalize method.) | |
| 4564 | |
| 4565 As a general rule, do not use Lisp objects here. | |
| 4566 And NEVER signal an error. | |
| 4567 */ | |
| 4568 | |
| 4569 void | |
| 4570 register_post_gc_action (void (*fun) (void *), void *arg) | |
| 4571 { | |
| 4572 post_gc_action action; | |
| 4573 | |
| 4574 if (!post_gc_actions) | |
| 4575 post_gc_actions = Dynarr_new (post_gc_action); | |
| 4576 | |
| 4577 action.fun = fun; | |
| 4578 action.arg = arg; | |
| 4579 | |
| 4580 Dynarr_add (post_gc_actions, action); | |
| 4581 } | |
| 4582 | |
| 4583 static void | |
| 4584 run_post_gc_actions (void) | |
| 4585 { | |
| 4586 int i; | |
| 4587 | |
| 4588 if (post_gc_actions) | |
| 4589 { | |
| 4590 for (i = 0; i < Dynarr_length (post_gc_actions); i++) | |
| 4591 { | |
| 4592 post_gc_action action = Dynarr_at (post_gc_actions, i); | |
| 4593 (action.fun) (action.arg); | |
| 4594 } | |
| 4595 | |
| 4596 Dynarr_reset (post_gc_actions); | |
| 4597 } | |
| 4598 } | |
| 4599 | |
| 428 | 4600 |
| 4601 void | |
| 4602 garbage_collect_1 (void) | |
| 4603 { | |
| 4604 #if MAX_SAVE_STACK > 0 | |
| 4605 char stack_top_variable; | |
| 4606 extern char *stack_bottom; | |
| 4607 #endif | |
| 4608 struct frame *f; | |
| 4609 int speccount; | |
| 4610 int cursor_changed; | |
| 4611 Lisp_Object pre_gc_cursor; | |
| 4612 struct gcpro gcpro1; | |
| 1292 | 4613 PROFILE_DECLARE (); |
| 428 | 4614 |
| 1123 | 4615 assert (!in_display || gc_currently_forbidden); |
| 4616 | |
| 428 | 4617 if (gc_in_progress |
| 4618 || gc_currently_forbidden | |
| 4619 || in_display | |
| 4620 || preparing_for_armageddon) | |
| 4621 return; | |
| 4622 | |
| 1292 | 4623 PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection); |
| 4624 | |
| 428 | 4625 /* We used to call selected_frame() here. |
| 4626 | |
| 4627 The following functions cannot be called inside GC | |
| 4628 so we move to after the above tests. */ | |
| 4629 { | |
| 4630 Lisp_Object frame; | |
| 4631 Lisp_Object device = Fselected_device (Qnil); | |
| 4632 if (NILP (device)) /* Could happen during startup, eg. if always_gc */ | |
| 4633 return; | |
| 872 | 4634 frame = Fselected_frame (device); |
| 428 | 4635 if (NILP (frame)) |
| 563 | 4636 invalid_state ("No frames exist on device", device); |
| 428 | 4637 f = XFRAME (frame); |
| 4638 } | |
| 4639 | |
| 4640 pre_gc_cursor = Qnil; | |
| 4641 cursor_changed = 0; | |
| 4642 | |
| 4643 GCPRO1 (pre_gc_cursor); | |
| 4644 | |
| 4645 /* Very important to prevent GC during any of the following | |
| 4646 stuff that might run Lisp code; otherwise, we'll likely | |
| 4647 have infinite GC recursion. */ | |
| 771 | 4648 speccount = begin_gc_forbidden (); |
| 428 | 4649 |
| 887 | 4650 need_to_signal_post_gc = 0; |
| 1318 | 4651 recompute_funcall_allocation_flag (); |
| 887 | 4652 |
| 428 | 4653 if (!gc_hooks_inhibited) |
| 853 | 4654 run_hook_trapping_problems |
| 1333 | 4655 (Qgarbage_collecting, Qpre_gc_hook, |
| 853 | 4656 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); |
| 428 | 4657 |
| 4658 /* Now show the GC cursor/message. */ | |
| 4659 if (!noninteractive) | |
| 4660 { | |
| 4661 if (FRAME_WIN_P (f)) | |
| 4662 { | |
| 771 | 4663 Lisp_Object frame = wrap_frame (f); |
| 428 | 4664 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph, |
| 4665 FRAME_SELECTED_WINDOW (f), | |
| 4666 ERROR_ME_NOT, 1); | |
| 4667 pre_gc_cursor = f->pointer; | |
| 4668 if (POINTER_IMAGE_INSTANCEP (cursor) | |
| 4669 /* don't change if we don't know how to change back. */ | |
| 4670 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor)) | |
| 4671 { | |
| 4672 cursor_changed = 1; | |
| 4673 Fset_frame_pointer (frame, cursor); | |
| 4674 } | |
| 4675 } | |
| 4676 | |
| 4677 /* Don't print messages to the stream device. */ | |
| 4678 if (!cursor_changed && !FRAME_STREAM_P (f)) | |
| 4679 { | |
| 1154 | 4680 if (garbage_collection_messages) |
| 4681 { | |
| 4682 Lisp_Object args[2], whole_msg; | |
| 4683 args[0] = (STRINGP (Vgc_message) ? Vgc_message : | |
| 4684 build_msg_string (gc_default_message)); | |
| 4685 args[1] = build_string ("..."); | |
| 4686 whole_msg = Fconcat (2, args); | |
| 4687 echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1, | |
| 4688 Qgarbage_collecting); | |
| 4689 } | |
| 428 | 4690 } |
| 4691 } | |
| 4692 | |
| 4693 /***** Now we actually start the garbage collection. */ | |
| 4694 | |
| 4695 gc_in_progress = 1; | |
| 2367 | 4696 inhibit_non_essential_conversion_operations = 1; |
| 428 | 4697 |
| 4698 gc_generation_number[0]++; | |
| 4699 | |
| 4700 #if MAX_SAVE_STACK > 0 | |
| 4701 | |
| 4702 /* Save a copy of the contents of the stack, for debugging. */ | |
| 4703 if (!purify_flag) | |
| 4704 { | |
| 4705 /* Static buffer in which we save a copy of the C stack at each GC. */ | |
| 4706 static char *stack_copy; | |
| 665 | 4707 static Bytecount stack_copy_size; |
| 428 | 4708 |
| 4709 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom; | |
| 665 | 4710 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff); |
| 428 | 4711 if (stack_size < MAX_SAVE_STACK) |
| 4712 { | |
| 4713 if (stack_copy_size < stack_size) | |
| 4714 { | |
| 4715 stack_copy = (char *) xrealloc (stack_copy, stack_size); | |
| 4716 stack_copy_size = stack_size; | |
| 4717 } | |
| 4718 | |
| 4719 memcpy (stack_copy, | |
| 4720 stack_diff > 0 ? stack_bottom : &stack_top_variable, | |
| 4721 stack_size); | |
| 4722 } | |
| 4723 } | |
| 4724 #endif /* MAX_SAVE_STACK > 0 */ | |
| 4725 | |
| 4726 /* Do some totally ad-hoc resource clearing. */ | |
| 4727 /* #### generalize this? */ | |
| 4728 clear_event_resource (); | |
| 4729 cleanup_specifiers (); | |
| 1204 | 4730 cleanup_buffer_undo_lists (); |
| 428 | 4731 |
| 4732 /* Mark all the special slots that serve as the roots of accessibility. */ | |
| 4733 | |
| 1598 | 4734 #ifdef USE_KKCC |
| 4735 /* initialize kkcc stack */ | |
| 4736 kkcc_gc_stack_init(); | |
| 1676 | 4737 #define mark_object kkcc_gc_stack_push_lisp_object |
| 1598 | 4738 #endif /* USE_KKCC */ |
| 4739 | |
| 428 | 4740 { /* staticpro() */ |
| 452 | 4741 Lisp_Object **p = Dynarr_begin (staticpros); |
| 665 | 4742 Elemcount count; |
| 452 | 4743 for (count = Dynarr_length (staticpros); count; count--) |
| 4744 mark_object (**p++); | |
| 4745 } | |
| 4746 | |
| 4747 { /* staticpro_nodump() */ | |
| 4748 Lisp_Object **p = Dynarr_begin (staticpros_nodump); | |
| 665 | 4749 Elemcount count; |
| 452 | 4750 for (count = Dynarr_length (staticpros_nodump); count; count--) |
| 4751 mark_object (**p++); | |
| 428 | 4752 } |
| 4753 | |
| 4754 { /* GCPRO() */ | |
| 4755 struct gcpro *tail; | |
| 4756 int i; | |
| 4757 for (tail = gcprolist; tail; tail = tail->next) | |
| 4758 for (i = 0; i < tail->nvars; i++) | |
| 4759 mark_object (tail->var[i]); | |
| 4760 } | |
| 4761 | |
| 4762 { /* specbind() */ | |
| 4763 struct specbinding *bind; | |
| 4764 for (bind = specpdl; bind != specpdl_ptr; bind++) | |
| 4765 { | |
| 4766 mark_object (bind->symbol); | |
| 4767 mark_object (bind->old_value); | |
| 4768 } | |
| 4769 } | |
| 4770 | |
| 4771 { | |
| 4772 struct catchtag *catch; | |
| 4773 for (catch = catchlist; catch; catch = catch->next) | |
| 4774 { | |
| 4775 mark_object (catch->tag); | |
| 4776 mark_object (catch->val); | |
| 853 | 4777 mark_object (catch->actual_tag); |
| 428 | 4778 } |
| 4779 } | |
| 4780 | |
| 4781 { | |
| 4782 struct backtrace *backlist; | |
| 4783 for (backlist = backtrace_list; backlist; backlist = backlist->next) | |
| 4784 { | |
| 4785 int nargs = backlist->nargs; | |
| 4786 int i; | |
| 4787 | |
| 4788 mark_object (*backlist->function); | |
| 1292 | 4789 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */ |
| 4790 /* might be fake (internal profiling entry) */ | |
| 4791 && backlist->args) | |
| 428 | 4792 mark_object (backlist->args[0]); |
| 4793 else | |
| 4794 for (i = 0; i < nargs; i++) | |
| 4795 mark_object (backlist->args[i]); | |
| 4796 } | |
| 4797 } | |
| 4798 | |
| 4799 mark_profiling_info (); | |
| 4800 | |
| 4801 /* OK, now do the after-mark stuff. This is for things that | |
| 4802 are only marked when something else is marked (e.g. weak hash tables). | |
| 4803 There may be complex dependencies between such objects -- e.g. | |
| 4804 a weak hash table might be unmarked, but after processing a later | |
| 4805 weak hash table, the former one might get marked. So we have to | |
| 4806 iterate until nothing more gets marked. */ | |
| 1598 | 4807 #ifdef USE_KKCC |
| 4808 kkcc_marking (); | |
| 4809 #endif /* USE_KKCC */ | |
| 1590 | 4810 init_marking_ephemerons (); |
| 428 | 4811 while (finish_marking_weak_hash_tables () > 0 || |
| 887 | 4812 finish_marking_weak_lists () > 0 || |
| 1590 | 4813 continue_marking_ephemerons () > 0) |
|
1773
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4814 #ifdef USE_KKCC |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4815 { |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4816 kkcc_marking (); |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4817 } |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4818 #else /* NOT USE_KKCC */ |
| 1590 | 4819 ; |
| 1598 | 4820 #endif /* USE_KKCC */ |
| 4821 | |
| 1590 | 4822 /* At this point, we know which objects need to be finalized: we |
| 4823 still need to resurrect them */ | |
| 4824 | |
| 4825 while (finish_marking_ephemerons () > 0 || | |
| 4826 finish_marking_weak_lists () > 0 || | |
| 4827 finish_marking_weak_hash_tables () > 0) | |
| 1643 | 4828 #ifdef USE_KKCC |
|
1773
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4829 { |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4830 kkcc_marking (); |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4831 } |
| 1643 | 4832 kkcc_gc_stack_free (); |
| 1676 | 4833 #undef mark_object |
|
1773
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4834 #else /* NOT USE_KKCC */ |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
4835 ; |
| 1643 | 4836 #endif /* USE_KKCC */ |
| 4837 | |
| 428 | 4838 /* And prune (this needs to be called after everything else has been |
| 4839 marked and before we do any sweeping). */ | |
| 4840 /* #### this is somewhat ad-hoc and should probably be an object | |
| 4841 method */ | |
| 4842 prune_weak_hash_tables (); | |
| 4843 prune_weak_lists (); | |
| 4844 prune_specifiers (); | |
| 4845 prune_syntax_tables (); | |
| 4846 | |
| 887 | 4847 prune_ephemerons (); |
| 858 | 4848 prune_weak_boxes (); |
| 4849 | |
| 428 | 4850 gc_sweep (); |
| 4851 | |
| 4852 consing_since_gc = 0; | |
| 4853 #ifndef DEBUG_XEMACS | |
| 4854 /* Allow you to set it really fucking low if you really want ... */ | |
| 4855 if (gc_cons_threshold < 10000) | |
| 4856 gc_cons_threshold = 10000; | |
| 4857 #endif | |
| 814 | 4858 recompute_need_to_garbage_collect (); |
| 428 | 4859 |
| 2367 | 4860 inhibit_non_essential_conversion_operations = 0; |
| 428 | 4861 gc_in_progress = 0; |
| 4862 | |
| 611 | 4863 run_post_gc_actions (); |
| 4864 | |
| 428 | 4865 /******* End of garbage collection ********/ |
| 4866 | |
| 4867 /* Now remove the GC cursor/message */ | |
| 4868 if (!noninteractive) | |
| 4869 { | |
| 4870 if (cursor_changed) | |
| 771 | 4871 Fset_frame_pointer (wrap_frame (f), pre_gc_cursor); |
| 428 | 4872 else if (!FRAME_STREAM_P (f)) |
| 4873 { | |
| 4874 /* Show "...done" only if the echo area would otherwise be empty. */ | |
| 4875 if (NILP (clear_echo_area (selected_frame (), | |
| 4876 Qgarbage_collecting, 0))) | |
| 4877 { | |
| 1154 | 4878 if (garbage_collection_messages) |
| 4879 { | |
| 4880 Lisp_Object args[2], whole_msg; | |
| 4881 args[0] = (STRINGP (Vgc_message) ? Vgc_message : | |
| 4882 build_msg_string (gc_default_message)); | |
| 4883 args[1] = build_msg_string ("... done"); | |
| 4884 whole_msg = Fconcat (2, args); | |
| 4885 echo_area_message (selected_frame (), (Ibyte *) 0, | |
| 4886 whole_msg, 0, -1, | |
| 4887 Qgarbage_collecting); | |
| 4888 } | |
| 428 | 4889 } |
| 4890 } | |
| 4891 } | |
| 4892 | |
| 4893 /* now stop inhibiting GC */ | |
| 771 | 4894 unbind_to (speccount); |
| 428 | 4895 |
| 4896 if (!breathing_space) | |
| 4897 { | |
| 4898 breathing_space = malloc (4096 - MALLOC_OVERHEAD); | |
| 4899 } | |
| 4900 | |
| 4901 UNGCPRO; | |
| 887 | 4902 |
| 4903 need_to_signal_post_gc = 1; | |
| 4904 funcall_allocation_flag = 1; | |
| 4905 | |
| 1292 | 4906 PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection); |
| 4907 | |
| 428 | 4908 return; |
| 4909 } | |
| 4910 | |
| 4911 /* Debugging aids. */ | |
| 4912 | |
| 4913 static Lisp_Object | |
| 2367 | 4914 gc_plist_hack (const Ascbyte *name, int value, Lisp_Object tail) |
| 428 | 4915 { |
| 4916 /* C doesn't have local functions (or closures, or GC, or readable syntax, | |
| 4917 or portable numeric datatypes, or bit-vectors, or characters, or | |
| 4918 arrays, or exceptions, or ...) */ | |
| 4919 return cons3 (intern (name), make_int (value), tail); | |
| 4920 } | |
| 4921 | |
| 4922 #define HACK_O_MATIC(type, name, pl) do { \ | |
| 4923 int s = 0; \ | |
| 4924 struct type##_block *x = current_##type##_block; \ | |
| 4925 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ | |
| 4926 (pl) = gc_plist_hack ((name), s, (pl)); \ | |
| 4927 } while (0) | |
| 4928 | |
| 4929 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* | |
| 4930 Reclaim storage for Lisp objects no longer needed. | |
| 4931 Return info on amount of space in use: | |
| 4932 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) | |
| 4933 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS | |
| 4934 PLIST) | |
| 4935 where `PLIST' is a list of alternating keyword/value pairs providing | |
| 4936 more detailed information. | |
| 4937 Garbage collection happens automatically if you cons more than | |
| 4938 `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
| 4939 */ | |
| 4940 ()) | |
| 4941 { | |
| 4942 Lisp_Object pl = Qnil; | |
| 647 | 4943 int i; |
| 428 | 4944 int gc_count_vector_total_size = 0; |
| 4945 garbage_collect_1 (); | |
| 4946 | |
| 442 | 4947 for (i = 0; i < lrecord_type_count; i++) |
| 428 | 4948 { |
| 4949 if (lcrecord_stats[i].bytes_in_use != 0 | |
| 4950 || lcrecord_stats[i].bytes_freed != 0 | |
| 4951 || lcrecord_stats[i].instances_on_free_list != 0) | |
| 4952 { | |
| 4953 char buf [255]; | |
| 442 | 4954 const char *name = lrecord_implementations_table[i]->name; |
| 428 | 4955 int len = strlen (name); |
| 4956 /* save this for the FSFmacs-compatible part of the summary */ | |
| 460 | 4957 if (i == lrecord_type_vector) |
| 428 | 4958 gc_count_vector_total_size = |
| 4959 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed; | |
| 4960 | |
| 4961 sprintf (buf, "%s-storage", name); | |
| 4962 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); | |
| 4963 /* Okay, simple pluralization check for `symbol-value-varalias' */ | |
| 4964 if (name[len-1] == 's') | |
| 4965 sprintf (buf, "%ses-freed", name); | |
| 4966 else | |
| 4967 sprintf (buf, "%ss-freed", name); | |
| 4968 if (lcrecord_stats[i].instances_freed != 0) | |
| 4969 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl); | |
| 4970 if (name[len-1] == 's') | |
| 4971 sprintf (buf, "%ses-on-free-list", name); | |
| 4972 else | |
| 4973 sprintf (buf, "%ss-on-free-list", name); | |
| 4974 if (lcrecord_stats[i].instances_on_free_list != 0) | |
| 4975 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list, | |
| 4976 pl); | |
| 4977 if (name[len-1] == 's') | |
| 4978 sprintf (buf, "%ses-used", name); | |
| 4979 else | |
| 4980 sprintf (buf, "%ss-used", name); | |
| 4981 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl); | |
| 4982 } | |
| 4983 } | |
| 4984 | |
| 4985 HACK_O_MATIC (extent, "extent-storage", pl); | |
| 4986 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl); | |
| 4987 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl); | |
| 4988 HACK_O_MATIC (event, "event-storage", pl); | |
| 4989 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl); | |
| 4990 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl); | |
| 4991 HACK_O_MATIC (marker, "marker-storage", pl); | |
| 4992 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl); | |
| 4993 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl); | |
| 4994 HACK_O_MATIC (float, "float-storage", pl); | |
| 4995 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl); | |
| 4996 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl); | |
| 1983 | 4997 #ifdef HAVE_BIGNUM |
| 4998 HACK_O_MATIC (bignum, "bignum-storage", pl); | |
| 4999 pl = gc_plist_hack ("bignums-free", gc_count_num_bignum_freelist, pl); | |
| 5000 pl = gc_plist_hack ("bignums-used", gc_count_num_bignum_in_use, pl); | |
| 5001 #endif /* HAVE_BIGNUM */ | |
| 5002 #ifdef HAVE_RATIO | |
| 5003 HACK_O_MATIC (ratio, "ratio-storage", pl); | |
| 5004 pl = gc_plist_hack ("ratios-free", gc_count_num_ratio_freelist, pl); | |
| 5005 pl = gc_plist_hack ("ratios-used", gc_count_num_ratio_in_use, pl); | |
| 5006 #endif /* HAVE_RATIO */ | |
| 5007 #ifdef HAVE_BIGFLOAT | |
| 5008 HACK_O_MATIC (bigfloat, "bigfloat-storage", pl); | |
| 5009 pl = gc_plist_hack ("bigfloats-free", gc_count_num_bigfloat_freelist, pl); | |
| 5010 pl = gc_plist_hack ("bigfloats-used", gc_count_num_bigfloat_in_use, pl); | |
| 5011 #endif /* HAVE_BIGFLOAT */ | |
| 428 | 5012 HACK_O_MATIC (string, "string-header-storage", pl); |
| 5013 pl = gc_plist_hack ("long-strings-total-length", | |
| 5014 gc_count_string_total_size | |
| 5015 - gc_count_short_string_total_size, pl); | |
| 5016 HACK_O_MATIC (string_chars, "short-string-storage", pl); | |
| 5017 pl = gc_plist_hack ("short-strings-total-length", | |
| 5018 gc_count_short_string_total_size, pl); | |
| 5019 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl); | |
| 5020 pl = gc_plist_hack ("long-strings-used", | |
| 5021 gc_count_num_string_in_use | |
| 5022 - gc_count_num_short_string_in_use, pl); | |
| 5023 pl = gc_plist_hack ("short-strings-used", | |
| 5024 gc_count_num_short_string_in_use, pl); | |
| 5025 | |
| 5026 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl); | |
| 5027 pl = gc_plist_hack ("compiled-functions-free", | |
| 5028 gc_count_num_compiled_function_freelist, pl); | |
| 5029 pl = gc_plist_hack ("compiled-functions-used", | |
| 5030 gc_count_num_compiled_function_in_use, pl); | |
| 5031 | |
| 5032 HACK_O_MATIC (symbol, "symbol-storage", pl); | |
| 5033 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl); | |
| 5034 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl); | |
| 5035 | |
| 5036 HACK_O_MATIC (cons, "cons-storage", pl); | |
| 5037 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl); | |
| 5038 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl); | |
| 5039 | |
| 5040 /* The things we do for backwards-compatibility */ | |
| 5041 return | |
| 5042 list6 (Fcons (make_int (gc_count_num_cons_in_use), | |
| 5043 make_int (gc_count_num_cons_freelist)), | |
| 5044 Fcons (make_int (gc_count_num_symbol_in_use), | |
| 5045 make_int (gc_count_num_symbol_freelist)), | |
| 5046 Fcons (make_int (gc_count_num_marker_in_use), | |
| 5047 make_int (gc_count_num_marker_freelist)), | |
| 5048 make_int (gc_count_string_total_size), | |
| 5049 make_int (gc_count_vector_total_size), | |
| 5050 pl); | |
| 5051 } | |
| 5052 #undef HACK_O_MATIC | |
| 5053 | |
| 5054 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /* | |
| 5055 Return the number of bytes consed since the last garbage collection. | |
| 5056 \"Consed\" is a misnomer in that this actually counts allocation | |
| 5057 of all different kinds of objects, not just conses. | |
| 5058 | |
| 5059 If this value exceeds `gc-cons-threshold', a garbage collection happens. | |
| 5060 */ | |
| 5061 ()) | |
| 5062 { | |
| 5063 return make_int (consing_since_gc); | |
| 5064 } | |
| 5065 | |
| 440 | 5066 #if 0 |
| 444 | 5067 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /* |
| 801 | 5068 Return the address of the last byte XEmacs has allocated, divided by 1024. |
| 5069 This may be helpful in debugging XEmacs's memory usage. | |
| 428 | 5070 The value is divided by 1024 to make sure it will fit in a lisp integer. |
| 5071 */ | |
| 5072 ()) | |
| 5073 { | |
| 5074 return make_int ((EMACS_INT) sbrk (0) / 1024); | |
| 5075 } | |
| 440 | 5076 #endif |
| 428 | 5077 |
| 801 | 5078 DEFUN ("memory-usage", Fmemory_usage, 0, 0, 0, /* |
| 5079 Return the total number of bytes used by the data segment in XEmacs. | |
| 5080 This may be helpful in debugging XEmacs's memory usage. | |
| 5081 */ | |
| 5082 ()) | |
| 5083 { | |
| 5084 return make_int (total_data_usage ()); | |
| 5085 } | |
| 5086 | |
| 851 | 5087 void |
| 5088 recompute_funcall_allocation_flag (void) | |
| 5089 { | |
| 887 | 5090 funcall_allocation_flag = |
| 5091 need_to_garbage_collect || | |
| 5092 need_to_check_c_alloca || | |
| 5093 need_to_signal_post_gc; | |
| 851 | 5094 } |
| 5095 | |
| 801 | 5096 /* True if it's time to garbage collect now. */ |
| 814 | 5097 static void |
| 5098 recompute_need_to_garbage_collect (void) | |
| 801 | 5099 { |
| 5100 if (always_gc) | |
| 814 | 5101 need_to_garbage_collect = 1; |
| 5102 else | |
| 5103 need_to_garbage_collect = | |
| 5104 (consing_since_gc > gc_cons_threshold | |
| 5105 #if 0 /* #### implement this better */ | |
| 5106 && | |
| 5107 (100 * consing_since_gc) / total_data_usage () >= | |
| 5108 gc_cons_percentage | |
| 5109 #endif /* 0 */ | |
| 5110 ); | |
| 851 | 5111 recompute_funcall_allocation_flag (); |
| 801 | 5112 } |
| 5113 | |
| 428 | 5114 |
| 5115 int | |
| 5116 object_dead_p (Lisp_Object obj) | |
| 5117 { | |
| 5118 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || | |
| 5119 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || | |
| 5120 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || | |
| 5121 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || | |
| 5122 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || | |
| 5123 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || | |
| 5124 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); | |
| 5125 } | |
| 5126 | |
| 5127 #ifdef MEMORY_USAGE_STATS | |
| 5128 | |
| 5129 /* Attempt to determine the actual amount of space that is used for | |
| 5130 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". | |
| 5131 | |
| 5132 It seems that the following holds: | |
| 5133 | |
| 5134 1. When using the old allocator (malloc.c): | |
| 5135 | |
| 5136 -- blocks are always allocated in chunks of powers of two. For | |
| 5137 each block, there is an overhead of 8 bytes if rcheck is not | |
| 5138 defined, 20 bytes if it is defined. In other words, a | |
| 5139 one-byte allocation needs 8 bytes of overhead for a total of | |
| 5140 9 bytes, and needs to have 16 bytes of memory chunked out for | |
| 5141 it. | |
| 5142 | |
| 5143 2. When using the new allocator (gmalloc.c): | |
| 5144 | |
| 5145 -- blocks are always allocated in chunks of powers of two up | |
| 5146 to 4096 bytes. Larger blocks are allocated in chunks of | |
| 5147 an integral multiple of 4096 bytes. The minimum block | |
| 5148 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG | |
| 5149 is defined. There is no per-block overhead, but there | |
| 5150 is an overhead of 3*sizeof (size_t) for each 4096 bytes | |
| 5151 allocated. | |
| 5152 | |
| 5153 3. When using the system malloc, anything goes, but they are | |
| 5154 generally slower and more space-efficient than the GNU | |
| 5155 allocators. One possibly reasonable assumption to make | |
| 5156 for want of better data is that sizeof (void *), or maybe | |
| 5157 2 * sizeof (void *), is required as overhead and that | |
| 5158 blocks are allocated in the minimum required size except | |
| 5159 that some minimum block size is imposed (e.g. 16 bytes). */ | |
| 5160 | |
| 665 | 5161 Bytecount |
| 2286 | 5162 malloced_storage_size (void *UNUSED (ptr), Bytecount claimed_size, |
| 428 | 5163 struct overhead_stats *stats) |
| 5164 { | |
| 665 | 5165 Bytecount orig_claimed_size = claimed_size; |
| 428 | 5166 |
| 5167 #ifdef GNU_MALLOC | |
| 665 | 5168 if (claimed_size < (Bytecount) (2 * sizeof (void *))) |
| 428 | 5169 claimed_size = 2 * sizeof (void *); |
| 5170 # ifdef SUNOS_LOCALTIME_BUG | |
| 5171 if (claimed_size < 16) | |
| 5172 claimed_size = 16; | |
| 5173 # endif | |
| 5174 if (claimed_size < 4096) | |
| 5175 { | |
| 2260 | 5176 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
| 5177 int log2 = 1; | |
| 428 | 5178 |
| 5179 /* compute the log base two, more or less, then use it to compute | |
| 5180 the block size needed. */ | |
| 5181 claimed_size--; | |
| 5182 /* It's big, it's heavy, it's wood! */ | |
| 5183 while ((claimed_size /= 2) != 0) | |
| 2260 | 5184 ++log2; |
| 428 | 5185 claimed_size = 1; |
| 5186 /* It's better than bad, it's good! */ | |
| 2260 | 5187 while (log2 > 0) |
| 428 | 5188 { |
| 5189 claimed_size *= 2; | |
| 2260 | 5190 log2--; |
| 428 | 5191 } |
| 5192 /* We have to come up with some average about the amount of | |
| 5193 blocks used. */ | |
| 665 | 5194 if ((Bytecount) (rand () & 4095) < claimed_size) |
| 428 | 5195 claimed_size += 3 * sizeof (void *); |
| 5196 } | |
| 5197 else | |
| 5198 { | |
| 5199 claimed_size += 4095; | |
| 5200 claimed_size &= ~4095; | |
| 5201 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); | |
| 5202 } | |
| 5203 | |
| 5204 #elif defined (SYSTEM_MALLOC) | |
| 5205 | |
| 5206 if (claimed_size < 16) | |
| 5207 claimed_size = 16; | |
| 5208 claimed_size += 2 * sizeof (void *); | |
| 5209 | |
| 5210 #else /* old GNU allocator */ | |
| 5211 | |
| 5212 # ifdef rcheck /* #### may not be defined here */ | |
| 5213 claimed_size += 20; | |
| 5214 # else | |
| 5215 claimed_size += 8; | |
| 5216 # endif | |
| 5217 { | |
| 2260 | 5218 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
| 5219 int log2 = 1; | |
| 428 | 5220 |
| 5221 /* compute the log base two, more or less, then use it to compute | |
| 5222 the block size needed. */ | |
| 5223 claimed_size--; | |
| 5224 /* It's big, it's heavy, it's wood! */ | |
| 5225 while ((claimed_size /= 2) != 0) | |
| 2260 | 5226 ++log2; |
| 428 | 5227 claimed_size = 1; |
| 5228 /* It's better than bad, it's good! */ | |
| 2260 | 5229 while (log2 > 0) |
| 428 | 5230 { |
| 5231 claimed_size *= 2; | |
| 2260 | 5232 log2--; |
| 428 | 5233 } |
| 5234 } | |
| 5235 | |
| 5236 #endif /* old GNU allocator */ | |
| 5237 | |
| 5238 if (stats) | |
| 5239 { | |
| 5240 stats->was_requested += orig_claimed_size; | |
| 5241 stats->malloc_overhead += claimed_size - orig_claimed_size; | |
| 5242 } | |
| 5243 return claimed_size; | |
| 5244 } | |
| 5245 | |
| 665 | 5246 Bytecount |
| 5247 fixed_type_block_overhead (Bytecount size) | |
| 428 | 5248 { |
| 665 | 5249 Bytecount per_block = TYPE_ALLOC_SIZE (cons, unsigned char); |
| 5250 Bytecount overhead = 0; | |
| 5251 Bytecount storage_size = malloced_storage_size (0, per_block, 0); | |
| 428 | 5252 while (size >= per_block) |
| 5253 { | |
| 5254 size -= per_block; | |
| 5255 overhead += sizeof (void *) + per_block - storage_size; | |
| 5256 } | |
| 5257 if (rand () % per_block < size) | |
| 5258 overhead += sizeof (void *) + per_block - storage_size; | |
| 5259 return overhead; | |
| 5260 } | |
| 5261 | |
| 5262 #endif /* MEMORY_USAGE_STATS */ | |
| 5263 | |
| 5264 | |
| 5265 /* Initialization */ | |
| 771 | 5266 static void |
| 1204 | 5267 common_init_alloc_early (void) |
| 428 | 5268 { |
| 771 | 5269 #ifndef Qzero |
| 5270 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ | |
| 5271 #endif | |
| 5272 | |
| 5273 #ifndef Qnull_pointer | |
| 5274 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, | |
| 5275 so the following is actually a no-op. */ | |
| 793 | 5276 Qnull_pointer = wrap_pointer_1 (0); |
| 771 | 5277 #endif |
| 5278 | |
| 428 | 5279 gc_generation_number[0] = 0; |
| 5280 breathing_space = 0; | |
| 771 | 5281 Vgc_message = Qzero; |
| 428 | 5282 all_lcrecords = 0; |
| 5283 ignore_malloc_warnings = 1; | |
| 5284 #ifdef DOUG_LEA_MALLOC | |
| 5285 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ | |
| 5286 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ | |
| 5287 #if 0 /* Moved to emacs.c */ | |
| 5288 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ | |
| 5289 #endif | |
| 5290 #endif | |
| 5291 init_string_alloc (); | |
| 5292 init_string_chars_alloc (); | |
| 5293 init_cons_alloc (); | |
| 5294 init_symbol_alloc (); | |
| 5295 init_compiled_function_alloc (); | |
| 5296 init_float_alloc (); | |
| 1983 | 5297 #ifdef HAVE_BIGNUM |
| 5298 init_bignum_alloc (); | |
| 5299 #endif | |
| 5300 #ifdef HAVE_RATIO | |
| 5301 init_ratio_alloc (); | |
| 5302 #endif | |
| 5303 #ifdef HAVE_BIGFLOAT | |
| 5304 init_bigfloat_alloc (); | |
| 5305 #endif | |
| 428 | 5306 init_marker_alloc (); |
| 5307 init_extent_alloc (); | |
| 5308 init_event_alloc (); | |
| 1204 | 5309 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 5310 init_key_data_alloc (); |
| 5311 init_button_data_alloc (); | |
| 5312 init_motion_data_alloc (); | |
| 5313 init_process_data_alloc (); | |
| 5314 init_timeout_data_alloc (); | |
| 5315 init_magic_data_alloc (); | |
| 5316 init_magic_eval_data_alloc (); | |
| 5317 init_eval_data_alloc (); | |
| 5318 init_misc_user_data_alloc (); | |
| 1204 | 5319 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 428 | 5320 |
| 5321 ignore_malloc_warnings = 0; | |
| 5322 | |
| 452 | 5323 if (staticpros_nodump) |
| 5324 Dynarr_free (staticpros_nodump); | |
| 5325 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); | |
| 5326 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */ | |
| 771 | 5327 #ifdef DEBUG_XEMACS |
| 5328 if (staticpro_nodump_names) | |
| 5329 Dynarr_free (staticpro_nodump_names); | |
| 5330 staticpro_nodump_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 5331 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */ | |
| 5332 #endif | |
| 428 | 5333 |
| 5334 consing_since_gc = 0; | |
| 814 | 5335 need_to_garbage_collect = always_gc; |
| 851 | 5336 need_to_check_c_alloca = 0; |
| 5337 funcall_allocation_flag = 0; | |
| 5338 funcall_alloca_count = 0; | |
| 814 | 5339 |
| 428 | 5340 #if 1 |
| 5341 gc_cons_threshold = 500000; /* XEmacs change */ | |
| 5342 #else | |
| 5343 gc_cons_threshold = 15000; /* debugging */ | |
| 5344 #endif | |
| 801 | 5345 gc_cons_percentage = 0; /* #### 20; Don't have an accurate measure of |
| 5346 memory usage on Windows; not verified on other | |
| 5347 systems */ | |
| 428 | 5348 lrecord_uid_counter = 259; |
| 5349 debug_string_purity = 0; | |
| 5350 | |
| 5351 gc_currently_forbidden = 0; | |
| 5352 gc_hooks_inhibited = 0; | |
| 5353 | |
| 800 | 5354 #ifdef ERROR_CHECK_TYPES |
| 428 | 5355 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = |
| 5356 666; | |
| 5357 ERROR_ME_NOT. | |
| 5358 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; | |
| 5359 ERROR_ME_WARN. | |
| 5360 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 5361 3333632; | |
| 793 | 5362 ERROR_ME_DEBUG_WARN. |
| 5363 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 5364 8675309; | |
| 800 | 5365 #endif /* ERROR_CHECK_TYPES */ |
| 428 | 5366 } |
| 5367 | |
| 771 | 5368 static void |
| 5369 init_lcrecord_lists (void) | |
| 5370 { | |
| 5371 int i; | |
| 5372 | |
| 5373 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 5374 { | |
| 5375 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */ | |
| 5376 staticpro_nodump (&all_lcrecord_lists[i]); | |
| 5377 } | |
| 5378 } | |
| 5379 | |
| 5380 void | |
| 1204 | 5381 init_alloc_early (void) |
| 771 | 5382 { |
| 1204 | 5383 #if defined (__cplusplus) && defined (ERROR_CHECK_GC) |
| 5384 static struct gcpro initial_gcpro; | |
| 5385 | |
| 5386 initial_gcpro.next = 0; | |
| 5387 initial_gcpro.var = &Qnil; | |
| 5388 initial_gcpro.nvars = 1; | |
| 5389 gcprolist = &initial_gcpro; | |
| 5390 #else | |
| 5391 gcprolist = 0; | |
| 5392 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */ | |
| 5393 } | |
| 5394 | |
| 5395 void | |
| 5396 reinit_alloc_early (void) | |
| 5397 { | |
| 5398 common_init_alloc_early (); | |
| 771 | 5399 init_lcrecord_lists (); |
| 5400 } | |
| 5401 | |
| 428 | 5402 void |
| 5403 init_alloc_once_early (void) | |
| 5404 { | |
| 1204 | 5405 common_init_alloc_early (); |
| 428 | 5406 |
| 442 | 5407 { |
| 5408 int i; | |
| 5409 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 5410 lrecord_implementations_table[i] = 0; | |
| 5411 } | |
| 5412 | |
| 5413 INIT_LRECORD_IMPLEMENTATION (cons); | |
| 5414 INIT_LRECORD_IMPLEMENTATION (vector); | |
| 5415 INIT_LRECORD_IMPLEMENTATION (string); | |
| 5416 INIT_LRECORD_IMPLEMENTATION (lcrecord_list); | |
| 1204 | 5417 INIT_LRECORD_IMPLEMENTATION (free); |
| 428 | 5418 |
| 452 | 5419 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); |
| 5420 Dynarr_resize (staticpros, 1410); /* merely a small optimization */ | |
| 2367 | 5421 dump_add_root_block_ptr (&staticpros, &staticpros_description); |
| 771 | 5422 #ifdef DEBUG_XEMACS |
| 5423 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 5424 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */ | |
| 2367 | 5425 dump_add_root_block_ptr (&staticpro_names, &staticpro_names_description); |
| 771 | 5426 #endif |
| 5427 | |
| 5428 init_lcrecord_lists (); | |
| 428 | 5429 } |
| 5430 | |
| 5431 void | |
| 5432 syms_of_alloc (void) | |
| 5433 { | |
| 442 | 5434 DEFSYMBOL (Qpre_gc_hook); |
| 5435 DEFSYMBOL (Qpost_gc_hook); | |
| 5436 DEFSYMBOL (Qgarbage_collecting); | |
| 428 | 5437 |
| 5438 DEFSUBR (Fcons); | |
| 5439 DEFSUBR (Flist); | |
| 5440 DEFSUBR (Fvector); | |
| 5441 DEFSUBR (Fbit_vector); | |
| 5442 DEFSUBR (Fmake_byte_code); | |
| 5443 DEFSUBR (Fmake_list); | |
| 5444 DEFSUBR (Fmake_vector); | |
| 5445 DEFSUBR (Fmake_bit_vector); | |
| 5446 DEFSUBR (Fmake_string); | |
| 5447 DEFSUBR (Fstring); | |
| 5448 DEFSUBR (Fmake_symbol); | |
| 5449 DEFSUBR (Fmake_marker); | |
| 5450 DEFSUBR (Fpurecopy); | |
| 5451 DEFSUBR (Fgarbage_collect); | |
| 440 | 5452 #if 0 |
| 428 | 5453 DEFSUBR (Fmemory_limit); |
| 440 | 5454 #endif |
| 801 | 5455 DEFSUBR (Fmemory_usage); |
| 428 | 5456 DEFSUBR (Fconsing_since_gc); |
| 5457 } | |
| 5458 | |
| 5459 void | |
| 5460 vars_of_alloc (void) | |
| 5461 { | |
| 1292 | 5462 QSin_garbage_collection = build_msg_string ("(in garbage collection)"); |
| 5463 staticpro (&QSin_garbage_collection); | |
| 5464 | |
| 428 | 5465 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /* |
| 5466 *Number of bytes of consing between garbage collections. | |
| 5467 \"Consing\" is a misnomer in that this actually counts allocation | |
| 5468 of all different kinds of objects, not just conses. | |
| 5469 Garbage collection can happen automatically once this many bytes have been | |
| 5470 allocated since the last garbage collection. All data types count. | |
| 5471 | |
| 5472 Garbage collection happens automatically when `eval' or `funcall' are | |
| 5473 called. (Note that `funcall' is called implicitly as part of evaluation.) | |
| 5474 By binding this temporarily to a large number, you can effectively | |
| 5475 prevent garbage collection during a part of the program. | |
| 5476 | |
| 853 | 5477 Normally, you cannot set this value less than 10,000 (if you do, it is |
| 5478 automatically reset during the next garbage collection). However, if | |
| 5479 XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing | |
| 5480 you to set this value very low to track down problems with insufficient | |
| 5481 GCPRO'ing. If you set this to a negative number, garbage collection will | |
| 5482 happen at *EVERY* call to `eval' or `funcall'. This is an extremely | |
| 5483 effective way to check GCPRO problems, but be warned that your XEmacs | |
| 5484 will be unusable! You almost certainly won't have the patience to wait | |
| 5485 long enough to be able to set it back. | |
| 5486 | |
| 428 | 5487 See also `consing-since-gc'. |
| 5488 */ ); | |
| 5489 | |
| 801 | 5490 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /* |
| 5491 *Percentage of memory allocated between garbage collections. | |
| 5492 | |
| 5493 Garbage collection will happen if this percentage of the total amount of | |
| 5494 memory used for data has been allocated since the last garbage collection. | |
| 5495 However, it will not happen if less than `gc-cons-threshold' bytes have | |
| 5496 been allocated -- this sets an absolute minimum in case very little data | |
| 5497 has been allocated or the percentage is set very low. Set this to 0 to | |
| 5498 have garbage collection always happen after `gc-cons-threshold' bytes have | |
| 5499 been allocated, regardless of current memory usage. | |
| 5500 | |
| 5501 Garbage collection happens automatically when `eval' or `funcall' are | |
| 5502 called. (Note that `funcall' is called implicitly as part of evaluation.) | |
| 5503 By binding this temporarily to a large number, you can effectively | |
| 5504 prevent garbage collection during a part of the program. | |
| 5505 | |
| 5506 See also `consing-since-gc'. | |
| 5507 */ ); | |
| 5508 | |
| 428 | 5509 #ifdef DEBUG_XEMACS |
| 5510 DEFVAR_INT ("debug-allocation", &debug_allocation /* | |
| 5511 If non-zero, print out information to stderr about all objects allocated. | |
| 5512 See also `debug-allocation-backtrace-length'. | |
| 5513 */ ); | |
| 5514 debug_allocation = 0; | |
| 5515 | |
| 5516 DEFVAR_INT ("debug-allocation-backtrace-length", | |
| 5517 &debug_allocation_backtrace_length /* | |
| 5518 Length (in stack frames) of short backtrace printed out by `debug-allocation'. | |
| 5519 */ ); | |
| 5520 debug_allocation_backtrace_length = 2; | |
| 5521 #endif | |
| 5522 | |
| 5523 DEFVAR_BOOL ("purify-flag", &purify_flag /* | |
| 5524 Non-nil means loading Lisp code in order to dump an executable. | |
| 5525 This means that certain objects should be allocated in readonly space. | |
| 5526 */ ); | |
| 5527 | |
| 1154 | 5528 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /* |
| 5529 Non-nil means display messages at start and end of garbage collection. | |
| 5530 */ ); | |
| 5531 garbage_collection_messages = 0; | |
| 5532 | |
| 428 | 5533 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /* |
| 5534 Function or functions to be run just before each garbage collection. | |
| 5535 Interrupts, garbage collection, and errors are inhibited while this hook | |
| 5536 runs, so be extremely careful in what you add here. In particular, avoid | |
| 5537 consing, and do not interact with the user. | |
| 5538 */ ); | |
| 5539 Vpre_gc_hook = Qnil; | |
| 5540 | |
| 5541 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /* | |
| 5542 Function or functions to be run just after each garbage collection. | |
| 5543 Interrupts, garbage collection, and errors are inhibited while this hook | |
| 887 | 5544 runs. Each hook is called with one argument which is an alist with |
| 5545 finalization data. | |
| 428 | 5546 */ ); |
| 5547 Vpost_gc_hook = Qnil; | |
| 5548 | |
| 5549 DEFVAR_LISP ("gc-message", &Vgc_message /* | |
| 5550 String to print to indicate that a garbage collection is in progress. | |
| 5551 This is printed in the echo area. If the selected frame is on a | |
| 5552 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer | |
| 5553 image instance) in the domain of the selected frame, the mouse pointer | |
| 5554 will change instead of this message being printed. | |
| 5555 */ ); | |
| 5556 Vgc_message = build_string (gc_default_message); | |
| 5557 | |
| 5558 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /* | |
| 5559 Pointer glyph used to indicate that a garbage collection is in progress. | |
| 5560 If the selected window is on a window system and this glyph specifies a | |
| 5561 value (i.e. a pointer image instance) in the domain of the selected | |
| 5562 window, the pointer will be changed as specified during garbage collection. | |
| 5563 Otherwise, a message will be printed in the echo area, as controlled | |
| 5564 by `gc-message'. | |
| 5565 */ ); | |
| 5566 } | |
| 5567 | |
| 5568 void | |
| 5569 complex_vars_of_alloc (void) | |
| 5570 { | |
| 5571 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); | |
| 5572 } |