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