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