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