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