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