Mercurial > hg > xemacs-beta
annotate src/alloc.c @ 2720:6fa9919a9a0b
[xemacs-hg @ 2005-04-08 23:10:01 by crestani]
ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* configure.ac (XE_COMPLEX_ARG_ENABLE): Add `--enable-mc-alloc' as
a new configure flag.
* configure.in (AC_INIT_PARSE_ARGS): Add `--mc-alloc' as a new
configure flag.
* configure.usage: Add description for `mc-alloc'.
DUMP_IN_EXEC:
* Makefile.in.in: Condition the installation of a separate dump
file on !DUMP_ON_EXEC.
* configure.ac (XE_COMPLEX_ARG_ENABLE): Add
`--enable-dump-in-exec' as a new configure flag.
* configure.ac: DUMP_IN_EXEC is define as default for PDUMP but
not default for MC_ALLOC.
* configure.in (AC_INIT_PARSE_ARGS): Add `--dump-in-exec' as a
new configure flag.
* configure.in: DUMP_IN_EXEC is define as default for PDUMP but
not default for MC_ALLOC.
* configure.usage: Add description for `dump-in-exec'.
lib-src/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
DUMP_IN_EXEC:
* Makefile.in.in: Only compile insert-data-in-exec if
DUMP_IN_EXEC is defined.
lisp/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
MEMORY_USAGE_STATS
* diagnose.el: Add new lisp function to pretty print statistics
about the new allocator.
* diagnose.el (show-mc-alloc-memory-usage): New.
modules/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
Remove Lcrecords:
* postgresql/postgresql.c (allocate_pgconn): Allocate with new
allocator.
* postgresql/postgresql.c (allocate_pgresult): Allocate PGresult
with new allocator.
* postgresql/postgresql.h (struct Lisp_PGconn): Add
lrecord_header.
* postgresql/postgresql.h (struct Lisp_PGresult): Add
lrecord_header.
* ldap/eldap.c (allocate_ldap): Allocate with new allocator.
* ldap/eldap.h (struct Lisp_LDAP): Add lrecord_header.
nt/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* config.inc.samp: Add new flag `MC_ALLOC'.
* xemacs.mak: Add flag and configuration output for `MC_ALLOC'.
New files:
* xemacs.dsp: Add source files mc-alloc.c and mc-alloc.h.
* xemacs.mak: Add new object file mc-alloc.obj to dependencies.
src/ChangeLog addition:
2005-04-01 Marcus Crestani <crestani@xemacs.org>
The new allocator.
New configure flag: `MC_ALLOC':
* config.h.in: Add new flag `MC_ALLOC'.
New files:
* Makefile.in.in: Add new object file mc-alloc.o.
* depend: Add new files to dependencies.
* mc-alloc.c: New.
* mc-alloc.h: New.
Running the new allocator from XEmacs:
* alloc.c (deadbeef_memory): Moved to mc-alloc.c.
* emacs.c (main_1): Initialize the new allocator and add
syms_of_mc_alloc.
* symsinit.h: Add syms_of_mc_alloc.
New lrecord allocation and free functions:
* alloc.c (alloc_lrecord): New. Allocates an lrecord, includes
type checking and initializing of the lrecord_header.
* alloc.c (noseeum_alloc_lrecord): Same as above, but increments
the NOSEEUM cons counter.
* alloc.c (free_lrecord): New. Calls the finalizer and frees the
lrecord.
* lrecord.h: Add lrecord allocation prototypes and comments.
Remove old lrecord FROB block allocation:
* alloc.c (allocate_lisp_storage): Former function to expand
heap. Not needed anymore, remove.
* alloc.c: Completely remove `Fixed-size type macros'
* alloc.c (release_breathing_space): Remove.
* alloc.c (memory_full): Remove release_breathing_space.
* alloc.c (refill_memory_reserve): Remove.
* alloc.c (TYPE_ALLOC_SIZE): Remove.
* alloc.c (DECLARE_FIXED_TYPE_ALLOC): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE_FROM_BLOCK): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE_1): Remove.
* alloc.c (ALLOCATE_FIXED_TYPE): Remove.
* alloc.c (NOSEEUM_ALLOCATE_FIXED_TYPE): Remove.
* alloc.c (struct Lisp_Free): Remove.
* alloc.c (LRECORD_FREE_P): Remove.
* alloc.c (MARK_LRECORD_AS_FREE): Remove.
* alloc.c (MARK_LRECORD_AS_NOT_FREE): Remove.
* alloc.c (PUT_FIXED_TYPE_ON_FREE_LIST): Remove.
* alloc.c (FREE_FIXED_TYPE): Remove.
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC): Remove.
Allocate old lrecords with new allocator:
* alloc.c: DECLARE_FIXED_TYPE_ALLOC removed for all lrecords
defined in alloc.c.
* alloc.c (Fcons): Allocate with new allocator.
* alloc.c (noseeum_cons): Allocate with new allocator.
* alloc.c (make_float): Allocate with new allocator.
* alloc.c (make_bignum): Allocate with new allocator.
* alloc.c (make_bignum_bg): Allocate with new allocator.
* alloc.c (make_ratio): Allocate with new allocator.
* alloc.c (make_ratio_bg): Allocate with new allocator.
* alloc.c (make_ratio_rt): Allocate with new allocator.
* alloc.c (make_bigfloat): Allocate with new allocator.
* alloc.c (make_bigfloat_bf): Allocate with new allocator.
* alloc.c (make_compiled_function): Allocate with new allocator.
* alloc.c (Fmake_symbol): Allocate with new allocator.
* alloc.c (allocate_extent): Allocate with new allocator.
* alloc.c (allocate_event): Allocate with new allocator.
* alloc.c (make_key_data): Allocate with new allocator.
* alloc.c (make_button_data): Allocate with new allocator.
* alloc.c (make_motion_data): Allocate with new allocator.
* alloc.c (make_process_data): Allocate with new allocator.
* alloc.c (make_timeout_data): Allocate with new allocator.
* alloc.c (make_magic_data): Allocate with new allocator.
* alloc.c (make_magic_eval_data): Allocate with new allocator.
* alloc.c (make_eval_data): Allocate with new allocator.
* alloc.c (make_misc_user_data): Allocate with new allocator.
* alloc.c (Fmake_marker): Allocate with new allocator.
* alloc.c (noseeum_make_marker): Allocate with new allocator.
* alloc.c (make_uninit_string): Allocate with new allocator.
* alloc.c (resize_string): Allocate with new allocator.
* alloc.c (make_string_nocopy): Allocate with new allocator.
Garbage Collection:
* alloc.c (GC_CHECK_NOT_FREE): Remove obsolete assertions.
* alloc.c (SWEEP_FIXED_TYPE_BLOCK): Remove.
* alloc.c (SWEEP_FIXED_TYPE_BLOCK_1): Remove.
* alloc.c (sweep_conses): Remove.
* alloc.c (free_cons): Use new allocator to free.
* alloc.c (sweep_compiled_functions): Remove.
* alloc.c (sweep_floats): Remove.
* alloc.c (sweep_bignums): Remove.
* alloc.c (sweep_ratios): Remove.
* alloc.c (sweep_bigfloats): Remove.
* alloc.c (sweep_symbols): Remove.
* alloc.c (sweep_extents): Remove.
* alloc.c (sweep_events): Remove.
* alloc.c (sweep_key_data): Remove.
* alloc.c (free_key_data): Use new allocator to free.
* alloc.c (sweep_button_data): Remove.
* alloc.c (free_button_data): Use new allocator to free.
* alloc.c (sweep_motion_data): Remove.
* alloc.c (free_motion_data): Use new allocator to free.
* alloc.c (sweep_process_data): Remove.
* alloc.c (free_process_data): Use new allocator to free.
* alloc.c (sweep_timeout_data): Remove.
* alloc.c (free_timeout_data): Use new allocator to free.
* alloc.c (sweep_magic_data): Remove.
* alloc.c (free_magic_data): Use new allocator to free.
* alloc.c (sweep_magic_eval_data): Remove.
* alloc.c (free_magic_eval_data): Use new allocator to free.
* alloc.c (sweep_eval_data): Remove.
* alloc.c (free_eval_data): Use new allocator to free.
* alloc.c (sweep_misc_user_data): Remove.
* alloc.c (free_misc_user_data): Use new allocator to free.
* alloc.c (sweep_markers): Remove.
* alloc.c (free_marker): Use new allocator to free.
* alloc.c (garbage_collect_1): Remove release_breathing_space.
* alloc.c (gc_sweep): Remove all the old lcrecord and lrecord
related stuff. Sweeping now works like this: compact string
chars, finalize, sweep.
* alloc.c (common_init_alloc_early): Remove old lrecord
initializations, remove breathing_space.
* emacs.c (Fdump_emacs): Remove release_breathing_space.
* lisp.h: Remove prototype for release_breathing_space.
* lisp.h: Adjust the special cons mark makros.
Lrecord Finalizer:
* alloc.c: Add finalizer to lrecord definition.
* alloc.c (finalize_string): Add finalizer for string.
* bytecode.c: Add finalizer to lrecord definition.
* bytecode.c (finalize_compiled_function): Add finalizer for
compiled function.
* marker.c: Add finalizer to lrecord definition.
* marker.c (finalize_marker): Add finalizer for marker.
These changes build the interface to mc-alloc:
* lrecord.h (MC_ALLOC_CALL_FINALIZER): Tell mc-alloc how to
finalize lrecords.
* lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE): Tell
mc-alloc how to finalize for disksave.
Unify lrecords and lcrecords:
* lisp.h (struct Lisp_String): Adjust string union hack to
new lrecord header.
* lrecord.h: Adjust comments.
* lrecord.h (struct lrecord_header): The new lrecord header
includes type, lisp-readonly, free, and uid.
* lrecord.h (set_lheader_implementation): Adjust to new
lrecord_header.
* lrecord.h (struct lrecord_implementation): The field basic_p
for indication of an old lrecord is not needed anymore, remove.
* lrecord.h (MAKE_LRECORD_IMPLEMENTATION): Remove basic_p.
* lrecord.h (MAKE_EXTERNAL_LRECORD_IMPLEMENTATION): Remove
basic_p.
* lrecord.h (copy_sized_lrecord): Remove distinction between
old lrecords and lcrecords.
* lrecord.h (copy_lrecord): Remove distinction between old
lrecords and lcrecords.
* lrecord.h (zero_sized_lrecord): Remove distinction between
old lrecords and lcrecords.
* lrecord.h (zero_lrecord): Remove distinction between old
lrecords and lcrecords.
Remove lcrecords and lcrecord lists:
* alloc.c (basic_alloc_lcrecord): Not needed anymore, remove.
* alloc.c (very_old_free_lcrecord): Not needed anymore, remove.
* alloc.c (copy_lisp_object): No more distinction between
lrecords and lcrecords.
* alloc.c (all_lcrecords): Not needed anymore, remove.
* alloc.c (make_vector_internal): Allocate as lrecord.
* alloc.c (make_bit_vector_internal): Allocate as lrecord.
* alloc.c: Completely remove `lcrecord lists'.
* alloc.c (free_description): Remove.
* alloc.c (lcrecord_list_description): Remove.
* alloc.c (mark_lcrecord_list): Remove.
* alloc.c (make_lcrecord_list): Remove.
* alloc.c (alloc_managed_lcrecord): Remove.
* alloc.c (free_managed_lcrecord): Remove.
* alloc.c (alloc_automanaged_lcrecord): Remove.
* alloc.c (free_lcrecord): Remove.
* alloc.c (lcrecord_stats): Remove.
* alloc.c (tick_lcrecord_stats): Remove.
* alloc.c (disksave_object_finalization_1): Add call to
mc_finalize_for_disksave. Remove the lcrecord way to visit all
objects.
* alloc.c (kkcc_marking): Remove XD_FLAG_FREE_LISP_OBJECT
* alloc.c (sweep_lcrecords_1): Remove.
* alloc.c (common_init_alloc_early): Remove everything related
to lcrecords, remove old lrecord initializations,
* alloc.c (init_lcrecord_lists): Not needed anymore, remove.
* alloc.c (reinit_alloc_early): Remove everything related to
lcrecords.
* alloc.c (init_alloc_once_early): Remove everything related to
lcrecords.
* buffer.c (allocate_buffer): Allocate as lrecord.
* buffer.c (nuke_all_buffer_slots): Use lrecord functions.
* buffer.c (common_init_complex_vars_of_buffer): Allocate as
lrecord.
* buffer.h (struct buffer): Add lrecord_header.
* casetab.c (allocate_case_table): Allocate as lrecord.
* casetab.h (struct Lisp_Case_Table): Add lrecord_header.
* charset.h (struct Lisp_Charset): Add lrecord_header.
* chartab.c (fill_char_table): Use lrecord functions.
* chartab.c (Fmake_char_table): Allocate as lrecord.
* chartab.c (make_char_table_entry): Allocate as lrecord.
* chartab.c (copy_char_table_entry): Allocate as lrecord.
* chartab.c (Fcopy_char_table): Allocate as lrecord.
* chartab.c (put_char_table): Use lrecord functions.
* chartab.h (struct Lisp_Char_Table_Entry): Add lrecord_header.
* chartab.h (struct Lisp_Char_Table): Add lrecord_header.
* console-impl.h (struct console): Add lrecord_header.
* console-msw-impl.h (struct Lisp_Devmode): Add lrecord_header.
* console-msw-impl.h (struct mswindows_dialog_id): Add
lrecord_header.
* console.c (allocate_console): Allocate as lrecord.
* console.c (nuke_all_console_slots): Use lrecord functions.
* console.c (common_init_complex_vars_of_console): Allocate as
lrecord.
* data.c (make_weak_list): Allocate as lrecord.
* data.c (make_weak_box): Allocate as lrecord.
* data.c (make_ephemeron): Allocate as lrecord.
* database.c (struct Lisp_Database): Add lrecord_header.
* database.c (allocate_database): Allocate as lrecord.
* device-impl.h (struct device): Add lrecord_header.
* device-msw.c (allocate_devmode): Allocate as lrecord.
* device.c (nuke_all_device_slots): Use lrecord functions.
* device.c (allocate_device): Allocate as lrecord.
* dialog-msw.c (handle_question_dialog_box): Allocate as lrecord.
* elhash.c (struct Lisp_Hash_Table): Add lrecord_header.
* elhash.c (make_general_lisp_hash_table): Allocate as lrecord.
* elhash.c (Fcopy_hash_table): Allocate as lrecord.
* event-stream.c: Lcrecord lists Vcommand_builder_free_list and
Vtimeout_free_list are no longer needed. Remove.
* event-stream.c (allocate_command_builder): Allocate as lrecord.
* event-stream.c (free_command_builder): Use lrecord functions.
* event-stream.c (event_stream_generate_wakeup): Allocate as
lrecord.
* event-stream.c (event_stream_resignal_wakeup): Use lrecord
functions.
* event-stream.c (event_stream_disable_wakeup): Use lrecord
functions.
* event-stream.c (reinit_vars_of_event_stream): Lcrecord lists
remove.
* events.h (struct Lisp_Timeout): Add lrecord_header.
* events.h (struct command_builder): Add lrecord_header.
* extents-impl.h (struct extent_auxiliary): Add lrecord_header.
* extents-impl.h (struct extent_info): Add lrecord_header.
* extents.c (allocate_extent_auxiliary): Allocate as lrecord.
* extents.c (allocate_extent_info): Allocate as lrecord.
* extents.c (copy_extent): Allocate as lrecord.
* faces.c (allocate_face): Allocate as lrecord.
* faces.h (struct Lisp_Face): Add lrecord_header.
* file-coding.c (allocate_coding_system): Allocate as lrecord.
* file-coding.c (Fcopy_coding_system): Allocate as lrecord.
* file-coding.h (struct Lisp_Coding_System): Add lrecord_header.
* fns.c (Ffillarray): Allocate as lrecord.
* frame-impl.h (struct frame): Add lrecord_header.
* frame.c (nuke_all_frame_slots): Use lrecord functions.
* frame.c (allocate_frame_core): Allocate as lrecord.
* glyphs.c (allocate_image_instance): Allocate as lrecord.
* glyphs.c (Fcolorize_image_instance): Allocate as lrecord.
* glyphs.c (allocate_glyph): Allocate as lrecord.
* glyphs.h (struct Lisp_Image_Instance): Add lrecord_header.
* glyphs.h (struct Lisp_Glyph): Add lrecord_header.
* gui.c (allocate_gui_item): Allocate as lrecord.
* gui.h (struct Lisp_Gui_Item): Add lrecord_header.
* keymap.c (struct Lisp_Keymap): Add lrecord_header.
* keymap.c (make_keymap): Allocate as lrecord.
* lisp.h (struct Lisp_Vector): Add lrecord_header.
* lisp.h (struct Lisp_Bit_Vector): Add lrecord_header.
* lisp.h (struct weak_box): Add lrecord_header.
* lisp.h (struct ephemeron): Add lrecord_header.
* lisp.h (struct weak_list): Add lrecord_header.
* lrecord.h (struct lcrecord_header): Not used, remove.
* lrecord.h (struct free_lcrecord_header): Not used, remove.
* lrecord.h (struct lcrecord_list): Not needed anymore, remove.
* lrecord.h (lcrecord_list): Not needed anymore, remove.
* lrecord.h: (enum data_description_entry_flags): Remove
XD_FLAG_FREE_LISP_OBJECT.
* lstream.c: Lrecord list Vlstream_free_list remove.
* lstream.c (Lstream_new): Allocate as lrecord.
* lstream.c (Lstream_delete): Use lrecod functions.
* lstream.c (reinit_vars_of_lstream): Vlstream_free_list
initialization remove.
* lstream.h (struct lstream): Add lrecord_header.
* emacs.c (main_1): Remove lstream initialization.
* mule-charset.c (make_charset): Allocate as lrecord.
* objects-impl.h (struct Lisp_Color_Instance): Add
lrecord_header.
* objects-impl.h (struct Lisp_Font_Instance): Add lrecord_header.
* objects.c (Fmake_color_instance): Allocate as lrecord.
* objects.c (Fmake_font_instance): Allocate as lrecord.
* objects.c (reinit_vars_of_objects): Allocate as lrecord.
* opaque.c: Lcreord list Vopaque_ptr_list remove.
* opaque.c (make_opaque): Allocate as lrecord.
* opaque.c (make_opaque_ptr): Allocate as lrecord.
* opaque.c (free_opaque_ptr): Use lrecord functions.
* opaque.c (reinit_opaque_early):
* opaque.c (init_opaque_once_early): Vopaque_ptr_list
initialization remove.
* opaque.h (Lisp_Opaque): Add lrecord_header.
* opaque.h (Lisp_Opaque_Ptr): Add lrecord_header.
* emacs.c (main_1): Remove opaque variable initialization.
* print.c (default_object_printer): Use new lrecord_header.
* print.c (print_internal): Use new lrecord_header.
* print.c (debug_p4): Use new lrecord_header.
* process.c (make_process_internal): Allocate as lrecord.
* procimpl.h (struct Lisp_Process): Add lrecord_header.
* rangetab.c (Fmake_range_table): Allocate as lrecord.
* rangetab.c (Fcopy_range_table): Allocate as lrecord.
* rangetab.h (struct Lisp_Range_Table): Add lrecord_header.
* scrollbar.c (create_scrollbar_instance): Allocate as lrecord.
* scrollbar.h (struct scrollbar_instance): Add lrecord_header.
* specifier.c (make_specifier_internal): Allocate as lrecord.
* specifier.h (struct Lisp_Specifier): Add lrecord_header.
* symbols.c:
* symbols.c (Fmake_variable_buffer_local): Allocate as lrecord.
* symbols.c (Fdontusethis_set_symbol_value_handler): Allocate
as lrecord.
* symbols.c (Fdefvaralias): Allocate as lrecord.
* symeval.h (struct symbol_value_magic): Add lrecord_header.
* toolbar.c (update_toolbar_button): Allocate as lrecord.
* toolbar.h (struct toolbar_button): Add lrecord_header.
* tooltalk.c (struct Lisp_Tooltalk_Message): Add lrecord_header.
* tooltalk.c (make_tooltalk_message): Allocate as lrecord.
* tooltalk.c (struct Lisp_Tooltalk_Pattern): Add lrecord_header.
* tooltalk.c (make_tooltalk_pattern): Allocate as lrecord.
* ui-gtk.c (allocate_ffi_data): Allocate as lrecord.
* ui-gtk.c (allocate_emacs_gtk_object_data): Allocate as lrecord.
* ui-gtk.c (allocate_emacs_gtk_boxed_data): Allocate as lrecord.
* ui-gtk.h (structs): Add lrecord_header.
* window-impl.h (struct window): Add lrecord_header.
* window-impl.h (struct window_mirror): Add lrecord_header.
* window.c (allocate_window): Allocate as lrecord.
* window.c (new_window_mirror): Allocate as lrecord.
* window.c (make_dummy_parent): Allocate as lrecord.
MEMORY_USAGE_STATS
* alloc.c (fixed_type_block_overhead): Not used anymore, remove.
* buffer.c (compute_buffer_usage): Get storage size from new
allocator.
* marker.c (compute_buffer_marker_usage): Get storage size from
new allocator.
* mule-charset.c (compute_charset_usage): Get storage size from
new allocator.
* scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): Get
storage size from new allocator.
* scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage):
Get storage size from new allocator.
* scrollbar-x.c (x_compute_scrollbar_instance_usage): Get
storage size from new allocator.
* scrollbar.c (compute_scrollbar_instance_usage): Get storage
size from new allocator.
* unicode.c (compute_from_unicode_table_size_1): Get storage
size from new allocator.
* unicode.c (compute_to_unicode_table_size_1): Get storage size
from new allocator.
* window.c (compute_window_mirror_usage): Get storage size from
new allocator.
* window.c (compute_window_usage): Get storage size from new
allocator.
MC_ALLOC_TYPE_STATS:
* alloc.c (alloc_lrecord): Bump lrecord count.
* alloc.c (noseeum_alloc_lrecord): Bump lrecord count.
* alloc.c (struct lrecord_stats): Storage for counts.
* alloc.c (init_lrecord_stats): Zero statistics.
* alloc.c (inc_lrecord_stats): Increase the statistic.
* alloc.c (dec_lrecord_stats): Decrease the statistic.
* alloc.c (gc_plist_hack): Used to print the information.
* alloc.c (Fgarbage_collect): Return the collected information.
* mc-alloc.c (remove_cell): Decrease lrecord count.
* mc-alloc.h: Set flag MC_ALLOC_TYPE_STATS.
* emacs.c (main_1): Init lrecord statistics.
* lrecord.h: Add prototypes for *_lrecord_stats.
Strings:
* alloc.c (Fmake_string): Initialize ascii_begin to zero.
* alloc.c (gc_count_num_short_string_in_use): Remove.
* alloc.c (gc_count_string_total_size): Remove.
* alloc.c (gc_count_short_string_total_size): Remove.
* alloc.c (debug_string_purity): Remove.
* alloc.c (debug_string_purity_print): Remove.
* alloc.c (sweep_strings): Remove.
Remove static C-readonly Lisp objects:
* alloc.c (c_readonly): Not needed anymore, remove.
* alloc.c (GC_CHECK_LHEADER_INVARIANTS): Remove some obsolete
lheader invariants assertions.
* buffer.c (DEFVAR_BUFFER_LOCAL_1): Allocate dynamically.
* console.c (DEFVAR_CONSOLE_LOCAL_1): Allocate dynamically.
* gpmevent.c: Indirection via MC_ALLOC_Freceive_gpm_event.
* gpmevent.c (Fgpm_enable): Allocate dynamically.
* gpmevent.c (syms_of_gpmevent): Allocate dynamically.
* lisp.h (C_READONLY): Not needed anymore, remove.
* lisp.h (DEFUN): Allocate dynamically.
* lrecord.h (C_READONLY_RECORD_HEADER_P): Not needed anymore,
remove.
* lrecord.h (SET_C_READONLY_RECORD_HEADER): Not needed anymore,
remove.
* symbols.c (guts_of_unbound_marker):
* symeval.h (defsubr): Allocate dynamically.
* symeval.h (DEFSUBR_MACRO): Allocate dynamically.
* symeval.h (DEFVAR_ SYMVAL_FWD): Allocate dynamically.
* tests.c (TESTS_DEFSUBR): Allocate dynamically.
Definition of mcpro:
* lisp.h: Add mcpro prototypes.
* alloc.c (common_init_alloc_early): Add initialization for
mcpros.
* alloc.c (mcpro_description_1): New.
* alloc.c (mcpro_description): New.
* alloc.c (mcpros_description_1): New.
* alloc.c (mcpros_description): New.
* alloc.c (mcpro_one_name_description_1): New.
* alloc.c (mcpro_one_name_description): New.
* alloc.c (mcpro_names_description_1): New.
* alloc.c (mcpro_names_description): New.
* alloc.c (mcpros): New.
* alloc.c (mcpro_names): New.
* alloc.c (mcpro_1): New.
* alloc.c (mc_pro): New.
* alloc.c (garbage_collect_1): Add mcpros to root set.
Usage of mcpro:
* alloc.c (make_string_nocopy): Add string to root set.
* symbols.c (init_symbols_once_early): Add Qunbound to root set.
Changes to the Portable Dumper:
* alloc.c (FREE_OR_REALLOC_BEGIN): Since dumped objects can be
freed with the new allocator, remove assertion for !DUMPEDP.
* dumper.c: Adjust comments, increase PDUMP_HASHSIZE.
* dumper.c (pdump_make_hash): Shift address only 2 bytes, to
avoid collisions.
* dumper.c (pdump_objects_unmark): No more mark bits within
the object, remove.
* dumper.c (mc_addr_elt): New. Element data structure for mc
hash table.
* dumper.c (pdump_mc_hash): New hash table: `lookup table'.
* dumper.c (pdump_get_mc_addr): New. Lookup for hash table.
* dumper.c (pdump_get_indirect_mc_addr): New. Lookup for
convertibles.
* dumper.c (pdump_put_mc_addr): New. Putter for hash table.
* dumper.c (pdump_dump_mc_data): New. Writes the table for
relocation at load time to the dump file.
* dumper.c (pdump_scan_lisp_objects_by_alignment): New.
Visits all dumped Lisp objects.
* dumper.c (pdump_scan_non_lisp_objects_by_alignment): New.
Visits all other dumped objects.
* dumper.c (pdump_reloc_one_mc): New. Updates all pointers
of an object by using the hash table pdump_mc_hash.
* dumper.c (pdump_reloc_one): Replaced by pdump_reloc_one_mc.
* dumper.c (pdump): Change the structure of the dump file, add
the mc post dump relocation table to dump file.
* dumper.c (pdump_load_finish): Hand all dumped objects to the
new allocator and use the mc post dump relocation table for
relocating the dumped objects at dump file load time, free not
longer used data structures.
* dumper.c (pdump_load): Free the dump file.
* dumper.h: Remove pdump_objects_unmark.
* lrecord.h (DUMPEDP): Dumped objects can be freed, remove.
DUMP_IN_EXEC:
* Makefile.in.in: Linking for and with dump in executable only if
DUMP_IN_EXEC is defined.
* config.h.in: Add new flag `DUMP_IN_EXEC'
* emacs.c: Condition dump-data.h on DUMP_IN_EXEC.
* emacs.c (main_1): Flag `-si' only works if dump image is
written into executable.
Miscellanious
* lrecord.h (enum lrecord_type): Added numbers to all types,
very handy for debugging.
* xemacs.def.in.in: Add mc-alloc functions to make them visible
to the modules.
| author | crestani |
|---|---|
| date | Fri, 08 Apr 2005 23:11:35 +0000 |
| parents | 7bf1f40e6acb |
| children | 05d62157e048 |
| 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. | |
| 2367 | 4 Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004 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" |
| 428 | 55 #include "glyphs.h" |
| 56 #include "opaque.h" | |
| 1204 | 57 #include "lstream.h" |
| 872 | 58 #include "process.h" |
| 1292 | 59 #include "profile.h" |
| 428 | 60 #include "redisplay.h" |
| 61 #include "specifier.h" | |
| 62 #include "sysfile.h" | |
| 442 | 63 #include "sysdep.h" |
| 428 | 64 #include "window.h" |
| 65 #include "console-stream.h" | |
| 66 | |
| 67 #ifdef DOUG_LEA_MALLOC | |
| 68 #include <malloc.h> | |
| 69 #endif | |
| 70 | |
| 71 EXFUN (Fgarbage_collect, 0); | |
| 72 | |
| 814 | 73 static void recompute_need_to_garbage_collect (void); |
| 74 | |
| 428 | 75 #if 0 /* this is _way_ too slow to be part of the standard debug options */ |
| 76 #if defined(DEBUG_XEMACS) && defined(MULE) | |
| 77 #define VERIFY_STRING_CHARS_INTEGRITY | |
| 78 #endif | |
| 79 #endif | |
| 80 | |
| 81 /* Define this to use malloc/free with no freelist for all datatypes, | |
| 82 the hope being that some debugging tools may help detect | |
| 83 freed memory references */ | |
| 84 #ifdef USE_DEBUG_MALLOC /* Taking the above comment at face value -slb */ | |
| 85 #include <dmalloc.h> | |
| 86 #define ALLOC_NO_POOLS | |
| 87 #endif | |
| 88 | |
| 89 #ifdef DEBUG_XEMACS | |
| 458 | 90 static Fixnum debug_allocation; |
| 91 static Fixnum debug_allocation_backtrace_length; | |
| 428 | 92 #endif |
| 93 | |
| 94 /* Number of bytes of consing done since the last gc */ | |
| 814 | 95 static EMACS_INT consing_since_gc; |
| 1292 | 96 EMACS_UINT total_consing; |
| 97 | |
| 814 | 98 int need_to_garbage_collect; |
| 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 | |
| 150 #define DECREMENT_CONS_COUNTER(size) do { \ | |
| 151 consing_since_gc -= (size); \ | |
| 1292 | 152 total_consing -= (size); \ |
| 153 if (profiling_active) \ | |
| 154 profile_record_unconsing (size); \ | |
| 428 | 155 if (consing_since_gc < 0) \ |
| 156 consing_since_gc = 0; \ | |
| 814 | 157 recompute_need_to_garbage_collect (); \ |
| 428 | 158 } while (0) |
| 159 | |
| 160 /* Number of bytes of consing since gc before another gc should be done. */ | |
| 801 | 161 static EMACS_INT gc_cons_threshold; |
| 162 | |
| 163 /* Percentage of consing of total data size before another GC. */ | |
| 164 static EMACS_INT gc_cons_percentage; | |
| 165 | |
| 166 #ifdef ERROR_CHECK_GC | |
| 853 | 167 int always_gc; /* Debugging hack; equivalent to |
| 168 (setq gc-cons-thresold -1) */ | |
| 801 | 169 #else |
| 170 #define always_gc 0 | |
| 171 #endif | |
| 428 | 172 |
| 173 /* Nonzero during gc */ | |
| 174 int gc_in_progress; | |
| 175 | |
| 1154 | 176 /* Nonzero means display messages at beginning and end of GC. */ |
| 177 | |
| 178 int garbage_collection_messages; | |
| 179 | |
| 428 | 180 /* Number of times GC has happened at this level or below. |
| 181 * Level 0 is most volatile, contrary to usual convention. | |
| 182 * (Of course, there's only one level at present) */ | |
| 183 EMACS_INT gc_generation_number[1]; | |
| 184 | |
| 185 /* This is just for use by the printer, to allow things to print uniquely */ | |
| 186 static int lrecord_uid_counter; | |
| 187 | |
| 188 /* Nonzero when calling certain hooks or doing other things where | |
| 189 a GC would be bad */ | |
| 1957 | 190 int gc_currently_forbidden; |
| 428 | 191 |
| 192 /* Hooks. */ | |
| 193 Lisp_Object Vpre_gc_hook, Qpre_gc_hook; | |
| 194 Lisp_Object Vpost_gc_hook, Qpost_gc_hook; | |
| 195 | |
| 196 /* "Garbage collecting" */ | |
| 197 Lisp_Object Vgc_message; | |
| 198 Lisp_Object Vgc_pointer_glyph; | |
| 2367 | 199 static const Ascbyte gc_default_message[] = "Garbage collecting"; |
| 428 | 200 Lisp_Object Qgarbage_collecting; |
| 201 | |
| 1292 | 202 static Lisp_Object QSin_garbage_collection; |
| 203 | |
| 428 | 204 /* Non-zero means we're in the process of doing the dump */ |
| 205 int purify_flag; | |
| 206 | |
| 1204 | 207 /* Non-zero means we're pdumping out or in */ |
| 208 #ifdef PDUMP | |
| 209 int in_pdump; | |
| 210 #endif | |
| 211 | |
| 800 | 212 #ifdef ERROR_CHECK_TYPES |
| 428 | 213 |
| 793 | 214 Error_Behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN, ERROR_ME_DEBUG_WARN; |
| 428 | 215 |
| 216 #endif | |
| 217 | |
| 801 | 218 /* Very cheesy ways of figuring out how much memory is being used for |
| 219 data. #### Need better (system-dependent) ways. */ | |
| 220 void *minimum_address_seen; | |
| 221 void *maximum_address_seen; | |
| 222 | |
| 2720 | 223 #ifndef MC_ALLOC |
| 428 | 224 int |
| 225 c_readonly (Lisp_Object obj) | |
| 226 { | |
| 227 return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj); | |
| 228 } | |
| 2720 | 229 #endif /* MC_ALLOC */ |
| 428 | 230 |
| 231 int | |
| 232 lisp_readonly (Lisp_Object obj) | |
| 233 { | |
| 234 return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj); | |
| 235 } | |
| 236 | |
| 237 | |
| 238 /* Maximum amount of C stack to save when a GC happens. */ | |
| 239 | |
| 240 #ifndef MAX_SAVE_STACK | |
| 241 #define MAX_SAVE_STACK 0 /* 16000 */ | |
| 242 #endif | |
| 243 | |
| 244 /* Non-zero means ignore malloc warnings. Set during initialization. */ | |
| 245 int ignore_malloc_warnings; | |
| 246 | |
| 247 | |
| 2720 | 248 #ifndef MC_ALLOC |
| 428 | 249 static void *breathing_space; |
| 250 | |
| 251 void | |
| 252 release_breathing_space (void) | |
| 253 { | |
| 254 if (breathing_space) | |
| 255 { | |
| 256 void *tmp = breathing_space; | |
| 257 breathing_space = 0; | |
| 1726 | 258 xfree (tmp, void *); |
| 428 | 259 } |
| 260 } | |
| 2720 | 261 #endif /* not MC_ALLOC */ |
| 428 | 262 |
| 263 /* malloc calls this if it finds we are near exhausting storage */ | |
| 264 void | |
| 442 | 265 malloc_warning (const char *str) |
| 428 | 266 { |
| 267 if (ignore_malloc_warnings) | |
| 268 return; | |
| 269 | |
| 270 warn_when_safe | |
| 793 | 271 (Qmemory, Qemergency, |
| 428 | 272 "%s\n" |
| 273 "Killing some buffers may delay running out of memory.\n" | |
| 274 "However, certainly by the time you receive the 95%% warning,\n" | |
| 275 "you should clean up, kill this Emacs, and start a new one.", | |
| 276 str); | |
| 277 } | |
| 278 | |
| 279 /* Called if malloc returns zero */ | |
| 280 DOESNT_RETURN | |
| 281 memory_full (void) | |
| 282 { | |
| 283 /* Force a GC next time eval is called. | |
| 284 It's better to loop garbage-collecting (we might reclaim enough | |
| 285 to win) than to loop beeping and barfing "Memory exhausted" | |
| 286 */ | |
| 287 consing_since_gc = gc_cons_threshold + 1; | |
| 814 | 288 recompute_need_to_garbage_collect (); |
| 2720 | 289 #ifndef MC_ALLOC |
| 428 | 290 release_breathing_space (); |
| 2720 | 291 #endif /* not MC_ALLOC */ |
| 428 | 292 |
| 293 /* Flush some histories which might conceivably contain garbalogical | |
| 294 inhibitors. */ | |
| 295 if (!NILP (Fboundp (Qvalues))) | |
| 296 Fset (Qvalues, Qnil); | |
| 297 Vcommand_history = Qnil; | |
| 298 | |
| 563 | 299 out_of_memory ("Memory exhausted", Qunbound); |
| 428 | 300 } |
| 301 | |
| 801 | 302 static void |
| 303 set_alloc_mins_and_maxes (void *val, Bytecount size) | |
| 304 { | |
| 305 if (!val) | |
| 306 return; | |
| 307 if ((char *) val + size > (char *) maximum_address_seen) | |
| 308 maximum_address_seen = (char *) val + size; | |
| 309 if (!minimum_address_seen) | |
| 310 minimum_address_seen = | |
| 311 #if SIZEOF_VOID_P == 8 | |
| 312 (void *) 0xFFFFFFFFFFFFFFFF; | |
| 313 #else | |
| 314 (void *) 0xFFFFFFFF; | |
| 315 #endif | |
| 316 if ((char *) val < (char *) minimum_address_seen) | |
| 317 minimum_address_seen = (char *) val; | |
| 318 } | |
| 319 | |
| 1315 | 320 #ifdef ERROR_CHECK_MALLOC |
| 1292 | 321 static int in_malloc; |
| 1333 | 322 extern int regex_malloc_disallowed; |
| 2367 | 323 |
| 324 #define MALLOC_BEGIN() \ | |
| 325 do \ | |
| 326 { \ | |
| 327 assert (!in_malloc); \ | |
| 328 assert (!regex_malloc_disallowed); \ | |
| 329 in_malloc = 1; \ | |
| 330 } \ | |
| 331 while (0) | |
| 332 | |
| 2720 | 333 #ifdef MC_ALLOC |
| 334 #define FREE_OR_REALLOC_BEGIN(block) \ | |
| 335 do \ | |
| 336 { \ | |
| 337 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
| 338 error until much later on for many system mallocs, such as \ | |
| 339 the one that comes with Solaris 2.3. FMH!! */ \ | |
| 340 assert (block != (void *) 0xDEADBEEF); \ | |
| 341 MALLOC_BEGIN (); \ | |
| 342 } \ | |
| 343 while (0) | |
| 344 #else /* not MC_ALLOC */ | |
| 2367 | 345 #define FREE_OR_REALLOC_BEGIN(block) \ |
| 346 do \ | |
| 347 { \ | |
| 348 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an \ | |
| 349 error until much later on for many system mallocs, such as \ | |
| 350 the one that comes with Solaris 2.3. FMH!! */ \ | |
| 351 assert (block != (void *) 0xDEADBEEF); \ | |
| 352 /* You cannot free something within dumped space, because there is \ | |
| 353 no longer any sort of malloc structure associated with the block. \ | |
| 354 If you are tripping this, you may need to conditionalize on \ | |
| 355 DUMPEDP. */ \ | |
| 356 assert (!DUMPEDP (block)); \ | |
| 357 MALLOC_BEGIN (); \ | |
| 358 } \ | |
| 359 while (0) | |
| 2720 | 360 #endif /* not MC_ALLOC */ |
| 2367 | 361 |
| 362 #define MALLOC_END() \ | |
| 363 do \ | |
| 364 { \ | |
| 365 in_malloc = 0; \ | |
| 366 } \ | |
| 367 while (0) | |
| 368 | |
| 369 #else /* ERROR_CHECK_MALLOC */ | |
| 370 | |
| 2658 | 371 #define MALLOC_BEGIN() |
| 2367 | 372 #define FREE_OR_REALLOC_BEGIN(block) |
| 373 #define MALLOC_END() | |
| 374 | |
| 375 #endif /* ERROR_CHECK_MALLOC */ | |
| 376 | |
| 377 static void | |
| 378 malloc_after (void *val, Bytecount size) | |
| 379 { | |
| 380 if (!val && size != 0) | |
| 381 memory_full (); | |
| 382 set_alloc_mins_and_maxes (val, size); | |
| 383 } | |
| 384 | |
| 385 /* like malloc, calloc, realloc, free but: | |
| 386 | |
| 387 -- check for no memory left | |
| 388 -- set internal mins and maxes | |
| 389 -- with error-checking on, check for reentrancy, invalid freeing, etc. | |
| 390 */ | |
| 1292 | 391 |
| 428 | 392 #undef xmalloc |
| 393 void * | |
| 665 | 394 xmalloc (Bytecount size) |
| 428 | 395 { |
| 1292 | 396 void *val; |
| 2367 | 397 MALLOC_BEGIN (); |
| 1292 | 398 val = malloc (size); |
| 2367 | 399 MALLOC_END (); |
| 400 malloc_after (val, size); | |
| 428 | 401 return val; |
| 402 } | |
| 403 | |
| 404 #undef xcalloc | |
| 405 static void * | |
| 665 | 406 xcalloc (Elemcount nelem, Bytecount elsize) |
| 428 | 407 { |
| 1292 | 408 void *val; |
| 2367 | 409 MALLOC_BEGIN (); |
| 1292 | 410 val= calloc (nelem, elsize); |
| 2367 | 411 MALLOC_END (); |
| 412 malloc_after (val, nelem * elsize); | |
| 428 | 413 return val; |
| 414 } | |
| 415 | |
| 416 void * | |
| 665 | 417 xmalloc_and_zero (Bytecount size) |
| 428 | 418 { |
| 419 return xcalloc (size, sizeof (char)); | |
| 420 } | |
| 421 | |
| 422 #undef xrealloc | |
| 423 void * | |
| 665 | 424 xrealloc (void *block, Bytecount size) |
| 428 | 425 { |
| 2367 | 426 FREE_OR_REALLOC_BEGIN (block); |
| 551 | 427 block = realloc (block, size); |
| 2367 | 428 MALLOC_END (); |
| 429 malloc_after (block, size); | |
| 551 | 430 return block; |
| 428 | 431 } |
| 432 | |
| 433 void | |
| 434 xfree_1 (void *block) | |
| 435 { | |
| 436 #ifdef ERROR_CHECK_MALLOC | |
| 437 assert (block); | |
| 438 #endif /* ERROR_CHECK_MALLOC */ | |
| 2367 | 439 FREE_OR_REALLOC_BEGIN (block); |
| 428 | 440 free (block); |
| 2367 | 441 MALLOC_END (); |
| 428 | 442 } |
| 443 | |
| 444 #ifdef ERROR_CHECK_GC | |
| 445 | |
| 2720 | 446 #ifndef MC_ALLOC |
| 428 | 447 static void |
| 665 | 448 deadbeef_memory (void *ptr, Bytecount size) |
| 428 | 449 { |
| 826 | 450 UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr; |
| 665 | 451 Bytecount beefs = size >> 2; |
| 428 | 452 |
| 453 /* In practice, size will always be a multiple of four. */ | |
| 454 while (beefs--) | |
| 1204 | 455 (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */ |
| 428 | 456 } |
| 2720 | 457 #endif /* not MC_ALLOC */ |
| 428 | 458 |
| 459 #else /* !ERROR_CHECK_GC */ | |
| 460 | |
| 461 | |
| 462 #define deadbeef_memory(ptr, size) | |
| 463 | |
| 464 #endif /* !ERROR_CHECK_GC */ | |
| 465 | |
| 466 #undef xstrdup | |
| 467 char * | |
| 442 | 468 xstrdup (const char *str) |
| 428 | 469 { |
| 470 int len = strlen (str) + 1; /* for stupid terminating 0 */ | |
| 471 void *val = xmalloc (len); | |
| 771 | 472 |
| 428 | 473 if (val == 0) return 0; |
| 474 return (char *) memcpy (val, str, len); | |
| 475 } | |
| 476 | |
| 477 #ifdef NEED_STRDUP | |
| 478 char * | |
| 442 | 479 strdup (const char *s) |
| 428 | 480 { |
| 481 return xstrdup (s); | |
| 482 } | |
| 483 #endif /* NEED_STRDUP */ | |
| 484 | |
| 485 | |
| 2720 | 486 #ifndef MC_ALLOC |
| 428 | 487 static void * |
| 665 | 488 allocate_lisp_storage (Bytecount size) |
| 428 | 489 { |
| 793 | 490 void *val = xmalloc (size); |
| 491 /* We don't increment the cons counter anymore. Calling functions do | |
| 492 that now because we have two different kinds of cons counters -- one | |
| 493 for normal objects, and one for no-see-um conses (and possibly others | |
| 494 similar) where the conses are used totally internally, never escape, | |
| 495 and are created and then freed and shouldn't logically increment the | |
| 496 cons counting. #### (Or perhaps, we should decrement it when an object | |
| 497 get freed?) */ | |
| 498 | |
| 499 /* But we do now (as of 3-27-02) go and zero out the memory. This is a | |
| 500 good thing, as it will guarantee we won't get any intermittent bugs | |
| 1204 | 501 coming from an uninitiated field. The speed loss is unnoticeable, |
| 502 esp. as the objects are not large -- large stuff like buffer text and | |
| 503 redisplay structures are allocated separately. */ | |
| 793 | 504 memset (val, 0, size); |
| 851 | 505 |
| 506 if (need_to_check_c_alloca) | |
| 507 xemacs_c_alloca (0); | |
| 508 | |
| 793 | 509 return val; |
| 428 | 510 } |
| 2720 | 511 #endif /* not MC_ALLOC */ |
| 512 | |
| 513 #ifdef MC_ALLOC_TYPE_STATS | |
| 514 static struct | |
| 515 { | |
| 516 int instances_in_use; | |
| 517 int bytes_in_use; | |
| 518 int bytes_in_use_including_overhead; | |
| 519 } lrecord_stats [countof (lrecord_implementations_table) | |
| 520 + MODULE_DEFINABLE_TYPE_COUNT]; | |
| 521 | |
| 522 void | |
| 523 init_lrecord_stats () | |
| 524 { | |
| 525 xzero (lrecord_stats); | |
| 526 } | |
| 527 | |
| 528 void | |
| 529 inc_lrecord_stats (Bytecount size, const struct lrecord_header *h) | |
| 530 { | |
| 531 int type_index = h->type; | |
| 532 if (!size) | |
| 533 size = detagged_lisp_object_size (h); | |
| 534 | |
| 535 lrecord_stats[type_index].instances_in_use++; | |
| 536 lrecord_stats[type_index].bytes_in_use += size; | |
| 537 lrecord_stats[type_index].bytes_in_use_including_overhead | |
| 538 #ifdef MEMORY_USAGE_STATS | |
| 539 += mc_alloced_storage_size (size, 0); | |
| 540 #else /* not MEMORY_USAGE_STATS */ | |
| 541 += size; | |
| 542 #endif /* not MEMORY_USAGE_STATS */ | |
| 543 } | |
| 544 | |
| 545 void | |
| 546 dec_lrecord_stats (Bytecount size_including_overhead, | |
| 547 const struct lrecord_header *h) | |
| 548 { | |
| 549 int type_index = h->type; | |
| 550 | |
| 551 lrecord_stats[type_index].instances_in_use--; | |
| 552 lrecord_stats[type_index].bytes_in_use -= detagged_lisp_object_size (h); | |
| 553 lrecord_stats[type_index].bytes_in_use_including_overhead | |
| 554 -= size_including_overhead; | |
| 555 | |
| 556 DECREMENT_CONS_COUNTER (lrecord_stats[type_index].bytes_in_use); | |
| 557 } | |
| 558 #endif /* not MC_ALLOC_TYPE_STATS */ | |
| 559 | |
| 560 #ifndef MC_ALLOC | |
| 442 | 561 /* lcrecords are chained together through their "next" field. |
| 562 After doing the mark phase, GC will walk this linked list | |
| 563 and free any lcrecord which hasn't been marked. */ | |
| 428 | 564 static struct lcrecord_header *all_lcrecords; |
| 2720 | 565 #endif /* not MC_ALLOC */ |
| 566 | |
| 567 #ifdef MC_ALLOC | |
| 568 /* The basic lrecord allocation functions. See lrecord.h for details. */ | |
| 569 void * | |
| 570 alloc_lrecord (Bytecount size, | |
| 571 const struct lrecord_implementation *implementation) | |
| 572 { | |
| 573 struct lrecord_header *lheader; | |
| 574 | |
| 575 type_checking_assert | |
| 576 ((implementation->static_size == 0 ? | |
| 577 implementation->size_in_bytes_method != NULL : | |
| 578 implementation->static_size == size)); | |
| 579 | |
| 580 lheader = (struct lrecord_header *) mc_alloc (size); | |
| 581 gc_checking_assert (LRECORD_FREE_P (lheader)); | |
| 582 set_lheader_implementation (lheader, implementation); | |
| 583 lheader->uid = lrecord_uid_counter++; | |
| 584 #ifdef MC_ALLOC_TYPE_STATS | |
| 585 inc_lrecord_stats (size, lheader); | |
| 586 #endif /* not MC_ALLOC_TYPE_STATS */ | |
| 587 INCREMENT_CONS_COUNTER (size, implementation->name); | |
| 588 return lheader; | |
| 589 } | |
| 590 | |
| 591 void * | |
| 592 noseeum_alloc_lrecord (Bytecount size, | |
| 593 const struct lrecord_implementation *implementation) | |
| 594 { | |
| 595 struct lrecord_header *lheader; | |
| 596 | |
| 597 type_checking_assert | |
| 598 ((implementation->static_size == 0 ? | |
| 599 implementation->size_in_bytes_method != NULL : | |
| 600 implementation->static_size == size)); | |
| 601 | |
| 602 lheader = (struct lrecord_header *) mc_alloc (size); | |
| 603 gc_checking_assert (LRECORD_FREE_P (lheader)); | |
| 604 set_lheader_implementation (lheader, implementation); | |
| 605 lheader->uid = lrecord_uid_counter++; | |
| 606 #ifdef MC_ALLOC_TYPE_STATS | |
| 607 inc_lrecord_stats (size, lheader); | |
| 608 #endif /* not MC_ALLOC_TYPE_STATS */ | |
| 609 NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name); | |
| 610 return lheader; | |
| 611 } | |
| 612 | |
| 613 void | |
| 614 free_lrecord (Lisp_Object lrecord) | |
| 615 { | |
| 616 gc_checking_assert (!gc_in_progress); | |
| 617 gc_checking_assert (!LRECORD_FREE_P (XRECORD_LHEADER (lrecord))); | |
| 618 gc_checking_assert (!XRECORD_LHEADER (lrecord)->free); | |
| 619 | |
| 620 MC_ALLOC_CALL_FINALIZER (XPNTR (lrecord)); | |
| 621 mc_free (XPNTR (lrecord)); | |
| 622 } | |
| 623 #else /* not MC_ALLOC */ | |
| 428 | 624 |
| 1204 | 625 /* The most basic of the lcrecord allocation functions. Not usually called |
| 626 directly. Allocates an lrecord not managed by any lcrecord-list, of a | |
| 627 specified size. See lrecord.h. */ | |
| 628 | |
| 428 | 629 void * |
| 1204 | 630 basic_alloc_lcrecord (Bytecount size, |
| 631 const struct lrecord_implementation *implementation) | |
| 428 | 632 { |
| 633 struct lcrecord_header *lcheader; | |
| 634 | |
| 442 | 635 type_checking_assert |
| 636 ((implementation->static_size == 0 ? | |
| 637 implementation->size_in_bytes_method != NULL : | |
| 638 implementation->static_size == size) | |
| 639 && | |
| 640 (! implementation->basic_p) | |
| 641 && | |
| 642 (! (implementation->hash == NULL && implementation->equal != NULL))); | |
| 428 | 643 |
| 644 lcheader = (struct lcrecord_header *) allocate_lisp_storage (size); | |
| 442 | 645 set_lheader_implementation (&lcheader->lheader, implementation); |
| 428 | 646 lcheader->next = all_lcrecords; |
| 647 #if 1 /* mly prefers to see small ID numbers */ | |
| 648 lcheader->uid = lrecord_uid_counter++; | |
| 649 #else /* jwz prefers to see real addrs */ | |
| 650 lcheader->uid = (int) &lcheader; | |
| 651 #endif | |
| 652 lcheader->free = 0; | |
| 653 all_lcrecords = lcheader; | |
| 654 INCREMENT_CONS_COUNTER (size, implementation->name); | |
| 655 return lcheader; | |
| 656 } | |
| 657 | |
| 658 #if 0 /* Presently unused */ | |
| 659 /* Very, very poor man's EGC? | |
| 660 * This may be slow and thrash pages all over the place. | |
| 661 * Only call it if you really feel you must (and if the | |
| 662 * lrecord was fairly recently allocated). | |
| 663 * Otherwise, just let the GC do its job -- that's what it's there for | |
| 664 */ | |
| 665 void | |
| 771 | 666 very_old_free_lcrecord (struct lcrecord_header *lcrecord) |
| 428 | 667 { |
| 668 if (all_lcrecords == lcrecord) | |
| 669 { | |
| 670 all_lcrecords = lcrecord->next; | |
| 671 } | |
| 672 else | |
| 673 { | |
| 674 struct lrecord_header *header = all_lcrecords; | |
| 675 for (;;) | |
| 676 { | |
| 677 struct lrecord_header *next = header->next; | |
| 678 if (next == lcrecord) | |
| 679 { | |
| 680 header->next = lrecord->next; | |
| 681 break; | |
| 682 } | |
| 683 else if (next == 0) | |
| 2500 | 684 ABORT (); |
| 428 | 685 else |
| 686 header = next; | |
| 687 } | |
| 688 } | |
| 689 if (lrecord->implementation->finalizer) | |
| 690 lrecord->implementation->finalizer (lrecord, 0); | |
| 691 xfree (lrecord); | |
| 692 return; | |
| 693 } | |
| 694 #endif /* Unused */ | |
| 2720 | 695 #endif /* not MC_ALLOC */ |
| 428 | 696 |
| 697 | |
| 698 static void | |
| 699 disksave_object_finalization_1 (void) | |
| 700 { | |
| 2720 | 701 #ifdef MC_ALLOC |
| 702 mc_finalize_for_disksave (); | |
| 703 #else /* not MC_ALLOC */ | |
| 428 | 704 struct lcrecord_header *header; |
| 705 | |
| 706 for (header = all_lcrecords; header; header = header->next) | |
| 707 { | |
| 442 | 708 if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer && |
| 428 | 709 !header->free) |
| 442 | 710 LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1); |
| 428 | 711 } |
| 2720 | 712 #endif /* not MC_ALLOC */ |
| 428 | 713 } |
| 714 | |
| 1204 | 715 /* Bitwise copy all parts of a Lisp object other than the header */ |
| 716 | |
| 717 void | |
| 718 copy_lisp_object (Lisp_Object dst, Lisp_Object src) | |
| 719 { | |
| 720 const struct lrecord_implementation *imp = | |
| 721 XRECORD_LHEADER_IMPLEMENTATION (src); | |
| 722 Bytecount size = lisp_object_size (src); | |
| 723 | |
| 724 assert (imp == XRECORD_LHEADER_IMPLEMENTATION (dst)); | |
| 725 assert (size == lisp_object_size (dst)); | |
| 726 | |
| 2720 | 727 #ifdef MC_ALLOC |
| 728 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), | |
| 729 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
| 730 size - sizeof (struct lrecord_header)); | |
| 731 #else /* not MC_ALLOC */ | |
| 1204 | 732 if (imp->basic_p) |
| 733 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), | |
| 734 (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), | |
| 735 size - sizeof (struct lrecord_header)); | |
| 736 else | |
| 737 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lcrecord_header), | |
| 738 (char *) XRECORD_LHEADER (src) + sizeof (struct lcrecord_header), | |
| 739 size - sizeof (struct lcrecord_header)); | |
| 2720 | 740 #endif /* not MC_ALLOC */ |
| 1204 | 741 } |
| 742 | |
| 428 | 743 |
| 744 /************************************************************************/ | |
| 745 /* Debugger support */ | |
| 746 /************************************************************************/ | |
| 747 /* Give gdb/dbx enough information to decode Lisp Objects. We make | |
| 748 sure certain symbols are always defined, so gdb doesn't complain | |
| 438 | 749 about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc |
| 750 to see how this is used. */ | |
| 428 | 751 |
| 458 | 752 EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS; |
| 753 EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1; | |
| 428 | 754 |
| 755 #ifdef USE_UNION_TYPE | |
| 458 | 756 unsigned char dbg_USE_UNION_TYPE = 1; |
| 428 | 757 #else |
| 458 | 758 unsigned char dbg_USE_UNION_TYPE = 0; |
| 428 | 759 #endif |
| 760 | |
| 458 | 761 unsigned char dbg_valbits = VALBITS; |
| 762 unsigned char dbg_gctypebits = GCTYPEBITS; | |
| 763 | |
| 764 /* On some systems, the above definitions will be optimized away by | |
| 765 the compiler or linker unless they are referenced in some function. */ | |
| 766 long dbg_inhibit_dbg_symbol_deletion (void); | |
| 767 long | |
| 768 dbg_inhibit_dbg_symbol_deletion (void) | |
| 769 { | |
| 770 return | |
| 771 (dbg_valmask + | |
| 772 dbg_typemask + | |
| 773 dbg_USE_UNION_TYPE + | |
| 774 dbg_valbits + | |
| 775 dbg_gctypebits); | |
| 776 } | |
| 428 | 777 |
| 778 /* Macros turned into functions for ease of debugging. | |
| 779 Debuggers don't know about macros! */ | |
| 780 int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); | |
| 781 int | |
| 782 dbg_eq (Lisp_Object obj1, Lisp_Object obj2) | |
| 783 { | |
| 784 return EQ (obj1, obj2); | |
| 785 } | |
| 786 | |
| 787 | |
| 2720 | 788 #ifndef MC_ALLOC |
| 428 | 789 /************************************************************************/ |
| 790 /* Fixed-size type macros */ | |
| 791 /************************************************************************/ | |
| 792 | |
| 793 /* For fixed-size types that are commonly used, we malloc() large blocks | |
| 794 of memory at a time and subdivide them into chunks of the correct | |
| 795 size for an object of that type. This is more efficient than | |
| 796 malloc()ing each object separately because we save on malloc() time | |
| 797 and overhead due to the fewer number of malloc()ed blocks, and | |
| 798 also because we don't need any extra pointers within each object | |
| 799 to keep them threaded together for GC purposes. For less common | |
| 800 (and frequently large-size) types, we use lcrecords, which are | |
| 801 malloc()ed individually and chained together through a pointer | |
| 802 in the lcrecord header. lcrecords do not need to be fixed-size | |
| 803 (i.e. two objects of the same type need not have the same size; | |
| 804 however, the size of a particular object cannot vary dynamically). | |
| 805 It is also much easier to create a new lcrecord type because no | |
| 806 additional code needs to be added to alloc.c. Finally, lcrecords | |
| 807 may be more efficient when there are only a small number of them. | |
| 808 | |
| 809 The types that are stored in these large blocks (or "frob blocks") | |
| 1983 | 810 are cons, all number types except fixnum, compiled-function, symbol, |
| 811 marker, extent, event, and string. | |
| 428 | 812 |
| 813 Note that strings are special in that they are actually stored in | |
| 814 two parts: a structure containing information about the string, and | |
| 815 the actual data associated with the string. The former structure | |
| 816 (a struct Lisp_String) is a fixed-size structure and is managed the | |
| 817 same way as all the other such types. This structure contains a | |
| 818 pointer to the actual string data, which is stored in structures of | |
| 819 type struct string_chars_block. Each string_chars_block consists | |
| 820 of a pointer to a struct Lisp_String, followed by the data for that | |
| 440 | 821 string, followed by another pointer to a Lisp_String, followed by |
| 822 the data for that string, etc. At GC time, the data in these | |
| 823 blocks is compacted by searching sequentially through all the | |
| 428 | 824 blocks and compressing out any holes created by unmarked strings. |
| 825 Strings that are more than a certain size (bigger than the size of | |
| 826 a string_chars_block, although something like half as big might | |
| 827 make more sense) are malloc()ed separately and not stored in | |
| 828 string_chars_blocks. Furthermore, no one string stretches across | |
| 829 two string_chars_blocks. | |
| 830 | |
| 1204 | 831 Vectors are each malloc()ed separately as lcrecords. |
| 428 | 832 |
| 833 In the following discussion, we use conses, but it applies equally | |
| 834 well to the other fixed-size types. | |
| 835 | |
| 836 We store cons cells inside of cons_blocks, allocating a new | |
| 837 cons_block with malloc() whenever necessary. Cons cells reclaimed | |
| 838 by GC are put on a free list to be reallocated before allocating | |
| 839 any new cons cells from the latest cons_block. Each cons_block is | |
| 840 just under 2^n - MALLOC_OVERHEAD bytes long, since malloc (at least | |
| 841 the versions in malloc.c and gmalloc.c) really allocates in units | |
| 842 of powers of two and uses 4 bytes for its own overhead. | |
| 843 | |
| 844 What GC actually does is to search through all the cons_blocks, | |
| 845 from the most recently allocated to the oldest, and put all | |
| 846 cons cells that are not marked (whether or not they're already | |
| 847 free) on a cons_free_list. The cons_free_list is a stack, and | |
| 848 so the cons cells in the oldest-allocated cons_block end up | |
| 849 at the head of the stack and are the first to be reallocated. | |
| 850 If any cons_block is entirely free, it is freed with free() | |
| 851 and its cons cells removed from the cons_free_list. Because | |
| 852 the cons_free_list ends up basically in memory order, we have | |
| 853 a high locality of reference (assuming a reasonable turnover | |
| 854 of allocating and freeing) and have a reasonable probability | |
| 855 of entirely freeing up cons_blocks that have been more recently | |
| 856 allocated. This stage is called the "sweep stage" of GC, and | |
| 857 is executed after the "mark stage", which involves starting | |
| 858 from all places that are known to point to in-use Lisp objects | |
| 859 (e.g. the obarray, where are all symbols are stored; the | |
| 860 current catches and condition-cases; the backtrace list of | |
| 861 currently executing functions; the gcpro list; etc.) and | |
| 862 recursively marking all objects that are accessible. | |
| 863 | |
| 454 | 864 At the beginning of the sweep stage, the conses in the cons blocks |
| 865 are in one of three states: in use and marked, in use but not | |
| 866 marked, and not in use (already freed). Any conses that are marked | |
| 867 have been marked in the mark stage just executed, because as part | |
| 868 of the sweep stage we unmark any marked objects. The way we tell | |
| 869 whether or not a cons cell is in use is through the LRECORD_FREE_P | |
| 870 macro. This uses a special lrecord type `lrecord_type_free', | |
| 871 which is never associated with any valid object. | |
| 872 | |
| 873 Conses on the free_cons_list are threaded through a pointer stored | |
| 874 in the conses themselves. Because the cons is still in a | |
| 875 cons_block and needs to remain marked as not in use for the next | |
| 876 time that GC happens, we need room to store both the "free" | |
| 877 indicator and the chaining pointer. So this pointer is stored | |
| 878 after the lrecord header (actually where C places a pointer after | |
| 879 the lrecord header; they are not necessarily contiguous). This | |
| 880 implies that all fixed-size types must be big enough to contain at | |
| 881 least one pointer. This is true for all current fixed-size types, | |
| 882 with the possible exception of Lisp_Floats, for which we define the | |
| 883 meat of the struct using a union of a pointer and a double to | |
| 884 ensure adequate space for the free list chain pointer. | |
| 428 | 885 |
| 886 Some types of objects need additional "finalization" done | |
| 887 when an object is converted from in use to not in use; | |
| 888 this is the purpose of the ADDITIONAL_FREE_type macro. | |
| 889 For example, markers need to be removed from the chain | |
| 890 of markers that is kept in each buffer. This is because | |
| 891 markers in a buffer automatically disappear if the marker | |
| 892 is no longer referenced anywhere (the same does not | |
| 893 apply to extents, however). | |
| 894 | |
| 895 WARNING: Things are in an extremely bizarre state when | |
| 896 the ADDITIONAL_FREE_type macros are called, so beware! | |
| 897 | |
| 454 | 898 When ERROR_CHECK_GC is defined, we do things differently so as to |
| 899 maximize our chances of catching places where there is insufficient | |
| 900 GCPROing. The thing we want to avoid is having an object that | |
| 901 we're using but didn't GCPRO get freed by GC and then reallocated | |
| 902 while we're in the process of using it -- this will result in | |
| 903 something seemingly unrelated getting trashed, and is extremely | |
| 904 difficult to track down. If the object gets freed but not | |
| 905 reallocated, we can usually catch this because we set most of the | |
| 906 bytes of a freed object to 0xDEADBEEF. (The lisp object type is set | |
| 907 to the invalid type `lrecord_type_free', however, and a pointer | |
| 908 used to chain freed objects together is stored after the lrecord | |
| 909 header; we play some tricks with this pointer to make it more | |
| 428 | 910 bogus, so crashes are more likely to occur right away.) |
| 911 | |
| 912 We want freed objects to stay free as long as possible, | |
| 913 so instead of doing what we do above, we maintain the | |
| 914 free objects in a first-in first-out queue. We also | |
| 915 don't recompute the free list each GC, unlike above; | |
| 916 this ensures that the queue ordering is preserved. | |
| 917 [This means that we are likely to have worse locality | |
| 918 of reference, and that we can never free a frob block | |
| 919 once it's allocated. (Even if we know that all cells | |
| 920 in it are free, there's no easy way to remove all those | |
| 921 cells from the free list because the objects on the | |
| 922 free list are unlikely to be in memory order.)] | |
| 923 Furthermore, we never take objects off the free list | |
| 924 unless there's a large number (usually 1000, but | |
| 925 varies depending on type) of them already on the list. | |
| 926 This way, we ensure that an object that gets freed will | |
| 927 remain free for the next 1000 (or whatever) times that | |
| 440 | 928 an object of that type is allocated. */ |
| 428 | 929 |
| 930 #ifndef MALLOC_OVERHEAD | |
| 931 #ifdef GNU_MALLOC | |
| 932 #define MALLOC_OVERHEAD 0 | |
| 933 #elif defined (rcheck) | |
| 934 #define MALLOC_OVERHEAD 20 | |
| 935 #else | |
| 936 #define MALLOC_OVERHEAD 8 | |
| 937 #endif | |
| 938 #endif /* MALLOC_OVERHEAD */ | |
| 939 | |
| 940 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) | |
| 941 /* If we released our reserve (due to running out of memory), | |
| 942 and we have a fair amount free once again, | |
| 943 try to set aside another reserve in case we run out once more. | |
| 944 | |
| 945 This is called when a relocatable block is freed in ralloc.c. */ | |
| 946 void refill_memory_reserve (void); | |
| 947 void | |
| 442 | 948 refill_memory_reserve (void) |
| 428 | 949 { |
| 950 if (breathing_space == 0) | |
| 951 breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); | |
| 952 } | |
| 953 #endif | |
| 954 | |
| 955 #ifdef ALLOC_NO_POOLS | |
| 956 # define TYPE_ALLOC_SIZE(type, structtype) 1 | |
| 957 #else | |
| 958 # define TYPE_ALLOC_SIZE(type, structtype) \ | |
| 959 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *)) \ | |
| 960 / sizeof (structtype)) | |
| 961 #endif /* ALLOC_NO_POOLS */ | |
| 962 | |
| 963 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ | |
| 964 \ | |
| 965 struct type##_block \ | |
| 966 { \ | |
| 967 struct type##_block *prev; \ | |
| 968 structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ | |
| 969 }; \ | |
| 970 \ | |
| 971 static struct type##_block *current_##type##_block; \ | |
| 972 static int current_##type##_block_index; \ | |
| 973 \ | |
| 454 | 974 static Lisp_Free *type##_free_list; \ |
| 975 static Lisp_Free *type##_free_list_tail; \ | |
| 428 | 976 \ |
| 977 static void \ | |
| 978 init_##type##_alloc (void) \ | |
| 979 { \ | |
| 980 current_##type##_block = 0; \ | |
| 981 current_##type##_block_index = \ | |
| 982 countof (current_##type##_block->block); \ | |
| 983 type##_free_list = 0; \ | |
| 984 type##_free_list_tail = 0; \ | |
| 985 } \ | |
| 986 \ | |
| 987 static int gc_count_num_##type##_in_use; \ | |
| 988 static int gc_count_num_##type##_freelist | |
| 989 | |
| 990 #define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ | |
| 991 if (current_##type##_block_index \ | |
| 992 == countof (current_##type##_block->block)) \ | |
| 993 { \ | |
| 994 struct type##_block *AFTFB_new = (struct type##_block *) \ | |
| 995 allocate_lisp_storage (sizeof (struct type##_block)); \ | |
| 996 AFTFB_new->prev = current_##type##_block; \ | |
| 997 current_##type##_block = AFTFB_new; \ | |
| 998 current_##type##_block_index = 0; \ | |
| 999 } \ | |
| 1000 (result) = \ | |
| 1001 &(current_##type##_block->block[current_##type##_block_index++]); \ | |
| 1002 } while (0) | |
| 1003 | |
| 1004 /* Allocate an instance of a type that is stored in blocks. | |
| 1005 TYPE is the "name" of the type, STRUCTTYPE is the corresponding | |
| 1006 structure type. */ | |
| 1007 | |
| 1008 #ifdef ERROR_CHECK_GC | |
| 1009 | |
| 1010 /* Note: if you get crashes in this function, suspect incorrect calls | |
| 1011 to free_cons() and friends. This happened once because the cons | |
| 1012 cell was not GC-protected and was getting collected before | |
| 1013 free_cons() was called. */ | |
| 1014 | |
| 454 | 1015 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
| 1016 if (gc_count_num_##type##_freelist > \ | |
| 1017 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \ | |
| 1018 { \ | |
| 1019 result = (structtype *) type##_free_list; \ | |
| 1204 | 1020 assert (LRECORD_FREE_P (result)); \ |
| 1021 /* Before actually using the chain pointer, we complement \ | |
| 1022 all its bits; see PUT_FIXED_TYPE_ON_FREE_LIST(). */ \ | |
| 454 | 1023 type##_free_list = (Lisp_Free *) \ |
| 1024 (~ (EMACS_UINT) (type##_free_list->chain)); \ | |
| 1025 gc_count_num_##type##_freelist--; \ | |
| 1026 } \ | |
| 1027 else \ | |
| 1028 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
| 1029 MARK_LRECORD_AS_NOT_FREE (result); \ | |
| 428 | 1030 } while (0) |
| 1031 | |
| 1032 #else /* !ERROR_CHECK_GC */ | |
| 1033 | |
| 454 | 1034 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \ |
| 428 | 1035 if (type##_free_list) \ |
| 1036 { \ | |
| 454 | 1037 result = (structtype *) type##_free_list; \ |
| 1038 type##_free_list = type##_free_list->chain; \ | |
| 428 | 1039 } \ |
| 1040 else \ | |
| 1041 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \ | |
| 454 | 1042 MARK_LRECORD_AS_NOT_FREE (result); \ |
| 428 | 1043 } while (0) |
| 1044 | |
| 1045 #endif /* !ERROR_CHECK_GC */ | |
| 1046 | |
| 454 | 1047 |
| 428 | 1048 #define ALLOCATE_FIXED_TYPE(type, structtype, result) \ |
| 1049 do \ | |
| 1050 { \ | |
| 1051 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
| 1052 INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
| 1053 } while (0) | |
| 1054 | |
| 1055 #define NOSEEUM_ALLOCATE_FIXED_TYPE(type, structtype, result) \ | |
| 1056 do \ | |
| 1057 { \ | |
| 1058 ALLOCATE_FIXED_TYPE_1 (type, structtype, result); \ | |
| 1059 NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \ | |
| 1060 } while (0) | |
| 1061 | |
| 454 | 1062 |
| 1063 /* Lisp_Free is the type to represent a free list member inside a frob | |
| 1064 block of any lisp object type. */ | |
| 1065 typedef struct Lisp_Free | |
| 1066 { | |
| 1067 struct lrecord_header lheader; | |
| 1068 struct Lisp_Free *chain; | |
| 1069 } Lisp_Free; | |
| 1070 | |
| 1071 #define LRECORD_FREE_P(ptr) \ | |
| 771 | 1072 (((struct lrecord_header *) ptr)->type == lrecord_type_free) |
| 454 | 1073 |
| 1074 #define MARK_LRECORD_AS_FREE(ptr) \ | |
| 771 | 1075 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_free)) |
| 454 | 1076 |
| 1077 #ifdef ERROR_CHECK_GC | |
| 1078 #define MARK_LRECORD_AS_NOT_FREE(ptr) \ | |
| 771 | 1079 ((void) (((struct lrecord_header *) ptr)->type = lrecord_type_undefined)) |
| 428 | 1080 #else |
| 454 | 1081 #define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING |
| 428 | 1082 #endif |
| 1083 | |
| 1084 #ifdef ERROR_CHECK_GC | |
| 1085 | |
| 454 | 1086 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
| 1087 if (type##_free_list_tail) \ | |
| 1088 { \ | |
| 1089 /* When we store the chain pointer, we complement all \ | |
| 1090 its bits; this should significantly increase its \ | |
| 1091 bogosity in case someone tries to use the value, and \ | |
| 1092 should make us crash faster if someone overwrites the \ | |
| 1093 pointer because when it gets un-complemented in \ | |
| 1094 ALLOCATED_FIXED_TYPE(), the resulting pointer will be \ | |
| 1095 extremely bogus. */ \ | |
| 1096 type##_free_list_tail->chain = \ | |
| 1097 (Lisp_Free *) ~ (EMACS_UINT) (ptr); \ | |
| 1098 } \ | |
| 1099 else \ | |
| 1100 type##_free_list = (Lisp_Free *) (ptr); \ | |
| 1101 type##_free_list_tail = (Lisp_Free *) (ptr); \ | |
| 1102 } while (0) | |
| 428 | 1103 |
| 1104 #else /* !ERROR_CHECK_GC */ | |
| 1105 | |
| 454 | 1106 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \ |
| 1107 ((Lisp_Free *) (ptr))->chain = type##_free_list; \ | |
| 1108 type##_free_list = (Lisp_Free *) (ptr); \ | |
| 1109 } while (0) \ | |
| 428 | 1110 |
| 1111 #endif /* !ERROR_CHECK_GC */ | |
| 1112 | |
| 1113 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ | |
| 1114 | |
| 1115 #define FREE_FIXED_TYPE(type, structtype, ptr) do { \ | |
| 1116 structtype *FFT_ptr = (ptr); \ | |
| 1204 | 1117 gc_checking_assert (!LRECORD_FREE_P (FFT_ptr)); \ |
| 2367 | 1118 gc_checking_assert (!DUMPEDP (FFT_ptr)); \ |
| 428 | 1119 ADDITIONAL_FREE_##type (FFT_ptr); \ |
| 1120 deadbeef_memory (FFT_ptr, sizeof (structtype)); \ | |
| 1121 PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \ | |
| 454 | 1122 MARK_LRECORD_AS_FREE (FFT_ptr); \ |
| 428 | 1123 } while (0) |
| 1124 | |
| 1125 /* Like FREE_FIXED_TYPE() but used when we are explicitly | |
| 1126 freeing a structure through free_cons(), free_marker(), etc. | |
| 1127 rather than through the normal process of sweeping. | |
| 1128 We attempt to undo the changes made to the allocation counters | |
| 1129 as a result of this structure being allocated. This is not | |
| 1130 completely necessary but helps keep things saner: e.g. this way, | |
| 1131 repeatedly allocating and freeing a cons will not result in | |
| 1132 the consing-since-gc counter advancing, which would cause a GC | |
| 1204 | 1133 and somewhat defeat the purpose of explicitly freeing. |
| 1134 | |
| 1135 We also disable this mechanism entirely when ALLOC_NO_POOLS is | |
| 1136 set, which is used for Purify and the like. */ | |
| 1137 | |
| 1138 #ifndef ALLOC_NO_POOLS | |
| 428 | 1139 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) \ |
| 1140 do { FREE_FIXED_TYPE (type, structtype, ptr); \ | |
| 1141 DECREMENT_CONS_COUNTER (sizeof (structtype)); \ | |
| 1142 gc_count_num_##type##_freelist++; \ | |
| 1143 } while (0) | |
| 1204 | 1144 #else |
| 1145 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr) | |
| 1146 #endif | |
| 2720 | 1147 #endif /* not MC_ALLOC */ |
| 428 | 1148 |
| 1149 | |
| 1150 | |
| 1151 /************************************************************************/ | |
| 1152 /* Cons allocation */ | |
| 1153 /************************************************************************/ | |
| 1154 | |
| 2720 | 1155 #ifndef MC_ALLOC |
| 440 | 1156 DECLARE_FIXED_TYPE_ALLOC (cons, Lisp_Cons); |
| 428 | 1157 /* conses are used and freed so often that we set this really high */ |
| 1158 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */ | |
| 1159 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000 | |
| 2720 | 1160 #endif /* not MC_ALLOC */ |
| 428 | 1161 |
| 1162 static Lisp_Object | |
| 1163 mark_cons (Lisp_Object obj) | |
| 1164 { | |
| 1165 if (NILP (XCDR (obj))) | |
| 1166 return XCAR (obj); | |
| 1167 | |
| 1168 mark_object (XCAR (obj)); | |
| 1169 return XCDR (obj); | |
| 1170 } | |
| 1171 | |
| 1172 static int | |
| 1173 cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) | |
| 1174 { | |
| 442 | 1175 depth++; |
| 1176 while (internal_equal (XCAR (ob1), XCAR (ob2), depth)) | |
| 428 | 1177 { |
| 1178 ob1 = XCDR (ob1); | |
| 1179 ob2 = XCDR (ob2); | |
| 1180 if (! CONSP (ob1) || ! CONSP (ob2)) | |
| 442 | 1181 return internal_equal (ob1, ob2, depth); |
| 428 | 1182 } |
| 1183 return 0; | |
| 1184 } | |
| 1185 | |
| 1204 | 1186 static const struct memory_description cons_description[] = { |
| 853 | 1187 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) }, |
| 1188 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) }, | |
| 428 | 1189 { XD_END } |
| 1190 }; | |
| 1191 | |
| 934 | 1192 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, |
| 1193 1, /*dumpable-flag*/ | |
| 1194 mark_cons, print_cons, 0, | |
| 1195 cons_equal, | |
| 1196 /* | |
| 1197 * No `hash' method needed. | |
| 1198 * internal_hash knows how to | |
| 1199 * handle conses. | |
| 1200 */ | |
| 1201 0, | |
| 1202 cons_description, | |
| 1203 Lisp_Cons); | |
| 428 | 1204 |
| 1205 DEFUN ("cons", Fcons, 2, 2, 0, /* | |
| 1206 Create a new cons, give it CAR and CDR as components, and return it. | |
| 1207 */ | |
| 1208 (car, cdr)) | |
| 1209 { | |
| 1210 /* This cannot GC. */ | |
| 1211 Lisp_Object val; | |
| 440 | 1212 Lisp_Cons *c; |
| 1213 | |
| 2720 | 1214 #ifdef MC_ALLOC |
| 1215 c = alloc_lrecord_type (Lisp_Cons, &lrecord_cons); | |
| 1216 #else /* not MC_ALLOC */ | |
| 440 | 1217 ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); |
| 442 | 1218 set_lheader_implementation (&c->lheader, &lrecord_cons); |
| 2720 | 1219 #endif /* not MC_ALLOC */ |
| 793 | 1220 val = wrap_cons (c); |
| 853 | 1221 XSETCAR (val, car); |
| 1222 XSETCDR (val, cdr); | |
| 428 | 1223 return val; |
| 1224 } | |
| 1225 | |
| 1226 /* This is identical to Fcons() but it used for conses that we're | |
| 1227 going to free later, and is useful when trying to track down | |
| 1228 "real" consing. */ | |
| 1229 Lisp_Object | |
| 1230 noseeum_cons (Lisp_Object car, Lisp_Object cdr) | |
| 1231 { | |
| 1232 Lisp_Object val; | |
| 440 | 1233 Lisp_Cons *c; |
| 1234 | |
| 2720 | 1235 #ifdef MC_ALLOC |
| 1236 c = noseeum_alloc_lrecord_type (Lisp_Cons, &lrecord_cons); | |
| 1237 #else /* not MC_ALLOC */ | |
| 440 | 1238 NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c); |
| 442 | 1239 set_lheader_implementation (&c->lheader, &lrecord_cons); |
| 2720 | 1240 #endif /* not MC_ALLOC */ |
| 793 | 1241 val = wrap_cons (c); |
| 428 | 1242 XCAR (val) = car; |
| 1243 XCDR (val) = cdr; | |
| 1244 return val; | |
| 1245 } | |
| 1246 | |
| 1247 DEFUN ("list", Flist, 0, MANY, 0, /* | |
| 1248 Return a newly created list with specified arguments as elements. | |
| 1249 Any number of arguments, even zero arguments, are allowed. | |
| 1250 */ | |
| 1251 (int nargs, Lisp_Object *args)) | |
| 1252 { | |
| 1253 Lisp_Object val = Qnil; | |
| 1254 Lisp_Object *argp = args + nargs; | |
| 1255 | |
| 1256 while (argp > args) | |
| 1257 val = Fcons (*--argp, val); | |
| 1258 return val; | |
| 1259 } | |
| 1260 | |
| 1261 Lisp_Object | |
| 1262 list1 (Lisp_Object obj0) | |
| 1263 { | |
| 1264 /* This cannot GC. */ | |
| 1265 return Fcons (obj0, Qnil); | |
| 1266 } | |
| 1267 | |
| 1268 Lisp_Object | |
| 1269 list2 (Lisp_Object obj0, Lisp_Object obj1) | |
| 1270 { | |
| 1271 /* This cannot GC. */ | |
| 1272 return Fcons (obj0, Fcons (obj1, Qnil)); | |
| 1273 } | |
| 1274 | |
| 1275 Lisp_Object | |
| 1276 list3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1277 { | |
| 1278 /* This cannot GC. */ | |
| 1279 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Qnil))); | |
| 1280 } | |
| 1281 | |
| 1282 Lisp_Object | |
| 1283 cons3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1284 { | |
| 1285 /* This cannot GC. */ | |
| 1286 return Fcons (obj0, Fcons (obj1, obj2)); | |
| 1287 } | |
| 1288 | |
| 1289 Lisp_Object | |
| 1290 acons (Lisp_Object key, Lisp_Object value, Lisp_Object alist) | |
| 1291 { | |
| 1292 return Fcons (Fcons (key, value), alist); | |
| 1293 } | |
| 1294 | |
| 1295 Lisp_Object | |
| 1296 list4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3) | |
| 1297 { | |
| 1298 /* This cannot GC. */ | |
| 1299 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Qnil)))); | |
| 1300 } | |
| 1301 | |
| 1302 Lisp_Object | |
| 1303 list5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
| 1304 Lisp_Object obj4) | |
| 1305 { | |
| 1306 /* This cannot GC. */ | |
| 1307 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Qnil))))); | |
| 1308 } | |
| 1309 | |
| 1310 Lisp_Object | |
| 1311 list6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, Lisp_Object obj3, | |
| 1312 Lisp_Object obj4, Lisp_Object obj5) | |
| 1313 { | |
| 1314 /* This cannot GC. */ | |
| 1315 return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil)))))); | |
| 1316 } | |
| 1317 | |
| 1318 DEFUN ("make-list", Fmake_list, 2, 2, 0, /* | |
| 444 | 1319 Return a new list of length LENGTH, with each element being OBJECT. |
| 428 | 1320 */ |
| 444 | 1321 (length, object)) |
| 428 | 1322 { |
| 1323 CHECK_NATNUM (length); | |
| 1324 | |
| 1325 { | |
| 1326 Lisp_Object val = Qnil; | |
| 647 | 1327 EMACS_INT size = XINT (length); |
| 428 | 1328 |
| 1329 while (size--) | |
| 444 | 1330 val = Fcons (object, val); |
| 428 | 1331 return val; |
| 1332 } | |
| 1333 } | |
| 1334 | |
| 1335 | |
| 1336 /************************************************************************/ | |
| 1337 /* Float allocation */ | |
| 1338 /************************************************************************/ | |
| 1339 | |
| 1983 | 1340 /*** With enhanced number support, these are short floats */ |
| 1341 | |
| 2720 | 1342 #ifndef MC_ALLOC |
| 440 | 1343 DECLARE_FIXED_TYPE_ALLOC (float, Lisp_Float); |
| 428 | 1344 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_float 1000 |
| 2720 | 1345 #endif /* not MC_ALLOC */ |
| 428 | 1346 |
| 1347 Lisp_Object | |
| 1348 make_float (double float_value) | |
| 1349 { | |
| 440 | 1350 Lisp_Float *f; |
| 1351 | |
| 2720 | 1352 #ifdef MC_ALLOC |
| 1353 f = alloc_lrecord_type (Lisp_Float, &lrecord_float); | |
| 1354 #else /* not MC_ALLOC */ | |
| 440 | 1355 ALLOCATE_FIXED_TYPE (float, Lisp_Float, f); |
| 1356 | |
| 1357 /* Avoid dump-time `uninitialized memory read' purify warnings. */ | |
| 1358 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) | |
| 1359 xzero (*f); | |
| 2720 | 1360 #endif /* not MC_ALLOC */ |
| 440 | 1361 |
| 442 | 1362 set_lheader_implementation (&f->lheader, &lrecord_float); |
| 428 | 1363 float_data (f) = float_value; |
| 793 | 1364 return wrap_float (f); |
| 428 | 1365 } |
| 1366 | |
| 1367 | |
| 1368 /************************************************************************/ | |
| 1983 | 1369 /* Enhanced number allocation */ |
| 1370 /************************************************************************/ | |
| 1371 | |
| 1372 /*** Bignum ***/ | |
| 1373 #ifdef HAVE_BIGNUM | |
| 2720 | 1374 #ifndef MC_ALLOC |
| 1983 | 1375 DECLARE_FIXED_TYPE_ALLOC (bignum, Lisp_Bignum); |
| 1376 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bignum 250 | |
| 2720 | 1377 #endif /* not MC_ALLOC */ |
| 1983 | 1378 |
| 1379 /* WARNING: This function returns a bignum even if its argument fits into a | |
| 1380 fixnum. See Fcanonicalize_number(). */ | |
| 1381 Lisp_Object | |
| 1382 make_bignum (long bignum_value) | |
| 1383 { | |
| 1384 Lisp_Bignum *b; | |
| 1385 | |
| 2720 | 1386 #ifdef MC_ALLOC |
| 1387 b = alloc_lrecord_type (Lisp_Bignum, &lrecord_bignum); | |
| 1388 #else /* not MC_ALLOC */ | |
| 1983 | 1389 ALLOCATE_FIXED_TYPE (bignum, Lisp_Bignum, b); |
| 1390 set_lheader_implementation (&b->lheader, &lrecord_bignum); | |
| 2720 | 1391 #endif /* not MC_ALLOC */ |
| 1983 | 1392 bignum_init (bignum_data (b)); |
| 1393 bignum_set_long (bignum_data (b), bignum_value); | |
| 1394 return wrap_bignum (b); | |
| 1395 } | |
| 1396 | |
| 1397 /* WARNING: This function returns a bignum even if its argument fits into a | |
| 1398 fixnum. See Fcanonicalize_number(). */ | |
| 1399 Lisp_Object | |
| 1400 make_bignum_bg (bignum bg) | |
| 1401 { | |
| 1402 Lisp_Bignum *b; | |
| 1403 | |
| 2720 | 1404 #ifdef MC_ALLOC |
| 1405 b = alloc_lrecord_type (Lisp_Bignum, &lrecord_bignum); | |
| 1406 #else /* not MC_ALLOC */ | |
| 1983 | 1407 ALLOCATE_FIXED_TYPE (bignum, Lisp_Bignum, b); |
| 1408 set_lheader_implementation (&b->lheader, &lrecord_bignum); | |
| 2720 | 1409 #endif /* not MC_ALLOC */ |
| 1983 | 1410 bignum_init (bignum_data (b)); |
| 1411 bignum_set (bignum_data (b), bg); | |
| 1412 return wrap_bignum (b); | |
| 1413 } | |
| 1414 #endif /* HAVE_BIGNUM */ | |
| 1415 | |
| 1416 /*** Ratio ***/ | |
| 1417 #ifdef HAVE_RATIO | |
| 2720 | 1418 #ifndef MC_ALLOC |
| 1983 | 1419 DECLARE_FIXED_TYPE_ALLOC (ratio, Lisp_Ratio); |
| 1420 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_ratio 250 | |
| 2720 | 1421 #endif /* not MC_ALLOC */ |
| 1983 | 1422 |
| 1423 Lisp_Object | |
| 1424 make_ratio (long numerator, unsigned long denominator) | |
| 1425 { | |
| 1426 Lisp_Ratio *r; | |
| 1427 | |
| 2720 | 1428 #ifdef MC_ALLOC |
| 1429 r = alloc_lrecord_type (Lisp_Ratio, &lrecord_ratio); | |
| 1430 #else /* not MC_ALLOC */ | |
| 1983 | 1431 ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); |
| 1432 set_lheader_implementation (&r->lheader, &lrecord_ratio); | |
| 2720 | 1433 #endif /* not MC_ALLOC */ |
| 1983 | 1434 ratio_init (ratio_data (r)); |
| 1435 ratio_set_long_ulong (ratio_data (r), numerator, denominator); | |
| 1436 ratio_canonicalize (ratio_data (r)); | |
| 1437 return wrap_ratio (r); | |
| 1438 } | |
| 1439 | |
| 1440 Lisp_Object | |
| 1441 make_ratio_bg (bignum numerator, bignum denominator) | |
| 1442 { | |
| 1443 Lisp_Ratio *r; | |
| 1444 | |
| 2720 | 1445 #ifdef MC_ALLOC |
| 1446 r = alloc_lrecord_type (Lisp_Ratio, &lrecord_ratio); | |
| 1447 #else /* not MC_ALLOC */ | |
| 1983 | 1448 ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); |
| 1449 set_lheader_implementation (&r->lheader, &lrecord_ratio); | |
| 2720 | 1450 #endif /* not MC_ALLOC */ |
| 1983 | 1451 ratio_init (ratio_data (r)); |
| 1452 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator); | |
| 1453 ratio_canonicalize (ratio_data (r)); | |
| 1454 return wrap_ratio (r); | |
| 1455 } | |
| 1456 | |
| 1457 Lisp_Object | |
| 1458 make_ratio_rt (ratio rat) | |
| 1459 { | |
| 1460 Lisp_Ratio *r; | |
| 1461 | |
| 2720 | 1462 #ifdef MC_ALLOC |
| 1463 r = alloc_lrecord_type (Lisp_Ratio, &lrecord_ratio); | |
| 1464 #else /* not MC_ALLOC */ | |
| 1983 | 1465 ALLOCATE_FIXED_TYPE (ratio, Lisp_Ratio, r); |
| 1466 set_lheader_implementation (&r->lheader, &lrecord_ratio); | |
| 2720 | 1467 #endif /* not MC_ALLOC */ |
| 1983 | 1468 ratio_init (ratio_data (r)); |
| 1469 ratio_set (ratio_data (r), rat); | |
| 1470 return wrap_ratio (r); | |
| 1471 } | |
| 1472 #endif /* HAVE_RATIO */ | |
| 1473 | |
| 1474 /*** Bigfloat ***/ | |
| 1475 #ifdef HAVE_BIGFLOAT | |
| 2720 | 1476 #ifndef MC_ALLOC |
| 1983 | 1477 DECLARE_FIXED_TYPE_ALLOC (bigfloat, Lisp_Bigfloat); |
| 1478 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_bigfloat 250 | |
| 2720 | 1479 #endif /* not MC_ALLOC */ |
| 1983 | 1480 |
| 1481 /* This function creates a bigfloat with the default precision if the | |
| 1482 PRECISION argument is zero. */ | |
| 1483 Lisp_Object | |
| 1484 make_bigfloat (double float_value, unsigned long precision) | |
| 1485 { | |
| 1486 Lisp_Bigfloat *f; | |
| 1487 | |
| 2720 | 1488 #ifdef MC_ALLOC |
| 1489 f = alloc_lrecord_type (Lisp_Bigfloat, &lrecord_bigfloat); | |
| 1490 #else /* not MC_ALLOC */ | |
| 1983 | 1491 ALLOCATE_FIXED_TYPE (bigfloat, Lisp_Bigfloat, f); |
| 1492 set_lheader_implementation (&f->lheader, &lrecord_bigfloat); | |
| 2720 | 1493 #endif /* not MC_ALLOC */ |
| 1983 | 1494 if (precision == 0UL) |
| 1495 bigfloat_init (bigfloat_data (f)); | |
| 1496 else | |
| 1497 bigfloat_init_prec (bigfloat_data (f), precision); | |
| 1498 bigfloat_set_double (bigfloat_data (f), float_value); | |
| 1499 return wrap_bigfloat (f); | |
| 1500 } | |
| 1501 | |
| 1502 /* This function creates a bigfloat with the precision of its argument */ | |
| 1503 Lisp_Object | |
| 1504 make_bigfloat_bf (bigfloat float_value) | |
| 1505 { | |
| 1506 Lisp_Bigfloat *f; | |
| 1507 | |
| 2720 | 1508 #ifdef MC_ALLOC |
| 1509 f = alloc_lrecord_type (Lisp_Bigfloat, &lrecord_bigfloat); | |
| 1510 #else /* not MC_ALLOC */ | |
| 1983 | 1511 ALLOCATE_FIXED_TYPE (bigfloat, Lisp_Bigfloat, f); |
| 1512 set_lheader_implementation (&f->lheader, &lrecord_bigfloat); | |
| 2720 | 1513 #endif /* not MC_ALLOC */ |
| 1983 | 1514 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value)); |
| 1515 bigfloat_set (bigfloat_data (f), float_value); | |
| 1516 return wrap_bigfloat (f); | |
| 1517 } | |
| 1518 #endif /* HAVE_BIGFLOAT */ | |
| 1519 | |
| 1520 /************************************************************************/ | |
| 428 | 1521 /* Vector allocation */ |
| 1522 /************************************************************************/ | |
| 1523 | |
| 1524 static Lisp_Object | |
| 1525 mark_vector (Lisp_Object obj) | |
| 1526 { | |
| 1527 Lisp_Vector *ptr = XVECTOR (obj); | |
| 1528 int len = vector_length (ptr); | |
| 1529 int i; | |
| 1530 | |
| 1531 for (i = 0; i < len - 1; i++) | |
| 1532 mark_object (ptr->contents[i]); | |
| 1533 return (len > 0) ? ptr->contents[len - 1] : Qnil; | |
| 1534 } | |
| 1535 | |
| 665 | 1536 static Bytecount |
| 442 | 1537 size_vector (const void *lheader) |
| 428 | 1538 { |
| 456 | 1539 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents, |
| 442 | 1540 ((Lisp_Vector *) lheader)->size); |
| 428 | 1541 } |
| 1542 | |
| 1543 static int | |
| 1544 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 1545 { | |
| 1546 int len = XVECTOR_LENGTH (obj1); | |
| 1547 if (len != XVECTOR_LENGTH (obj2)) | |
| 1548 return 0; | |
| 1549 | |
| 1550 { | |
| 1551 Lisp_Object *ptr1 = XVECTOR_DATA (obj1); | |
| 1552 Lisp_Object *ptr2 = XVECTOR_DATA (obj2); | |
| 1553 while (len--) | |
| 1554 if (!internal_equal (*ptr1++, *ptr2++, depth + 1)) | |
| 1555 return 0; | |
| 1556 } | |
| 1557 return 1; | |
| 1558 } | |
| 1559 | |
| 665 | 1560 static Hashcode |
| 442 | 1561 vector_hash (Lisp_Object obj, int depth) |
| 1562 { | |
| 1563 return HASH2 (XVECTOR_LENGTH (obj), | |
| 1564 internal_array_hash (XVECTOR_DATA (obj), | |
| 1565 XVECTOR_LENGTH (obj), | |
| 1566 depth + 1)); | |
| 1567 } | |
| 1568 | |
| 1204 | 1569 static const struct memory_description vector_description[] = { |
| 440 | 1570 { XD_LONG, offsetof (Lisp_Vector, size) }, |
| 1571 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) }, | |
| 428 | 1572 { XD_END } |
| 1573 }; | |
| 1574 | |
| 1204 | 1575 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("vector", vector, |
| 1576 1, /*dumpable-flag*/ | |
| 1577 mark_vector, print_vector, 0, | |
| 1578 vector_equal, | |
| 1579 vector_hash, | |
| 1580 vector_description, | |
| 1581 size_vector, Lisp_Vector); | |
| 428 | 1582 /* #### should allocate `small' vectors from a frob-block */ |
| 1583 static Lisp_Vector * | |
| 665 | 1584 make_vector_internal (Elemcount sizei) |
| 428 | 1585 { |
| 1204 | 1586 /* no `next' field; we use lcrecords */ |
| 665 | 1587 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, |
| 1204 | 1588 contents, sizei); |
| 1589 Lisp_Vector *p = | |
| 2720 | 1590 #ifdef MC_ALLOC |
| 1591 (Lisp_Vector *) alloc_lrecord (sizem, &lrecord_vector); | |
| 1592 #else /* not MC_ALLOC */ | |
| 1204 | 1593 (Lisp_Vector *) basic_alloc_lcrecord (sizem, &lrecord_vector); |
| 2720 | 1594 #endif /* not MC_ALLOC */ |
| 428 | 1595 |
| 1596 p->size = sizei; | |
| 1597 return p; | |
| 1598 } | |
| 1599 | |
| 1600 Lisp_Object | |
| 665 | 1601 make_vector (Elemcount length, Lisp_Object object) |
| 428 | 1602 { |
| 1603 Lisp_Vector *vecp = make_vector_internal (length); | |
| 1604 Lisp_Object *p = vector_data (vecp); | |
| 1605 | |
| 1606 while (length--) | |
| 444 | 1607 *p++ = object; |
| 428 | 1608 |
| 793 | 1609 return wrap_vector (vecp); |
| 428 | 1610 } |
| 1611 | |
| 1612 DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /* | |
| 444 | 1613 Return a new vector of length LENGTH, with each element being OBJECT. |
| 428 | 1614 See also the function `vector'. |
| 1615 */ | |
| 444 | 1616 (length, object)) |
| 428 | 1617 { |
| 1618 CONCHECK_NATNUM (length); | |
| 444 | 1619 return make_vector (XINT (length), object); |
| 428 | 1620 } |
| 1621 | |
| 1622 DEFUN ("vector", Fvector, 0, MANY, 0, /* | |
| 1623 Return a newly created vector with specified arguments as elements. | |
| 1624 Any number of arguments, even zero arguments, are allowed. | |
| 1625 */ | |
| 1626 (int nargs, Lisp_Object *args)) | |
| 1627 { | |
| 1628 Lisp_Vector *vecp = make_vector_internal (nargs); | |
| 1629 Lisp_Object *p = vector_data (vecp); | |
| 1630 | |
| 1631 while (nargs--) | |
| 1632 *p++ = *args++; | |
| 1633 | |
| 793 | 1634 return wrap_vector (vecp); |
| 428 | 1635 } |
| 1636 | |
| 1637 Lisp_Object | |
| 1638 vector1 (Lisp_Object obj0) | |
| 1639 { | |
| 1640 return Fvector (1, &obj0); | |
| 1641 } | |
| 1642 | |
| 1643 Lisp_Object | |
| 1644 vector2 (Lisp_Object obj0, Lisp_Object obj1) | |
| 1645 { | |
| 1646 Lisp_Object args[2]; | |
| 1647 args[0] = obj0; | |
| 1648 args[1] = obj1; | |
| 1649 return Fvector (2, args); | |
| 1650 } | |
| 1651 | |
| 1652 Lisp_Object | |
| 1653 vector3 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2) | |
| 1654 { | |
| 1655 Lisp_Object args[3]; | |
| 1656 args[0] = obj0; | |
| 1657 args[1] = obj1; | |
| 1658 args[2] = obj2; | |
| 1659 return Fvector (3, args); | |
| 1660 } | |
| 1661 | |
| 1662 #if 0 /* currently unused */ | |
| 1663 | |
| 1664 Lisp_Object | |
| 1665 vector4 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1666 Lisp_Object obj3) | |
| 1667 { | |
| 1668 Lisp_Object args[4]; | |
| 1669 args[0] = obj0; | |
| 1670 args[1] = obj1; | |
| 1671 args[2] = obj2; | |
| 1672 args[3] = obj3; | |
| 1673 return Fvector (4, args); | |
| 1674 } | |
| 1675 | |
| 1676 Lisp_Object | |
| 1677 vector5 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1678 Lisp_Object obj3, Lisp_Object obj4) | |
| 1679 { | |
| 1680 Lisp_Object args[5]; | |
| 1681 args[0] = obj0; | |
| 1682 args[1] = obj1; | |
| 1683 args[2] = obj2; | |
| 1684 args[3] = obj3; | |
| 1685 args[4] = obj4; | |
| 1686 return Fvector (5, args); | |
| 1687 } | |
| 1688 | |
| 1689 Lisp_Object | |
| 1690 vector6 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1691 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5) | |
| 1692 { | |
| 1693 Lisp_Object args[6]; | |
| 1694 args[0] = obj0; | |
| 1695 args[1] = obj1; | |
| 1696 args[2] = obj2; | |
| 1697 args[3] = obj3; | |
| 1698 args[4] = obj4; | |
| 1699 args[5] = obj5; | |
| 1700 return Fvector (6, args); | |
| 1701 } | |
| 1702 | |
| 1703 Lisp_Object | |
| 1704 vector7 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1705 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
| 1706 Lisp_Object obj6) | |
| 1707 { | |
| 1708 Lisp_Object args[7]; | |
| 1709 args[0] = obj0; | |
| 1710 args[1] = obj1; | |
| 1711 args[2] = obj2; | |
| 1712 args[3] = obj3; | |
| 1713 args[4] = obj4; | |
| 1714 args[5] = obj5; | |
| 1715 args[6] = obj6; | |
| 1716 return Fvector (7, args); | |
| 1717 } | |
| 1718 | |
| 1719 Lisp_Object | |
| 1720 vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, | |
| 1721 Lisp_Object obj3, Lisp_Object obj4, Lisp_Object obj5, | |
| 1722 Lisp_Object obj6, Lisp_Object obj7) | |
| 1723 { | |
| 1724 Lisp_Object args[8]; | |
| 1725 args[0] = obj0; | |
| 1726 args[1] = obj1; | |
| 1727 args[2] = obj2; | |
| 1728 args[3] = obj3; | |
| 1729 args[4] = obj4; | |
| 1730 args[5] = obj5; | |
| 1731 args[6] = obj6; | |
| 1732 args[7] = obj7; | |
| 1733 return Fvector (8, args); | |
| 1734 } | |
| 1735 #endif /* unused */ | |
| 1736 | |
| 1737 /************************************************************************/ | |
| 1738 /* Bit Vector allocation */ | |
| 1739 /************************************************************************/ | |
| 1740 | |
| 1741 /* #### should allocate `small' bit vectors from a frob-block */ | |
| 440 | 1742 static Lisp_Bit_Vector * |
| 665 | 1743 make_bit_vector_internal (Elemcount sizei) |
| 428 | 1744 { |
| 1204 | 1745 /* no `next' field; we use lcrecords */ |
| 665 | 1746 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei); |
| 1747 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, | |
| 1204 | 1748 unsigned long, |
| 1749 bits, num_longs); | |
| 1750 Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) | |
| 2720 | 1751 #ifdef MC_ALLOC |
| 1752 alloc_lrecord (sizem, &lrecord_bit_vector); | |
| 1753 #else /* not MC_ALLOC */ | |
| 1204 | 1754 basic_alloc_lcrecord (sizem, &lrecord_bit_vector); |
| 2720 | 1755 #endif /* not MC_ALLOC */ |
| 428 | 1756 |
| 1757 bit_vector_length (p) = sizei; | |
| 1758 return p; | |
| 1759 } | |
| 1760 | |
| 1761 Lisp_Object | |
| 665 | 1762 make_bit_vector (Elemcount length, Lisp_Object bit) |
| 428 | 1763 { |
| 440 | 1764 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
| 665 | 1765 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (length); |
| 428 | 1766 |
| 444 | 1767 CHECK_BIT (bit); |
| 1768 | |
| 1769 if (ZEROP (bit)) | |
| 428 | 1770 memset (p->bits, 0, num_longs * sizeof (long)); |
| 1771 else | |
| 1772 { | |
| 665 | 1773 Elemcount bits_in_last = length & (LONGBITS_POWER_OF_2 - 1); |
| 428 | 1774 memset (p->bits, ~0, num_longs * sizeof (long)); |
| 1775 /* But we have to make sure that the unused bits in the | |
| 1776 last long are 0, so that equal/hash is easy. */ | |
| 1777 if (bits_in_last) | |
| 1778 p->bits[num_longs - 1] &= (1 << bits_in_last) - 1; | |
| 1779 } | |
| 1780 | |
| 793 | 1781 return wrap_bit_vector (p); |
| 428 | 1782 } |
| 1783 | |
| 1784 Lisp_Object | |
| 665 | 1785 make_bit_vector_from_byte_vector (unsigned char *bytevec, Elemcount length) |
| 428 | 1786 { |
| 665 | 1787 Elemcount i; |
| 428 | 1788 Lisp_Bit_Vector *p = make_bit_vector_internal (length); |
| 1789 | |
| 1790 for (i = 0; i < length; i++) | |
| 1791 set_bit_vector_bit (p, i, bytevec[i]); | |
| 1792 | |
| 793 | 1793 return wrap_bit_vector (p); |
| 428 | 1794 } |
| 1795 | |
| 1796 DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /* | |
| 444 | 1797 Return a new bit vector of length LENGTH. with each bit set to BIT. |
| 1798 BIT must be one of the integers 0 or 1. See also the function `bit-vector'. | |
| 428 | 1799 */ |
| 444 | 1800 (length, bit)) |
| 428 | 1801 { |
| 1802 CONCHECK_NATNUM (length); | |
| 1803 | |
| 444 | 1804 return make_bit_vector (XINT (length), bit); |
| 428 | 1805 } |
| 1806 | |
| 1807 DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /* | |
| 1808 Return a newly created bit vector with specified arguments as elements. | |
| 1809 Any number of arguments, even zero arguments, are allowed. | |
| 444 | 1810 Each argument must be one of the integers 0 or 1. |
| 428 | 1811 */ |
| 1812 (int nargs, Lisp_Object *args)) | |
| 1813 { | |
| 1814 int i; | |
| 1815 Lisp_Bit_Vector *p = make_bit_vector_internal (nargs); | |
| 1816 | |
| 1817 for (i = 0; i < nargs; i++) | |
| 1818 { | |
| 1819 CHECK_BIT (args[i]); | |
| 1820 set_bit_vector_bit (p, i, !ZEROP (args[i])); | |
| 1821 } | |
| 1822 | |
| 793 | 1823 return wrap_bit_vector (p); |
| 428 | 1824 } |
| 1825 | |
| 1826 | |
| 1827 /************************************************************************/ | |
| 1828 /* Compiled-function allocation */ | |
| 1829 /************************************************************************/ | |
| 1830 | |
| 2720 | 1831 #ifndef MC_ALLOC |
| 428 | 1832 DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); |
| 1833 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 | |
| 2720 | 1834 #endif /* not MC_ALLOC */ |
| 428 | 1835 |
| 1836 static Lisp_Object | |
| 1837 make_compiled_function (void) | |
| 1838 { | |
| 1839 Lisp_Compiled_Function *f; | |
| 1840 | |
| 2720 | 1841 #ifdef MC_ALLOC |
| 1842 f = alloc_lrecord_type (Lisp_Compiled_Function, &lrecord_compiled_function); | |
| 1843 #else /* not MC_ALLOC */ | |
| 428 | 1844 ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f); |
| 442 | 1845 set_lheader_implementation (&f->lheader, &lrecord_compiled_function); |
| 2720 | 1846 #endif /* not MC_ALLOC */ |
| 428 | 1847 |
| 1848 f->stack_depth = 0; | |
| 1849 f->specpdl_depth = 0; | |
| 1850 f->flags.documentationp = 0; | |
| 1851 f->flags.interactivep = 0; | |
| 1852 f->flags.domainp = 0; /* I18N3 */ | |
| 1853 f->instructions = Qzero; | |
| 1854 f->constants = Qzero; | |
| 1855 f->arglist = Qnil; | |
| 1739 | 1856 f->args = NULL; |
| 1857 f->max_args = f->min_args = f->args_in_array = 0; | |
| 428 | 1858 f->doc_and_interactive = Qnil; |
| 1859 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 1860 f->annotated = Qnil; | |
| 1861 #endif | |
| 793 | 1862 return wrap_compiled_function (f); |
| 428 | 1863 } |
| 1864 | |
| 1865 DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* | |
| 1866 Return a new compiled-function object. | |
| 1867 Usage: (arglist instructions constants stack-depth | |
| 1868 &optional doc-string interactive) | |
| 1869 Note that, unlike all other emacs-lisp functions, calling this with five | |
| 1870 arguments is NOT the same as calling it with six arguments, the last of | |
| 1871 which is nil. If the INTERACTIVE arg is specified as nil, then that means | |
| 1872 that this function was defined with `(interactive)'. If the arg is not | |
| 1873 specified, then that means the function is not interactive. | |
| 1874 This is terrible behavior which is retained for compatibility with old | |
| 1875 `.elc' files which expect these semantics. | |
| 1876 */ | |
| 1877 (int nargs, Lisp_Object *args)) | |
| 1878 { | |
| 1879 /* In a non-insane world this function would have this arglist... | |
| 1880 (arglist instructions constants stack_depth &optional doc_string interactive) | |
| 1881 */ | |
| 1882 Lisp_Object fun = make_compiled_function (); | |
| 1883 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); | |
| 1884 | |
| 1885 Lisp_Object arglist = args[0]; | |
| 1886 Lisp_Object instructions = args[1]; | |
| 1887 Lisp_Object constants = args[2]; | |
| 1888 Lisp_Object stack_depth = args[3]; | |
| 1889 Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; | |
| 1890 Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; | |
| 1891 | |
| 1892 if (nargs < 4 || nargs > 6) | |
| 1893 return Fsignal (Qwrong_number_of_arguments, | |
| 1894 list2 (intern ("make-byte-code"), make_int (nargs))); | |
| 1895 | |
| 1896 /* Check for valid formal parameter list now, to allow us to use | |
| 1897 SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */ | |
| 1898 { | |
| 814 | 1899 EXTERNAL_LIST_LOOP_2 (symbol, arglist) |
| 428 | 1900 { |
| 1901 CHECK_SYMBOL (symbol); | |
| 1902 if (EQ (symbol, Qt) || | |
| 1903 EQ (symbol, Qnil) || | |
| 1904 SYMBOL_IS_KEYWORD (symbol)) | |
| 563 | 1905 invalid_constant_2 |
| 428 | 1906 ("Invalid constant symbol in formal parameter list", |
| 1907 symbol, arglist); | |
| 1908 } | |
| 1909 } | |
| 1910 f->arglist = arglist; | |
| 1911 | |
| 1912 /* `instructions' is a string or a cons (string . int) for a | |
| 1913 lazy-loaded function. */ | |
| 1914 if (CONSP (instructions)) | |
| 1915 { | |
| 1916 CHECK_STRING (XCAR (instructions)); | |
| 1917 CHECK_INT (XCDR (instructions)); | |
| 1918 } | |
| 1919 else | |
| 1920 { | |
| 1921 CHECK_STRING (instructions); | |
| 1922 } | |
| 1923 f->instructions = instructions; | |
| 1924 | |
| 1925 if (!NILP (constants)) | |
| 1926 CHECK_VECTOR (constants); | |
| 1927 f->constants = constants; | |
| 1928 | |
| 1929 CHECK_NATNUM (stack_depth); | |
| 442 | 1930 f->stack_depth = (unsigned short) XINT (stack_depth); |
| 428 | 1931 |
| 1932 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK | |
| 1933 if (!NILP (Vcurrent_compiled_function_annotation)) | |
| 1934 f->annotated = Fcopy (Vcurrent_compiled_function_annotation); | |
| 1935 else if (!NILP (Vload_file_name_internal_the_purecopy)) | |
| 1936 f->annotated = Vload_file_name_internal_the_purecopy; | |
| 1937 else if (!NILP (Vload_file_name_internal)) | |
| 1938 { | |
| 1939 struct gcpro gcpro1; | |
| 1940 GCPRO1 (fun); /* don't let fun get reaped */ | |
| 1941 Vload_file_name_internal_the_purecopy = | |
| 1942 Ffile_name_nondirectory (Vload_file_name_internal); | |
| 1943 f->annotated = Vload_file_name_internal_the_purecopy; | |
| 1944 UNGCPRO; | |
| 1945 } | |
| 1946 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ | |
| 1947 | |
| 1948 /* doc_string may be nil, string, int, or a cons (string . int). | |
| 1949 interactive may be list or string (or unbound). */ | |
| 1950 f->doc_and_interactive = Qunbound; | |
| 1951 #ifdef I18N3 | |
| 1952 if ((f->flags.domainp = !NILP (Vfile_domain)) != 0) | |
| 1953 f->doc_and_interactive = Vfile_domain; | |
| 1954 #endif | |
| 1955 if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0) | |
| 1956 { | |
| 1957 f->doc_and_interactive | |
| 1958 = (UNBOUNDP (f->doc_and_interactive) ? interactive : | |
| 1959 Fcons (interactive, f->doc_and_interactive)); | |
| 1960 } | |
| 1961 if ((f->flags.documentationp = !NILP (doc_string)) != 0) | |
| 1962 { | |
| 1963 f->doc_and_interactive | |
| 1964 = (UNBOUNDP (f->doc_and_interactive) ? doc_string : | |
| 1965 Fcons (doc_string, f->doc_and_interactive)); | |
| 1966 } | |
| 1967 if (UNBOUNDP (f->doc_and_interactive)) | |
| 1968 f->doc_and_interactive = Qnil; | |
| 1969 | |
| 1970 return fun; | |
| 1971 } | |
| 1972 | |
| 1973 | |
| 1974 /************************************************************************/ | |
| 1975 /* Symbol allocation */ | |
| 1976 /************************************************************************/ | |
| 1977 | |
| 2720 | 1978 #ifndef MC_ALLOC |
| 440 | 1979 DECLARE_FIXED_TYPE_ALLOC (symbol, Lisp_Symbol); |
| 428 | 1980 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 |
| 2720 | 1981 #endif /* not MC_ALLOC */ |
| 428 | 1982 |
| 1983 DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* | |
| 1984 Return a newly allocated uninterned symbol whose name is NAME. | |
| 1985 Its value and function definition are void, and its property list is nil. | |
| 1986 */ | |
| 1987 (name)) | |
| 1988 { | |
| 440 | 1989 Lisp_Symbol *p; |
| 428 | 1990 |
| 1991 CHECK_STRING (name); | |
| 1992 | |
| 2720 | 1993 #ifdef MC_ALLOC |
| 1994 p = alloc_lrecord_type (Lisp_Symbol, &lrecord_symbol); | |
| 1995 #else /* not MC_ALLOC */ | |
| 440 | 1996 ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p); |
| 442 | 1997 set_lheader_implementation (&p->lheader, &lrecord_symbol); |
| 2720 | 1998 #endif /* not MC_ALLOC */ |
| 793 | 1999 p->name = name; |
| 428 | 2000 p->plist = Qnil; |
| 2001 p->value = Qunbound; | |
| 2002 p->function = Qunbound; | |
| 2003 symbol_next (p) = 0; | |
| 793 | 2004 return wrap_symbol (p); |
| 428 | 2005 } |
| 2006 | |
| 2007 | |
| 2008 /************************************************************************/ | |
| 2009 /* Extent allocation */ | |
| 2010 /************************************************************************/ | |
| 2011 | |
| 2720 | 2012 #ifndef MC_ALLOC |
| 428 | 2013 DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); |
| 2014 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 | |
| 2720 | 2015 #endif /* not MC_ALLOC */ |
| 428 | 2016 |
| 2017 struct extent * | |
| 2018 allocate_extent (void) | |
| 2019 { | |
| 2020 struct extent *e; | |
| 2021 | |
| 2720 | 2022 #ifdef MC_ALLOC |
| 2023 e = alloc_lrecord_type (struct extent, &lrecord_extent); | |
| 2024 #else /* not MC_ALLOC */ | |
| 428 | 2025 ALLOCATE_FIXED_TYPE (extent, struct extent, e); |
| 442 | 2026 set_lheader_implementation (&e->lheader, &lrecord_extent); |
| 2720 | 2027 #endif /* not MC_ALLOC */ |
| 428 | 2028 extent_object (e) = Qnil; |
| 2029 set_extent_start (e, -1); | |
| 2030 set_extent_end (e, -1); | |
| 2031 e->plist = Qnil; | |
| 2032 | |
| 2033 xzero (e->flags); | |
| 2034 | |
| 2035 extent_face (e) = Qnil; | |
| 2036 e->flags.end_open = 1; /* default is for endpoints to behave like markers */ | |
| 2037 e->flags.detachable = 1; | |
| 2038 | |
| 2039 return e; | |
| 2040 } | |
| 2041 | |
| 2042 | |
| 2043 /************************************************************************/ | |
| 2044 /* Event allocation */ | |
| 2045 /************************************************************************/ | |
| 2046 | |
| 2720 | 2047 #ifndef MC_ALLOC |
| 440 | 2048 DECLARE_FIXED_TYPE_ALLOC (event, Lisp_Event); |
| 428 | 2049 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 |
| 2720 | 2050 #endif /* not MC_ALLOC */ |
| 428 | 2051 |
| 2052 Lisp_Object | |
| 2053 allocate_event (void) | |
| 2054 { | |
| 440 | 2055 Lisp_Event *e; |
| 2056 | |
| 2720 | 2057 #ifdef MC_ALLOC |
| 2058 e = alloc_lrecord_type (Lisp_Event, &lrecord_event); | |
| 2059 #else /* not MC_ALLOC */ | |
| 440 | 2060 ALLOCATE_FIXED_TYPE (event, Lisp_Event, e); |
| 442 | 2061 set_lheader_implementation (&e->lheader, &lrecord_event); |
| 2720 | 2062 #endif /* not MC_ALLOC */ |
| 428 | 2063 |
| 793 | 2064 return wrap_event (e); |
| 428 | 2065 } |
| 2066 | |
| 1204 | 2067 #ifdef EVENT_DATA_AS_OBJECTS |
| 2720 | 2068 #ifndef MC_ALLOC |
| 934 | 2069 DECLARE_FIXED_TYPE_ALLOC (key_data, Lisp_Key_Data); |
| 2070 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_key_data 1000 | |
| 2720 | 2071 #endif /* not MC_ALLOC */ |
| 934 | 2072 |
| 2073 Lisp_Object | |
| 1204 | 2074 make_key_data (void) |
| 934 | 2075 { |
| 2076 Lisp_Key_Data *d; | |
| 2077 | |
| 2720 | 2078 #ifdef MC_ALLOC |
| 2079 d = alloc_lrecord_type (Lisp_Key_Data, &lrecord_key_data); | |
| 2080 #else /* not MC_ALLOC */ | |
| 934 | 2081 ALLOCATE_FIXED_TYPE (key_data, Lisp_Key_Data, d); |
| 1204 | 2082 xzero (*d); |
| 934 | 2083 set_lheader_implementation (&d->lheader, &lrecord_key_data); |
| 2720 | 2084 #endif /* not MC_ALLOC */ |
| 1204 | 2085 d->keysym = Qnil; |
| 2086 | |
| 2087 return wrap_key_data (d); | |
| 934 | 2088 } |
| 2089 | |
| 2720 | 2090 #ifndef MC_ALLOC |
| 934 | 2091 DECLARE_FIXED_TYPE_ALLOC (button_data, Lisp_Button_Data); |
| 2092 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_button_data 1000 | |
| 2720 | 2093 #endif /* not MC_ALLOC */ |
| 934 | 2094 |
| 2095 Lisp_Object | |
| 1204 | 2096 make_button_data (void) |
| 934 | 2097 { |
| 2098 Lisp_Button_Data *d; | |
| 2099 | |
| 2720 | 2100 #ifdef MC_ALLOC |
| 2101 d = alloc_lrecord_type (Lisp_Button_Data, &lrecord_button_data); | |
| 2102 #else /* not MC_ALLOC */ | |
| 934 | 2103 ALLOCATE_FIXED_TYPE (button_data, Lisp_Button_Data, d); |
| 1204 | 2104 xzero (*d); |
| 934 | 2105 set_lheader_implementation (&d->lheader, &lrecord_button_data); |
| 2106 | |
| 2720 | 2107 #endif /* not MC_ALLOC */ |
| 1204 | 2108 return wrap_button_data (d); |
| 934 | 2109 } |
| 2110 | |
| 2720 | 2111 #ifndef MC_ALLOC |
| 934 | 2112 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data); |
| 2113 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000 | |
| 2720 | 2114 #endif /* not MC_ALLOC */ |
| 934 | 2115 |
| 2116 Lisp_Object | |
| 1204 | 2117 make_motion_data (void) |
| 934 | 2118 { |
| 2119 Lisp_Motion_Data *d; | |
| 2120 | |
| 2720 | 2121 #ifdef MC_ALLOC |
| 2122 d = alloc_lrecord_type (Lisp_Motion_Data, &lrecord_motion_data); | |
| 2123 #else /* not MC_ALLOC */ | |
| 934 | 2124 ALLOCATE_FIXED_TYPE (motion_data, Lisp_Motion_Data, d); |
| 1204 | 2125 xzero (*d); |
| 934 | 2126 set_lheader_implementation (&d->lheader, &lrecord_motion_data); |
| 2720 | 2127 #endif /* not MC_ALLOC */ |
| 934 | 2128 |
| 1204 | 2129 return wrap_motion_data (d); |
| 934 | 2130 } |
| 2131 | |
| 2720 | 2132 #ifndef MC_ALLOC |
| 934 | 2133 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data); |
| 2134 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_process_data 1000 | |
| 2720 | 2135 #endif /* not MC_ALLOC */ |
| 934 | 2136 |
| 2137 Lisp_Object | |
| 1204 | 2138 make_process_data (void) |
| 934 | 2139 { |
| 2140 Lisp_Process_Data *d; | |
| 2141 | |
| 2720 | 2142 #ifdef MC_ALLOC |
| 2143 d = alloc_lrecord_type (Lisp_Process_Data, &lrecord_process_data); | |
| 2144 #else /* not MC_ALLOC */ | |
| 934 | 2145 ALLOCATE_FIXED_TYPE (process_data, Lisp_Process_Data, d); |
| 1204 | 2146 xzero (*d); |
| 934 | 2147 set_lheader_implementation (&d->lheader, &lrecord_process_data); |
| 1204 | 2148 d->process = Qnil; |
| 2720 | 2149 #endif /* not MC_ALLOC */ |
| 1204 | 2150 |
| 2151 return wrap_process_data (d); | |
| 934 | 2152 } |
| 2153 | |
| 2720 | 2154 #ifndef MC_ALLOC |
| 934 | 2155 DECLARE_FIXED_TYPE_ALLOC (timeout_data, Lisp_Timeout_Data); |
| 2156 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_timeout_data 1000 | |
| 2720 | 2157 #endif /* not MC_ALLOC */ |
| 934 | 2158 |
| 2159 Lisp_Object | |
| 1204 | 2160 make_timeout_data (void) |
| 934 | 2161 { |
| 2162 Lisp_Timeout_Data *d; | |
| 2163 | |
| 2720 | 2164 #ifdef MC_ALLOC |
| 2165 d = alloc_lrecord_type (Lisp_Timeout_Data, &lrecord_timeout_data); | |
| 2166 #else /* not MC_ALLOC */ | |
| 934 | 2167 ALLOCATE_FIXED_TYPE (timeout_data, Lisp_Timeout_Data, d); |
| 1204 | 2168 xzero (*d); |
| 934 | 2169 set_lheader_implementation (&d->lheader, &lrecord_timeout_data); |
| 1204 | 2170 d->function = Qnil; |
| 2171 d->object = Qnil; | |
| 2720 | 2172 #endif /* not MC_ALLOC */ |
| 1204 | 2173 |
| 2174 return wrap_timeout_data (d); | |
| 934 | 2175 } |
| 2176 | |
| 2720 | 2177 #ifndef MC_ALLOC |
| 934 | 2178 DECLARE_FIXED_TYPE_ALLOC (magic_data, Lisp_Magic_Data); |
| 2179 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_data 1000 | |
| 2720 | 2180 #endif /* not MC_ALLOC */ |
| 934 | 2181 |
| 2182 Lisp_Object | |
| 1204 | 2183 make_magic_data (void) |
| 934 | 2184 { |
| 2185 Lisp_Magic_Data *d; | |
| 2186 | |
| 2720 | 2187 #ifdef MC_ALLOC |
| 2188 d = alloc_lrecord_type (Lisp_Magic_Data, &lrecord_magic_data); | |
| 2189 #else /* not MC_ALLOC */ | |
| 934 | 2190 ALLOCATE_FIXED_TYPE (magic_data, Lisp_Magic_Data, d); |
| 1204 | 2191 xzero (*d); |
| 934 | 2192 set_lheader_implementation (&d->lheader, &lrecord_magic_data); |
| 2720 | 2193 #endif /* not MC_ALLOC */ |
| 934 | 2194 |
| 1204 | 2195 return wrap_magic_data (d); |
| 934 | 2196 } |
| 2197 | |
| 2720 | 2198 #ifndef MC_ALLOC |
| 934 | 2199 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data); |
| 2200 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_magic_eval_data 1000 | |
| 2720 | 2201 #endif /* not MC_ALLOC */ |
| 934 | 2202 |
| 2203 Lisp_Object | |
| 1204 | 2204 make_magic_eval_data (void) |
| 934 | 2205 { |
| 2206 Lisp_Magic_Eval_Data *d; | |
| 2207 | |
| 2720 | 2208 #ifdef MC_ALLOC |
| 2209 d = alloc_lrecord_type (Lisp_Magic_Eval_Data, &lrecord_magic_eval_data); | |
| 2210 #else /* not MC_ALLOC */ | |
| 934 | 2211 ALLOCATE_FIXED_TYPE (magic_eval_data, Lisp_Magic_Eval_Data, d); |
| 1204 | 2212 xzero (*d); |
| 934 | 2213 set_lheader_implementation (&d->lheader, &lrecord_magic_eval_data); |
| 1204 | 2214 d->object = Qnil; |
| 2720 | 2215 #endif /* not MC_ALLOC */ |
| 1204 | 2216 |
| 2217 return wrap_magic_eval_data (d); | |
| 934 | 2218 } |
| 2219 | |
| 2720 | 2220 #ifndef MC_ALLOC |
| 934 | 2221 DECLARE_FIXED_TYPE_ALLOC (eval_data, Lisp_Eval_Data); |
| 2222 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_eval_data 1000 | |
| 2720 | 2223 #endif /* not MC_ALLOC */ |
| 934 | 2224 |
| 2225 Lisp_Object | |
| 1204 | 2226 make_eval_data (void) |
| 934 | 2227 { |
| 2228 Lisp_Eval_Data *d; | |
| 2229 | |
| 2720 | 2230 #ifdef MC_ALLOC |
| 2231 d = alloc_lrecord_type (Lisp_Eval_Data, &lrecord_eval_data); | |
| 2232 #else /* not MC_ALLOC */ | |
| 934 | 2233 ALLOCATE_FIXED_TYPE (eval_data, Lisp_Eval_Data, d); |
| 1204 | 2234 xzero (*d); |
| 934 | 2235 set_lheader_implementation (&d->lheader, &lrecord_eval_data); |
| 1204 | 2236 d->function = Qnil; |
| 2237 d->object = Qnil; | |
| 2720 | 2238 #endif /* not MC_ALLOC */ |
| 1204 | 2239 |
| 2240 return wrap_eval_data (d); | |
| 934 | 2241 } |
| 2242 | |
| 2720 | 2243 #ifndef MC_ALLOC |
| 934 | 2244 DECLARE_FIXED_TYPE_ALLOC (misc_user_data, Lisp_Misc_User_Data); |
| 2245 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_misc_user_data 1000 | |
| 2720 | 2246 #endif /* not MC_ALLOC */ |
| 934 | 2247 |
| 2248 Lisp_Object | |
| 1204 | 2249 make_misc_user_data (void) |
| 934 | 2250 { |
| 2251 Lisp_Misc_User_Data *d; | |
| 2252 | |
| 2720 | 2253 #ifdef MC_ALLOC |
| 2254 d = alloc_lrecord_type (Lisp_Misc_User_Data, &lrecord_misc_user_data); | |
| 2255 #else /* not MC_ALLOC */ | |
| 934 | 2256 ALLOCATE_FIXED_TYPE (misc_user_data, Lisp_Misc_User_Data, d); |
| 1204 | 2257 xzero (*d); |
| 934 | 2258 set_lheader_implementation (&d->lheader, &lrecord_misc_user_data); |
| 1204 | 2259 d->function = Qnil; |
| 2260 d->object = Qnil; | |
| 2720 | 2261 #endif /* not MC_ALLOC */ |
| 1204 | 2262 |
| 2263 return wrap_misc_user_data (d); | |
| 934 | 2264 } |
| 1204 | 2265 |
| 2266 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 428 | 2267 |
| 2268 /************************************************************************/ | |
| 2269 /* Marker allocation */ | |
| 2270 /************************************************************************/ | |
| 2271 | |
| 2720 | 2272 #ifndef MC_ALLOC |
| 440 | 2273 DECLARE_FIXED_TYPE_ALLOC (marker, Lisp_Marker); |
| 428 | 2274 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 |
| 2720 | 2275 #endif /* not MC_ALLOC */ |
| 428 | 2276 |
| 2277 DEFUN ("make-marker", Fmake_marker, 0, 0, 0, /* | |
| 2278 Return a new marker which does not point at any place. | |
| 2279 */ | |
| 2280 ()) | |
| 2281 { | |
| 440 | 2282 Lisp_Marker *p; |
| 2283 | |
| 2720 | 2284 #ifdef MC_ALLOC |
| 2285 p = alloc_lrecord_type (Lisp_Marker, &lrecord_marker); | |
| 2286 #else /* not MC_ALLOC */ | |
| 440 | 2287 ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); |
| 442 | 2288 set_lheader_implementation (&p->lheader, &lrecord_marker); |
| 2720 | 2289 #endif /* not MC_ALLOC */ |
| 428 | 2290 p->buffer = 0; |
| 665 | 2291 p->membpos = 0; |
| 428 | 2292 marker_next (p) = 0; |
| 2293 marker_prev (p) = 0; | |
| 2294 p->insertion_type = 0; | |
| 793 | 2295 return wrap_marker (p); |
| 428 | 2296 } |
| 2297 | |
| 2298 Lisp_Object | |
| 2299 noseeum_make_marker (void) | |
| 2300 { | |
| 440 | 2301 Lisp_Marker *p; |
| 2302 | |
| 2720 | 2303 #ifdef MC_ALLOC |
| 2304 p = noseeum_alloc_lrecord_type (Lisp_Marker, &lrecord_marker); | |
| 2305 #else /* not MC_ALLOC */ | |
| 440 | 2306 NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p); |
| 442 | 2307 set_lheader_implementation (&p->lheader, &lrecord_marker); |
| 2720 | 2308 #endif /* not MC_ALLOC */ |
| 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 | |
| 2318 /************************************************************************/ | |
| 2319 /* String allocation */ | |
| 2320 /************************************************************************/ | |
| 2321 | |
| 2322 /* The data for "short" strings generally resides inside of structs of type | |
| 2323 string_chars_block. The Lisp_String structure is allocated just like any | |
| 1204 | 2324 other basic lrecord, and these are freelisted when they get garbage |
| 2325 collected. The data for short strings get compacted, but the data for | |
| 2326 large strings do not. | |
| 428 | 2327 |
| 2328 Previously Lisp_String structures were relocated, but this caused a lot | |
| 2329 of bus-errors because the C code didn't include enough GCPRO's for | |
| 2330 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so | |
| 2331 that the reference would get relocated). | |
| 2332 | |
| 2333 This new method makes things somewhat bigger, but it is MUCH safer. */ | |
| 2334 | |
| 2720 | 2335 #ifndef MC_ALLOC |
| 438 | 2336 DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String); |
| 428 | 2337 /* strings are used and freed quite often */ |
| 2338 /* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */ | |
| 2339 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000 | |
| 2720 | 2340 #endif /* not MC_ALLOC */ |
| 428 | 2341 |
| 2342 static Lisp_Object | |
| 2343 mark_string (Lisp_Object obj) | |
| 2344 { | |
| 793 | 2345 if (CONSP (XSTRING_PLIST (obj)) && EXTENT_INFOP (XCAR (XSTRING_PLIST (obj)))) |
| 2346 flush_cached_extent_info (XCAR (XSTRING_PLIST (obj))); | |
| 2347 return XSTRING_PLIST (obj); | |
| 428 | 2348 } |
| 2349 | |
| 2350 static int | |
| 2286 | 2351 string_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) |
| 428 | 2352 { |
| 2353 Bytecount len; | |
| 2354 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && | |
| 2355 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); | |
| 2356 } | |
| 2357 | |
| 1204 | 2358 static const struct memory_description string_description[] = { |
| 793 | 2359 { XD_BYTECOUNT, offsetof (Lisp_String, size_) }, |
| 2360 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) }, | |
| 440 | 2361 { XD_LISP_OBJECT, offsetof (Lisp_String, plist) }, |
| 428 | 2362 { XD_END } |
| 2363 }; | |
| 2364 | |
| 442 | 2365 /* We store the string's extent info as the first element of the string's |
| 2366 property list; and the string's MODIFF as the first or second element | |
| 2367 of the string's property list (depending on whether the extent info | |
| 2368 is present), but only if the string has been modified. This is ugly | |
| 2369 but it reduces the memory allocated for the string in the vast | |
| 2370 majority of cases, where the string is never modified and has no | |
| 2371 extent info. | |
| 2372 | |
| 2373 #### This means you can't use an int as a key in a string's plist. */ | |
| 2374 | |
| 2375 static Lisp_Object * | |
| 2376 string_plist_ptr (Lisp_Object string) | |
| 2377 { | |
| 793 | 2378 Lisp_Object *ptr = &XSTRING_PLIST (string); |
| 442 | 2379 |
| 2380 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
| 2381 ptr = &XCDR (*ptr); | |
| 2382 if (CONSP (*ptr) && INTP (XCAR (*ptr))) | |
| 2383 ptr = &XCDR (*ptr); | |
| 2384 return ptr; | |
| 2385 } | |
| 2386 | |
| 2387 static Lisp_Object | |
| 2388 string_getprop (Lisp_Object string, Lisp_Object property) | |
| 2389 { | |
| 2390 return external_plist_get (string_plist_ptr (string), property, 0, ERROR_ME); | |
| 2391 } | |
| 2392 | |
| 2393 static int | |
| 2394 string_putprop (Lisp_Object string, Lisp_Object property, Lisp_Object value) | |
| 2395 { | |
| 2396 external_plist_put (string_plist_ptr (string), property, value, 0, ERROR_ME); | |
| 2397 return 1; | |
| 2398 } | |
| 2399 | |
| 2400 static int | |
| 2401 string_remprop (Lisp_Object string, Lisp_Object property) | |
| 2402 { | |
| 2403 return external_remprop (string_plist_ptr (string), property, 0, ERROR_ME); | |
| 2404 } | |
| 2405 | |
| 2406 static Lisp_Object | |
| 2407 string_plist (Lisp_Object string) | |
| 2408 { | |
| 2409 return *string_plist_ptr (string); | |
| 2410 } | |
| 2411 | |
| 2720 | 2412 #ifndef MC_ALLOC |
| 442 | 2413 /* No `finalize', or `hash' methods. |
| 2414 internal_hash() already knows how to hash strings and finalization | |
| 2415 is done with the ADDITIONAL_FREE_string macro, which is the | |
| 2416 standard way to do finalization when using | |
| 2417 SWEEP_FIXED_TYPE_BLOCK(). */ | |
| 2720 | 2418 |
| 934 | 2419 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string, |
| 2420 1, /*dumpable-flag*/ | |
| 2421 mark_string, print_string, | |
| 2422 0, string_equal, 0, | |
| 2423 string_description, | |
| 2424 string_getprop, | |
| 2425 string_putprop, | |
| 2426 string_remprop, | |
| 2427 string_plist, | |
| 2428 Lisp_String); | |
| 2720 | 2429 #endif /* not MC_ALLOC */ |
| 2430 | |
| 428 | 2431 /* String blocks contain this many useful bytes. */ |
| 2432 #define STRING_CHARS_BLOCK_SIZE \ | |
| 814 | 2433 ((Bytecount) (8192 - MALLOC_OVERHEAD - \ |
| 2434 ((2 * sizeof (struct string_chars_block *)) \ | |
| 2435 + sizeof (EMACS_INT)))) | |
| 428 | 2436 /* Block header for small strings. */ |
| 2437 struct string_chars_block | |
| 2438 { | |
| 2439 EMACS_INT pos; | |
| 2440 struct string_chars_block *next; | |
| 2441 struct string_chars_block *prev; | |
| 2442 /* Contents of string_chars_block->string_chars are interleaved | |
| 2443 string_chars structures (see below) and the actual string data */ | |
| 2444 unsigned char string_chars[STRING_CHARS_BLOCK_SIZE]; | |
| 2445 }; | |
| 2446 | |
| 2447 static struct string_chars_block *first_string_chars_block; | |
| 2448 static struct string_chars_block *current_string_chars_block; | |
| 2449 | |
| 2450 /* If SIZE is the length of a string, this returns how many bytes | |
| 2451 * the string occupies in string_chars_block->string_chars | |
| 2452 * (including alignment padding). | |
| 2453 */ | |
| 438 | 2454 #define STRING_FULLSIZE(size) \ |
| 826 | 2455 ALIGN_FOR_TYPE (((size) + 1 + sizeof (Lisp_String *)), Lisp_String *) |
| 428 | 2456 |
| 2457 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE) | |
| 2458 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size))) | |
| 2459 | |
| 454 | 2460 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL) |
| 2461 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL)) | |
| 2462 | |
| 2720 | 2463 #ifdef MC_ALLOC |
| 2464 static void | |
| 2465 finalize_string (void *header, int for_disksave) | |
| 2466 { | |
| 2467 if (!for_disksave) | |
| 2468 { | |
| 2469 Lisp_String *s = (Lisp_String *) header; | |
| 2470 Bytecount size = s->size_; | |
| 2471 if (BIG_STRING_SIZE_P (size)) | |
| 2472 xfree (s->data_, Ibyte *); | |
| 2473 } | |
| 2474 } | |
| 2475 | |
| 2476 DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string, | |
| 2477 1, /*dumpable-flag*/ | |
| 2478 mark_string, print_string, | |
| 2479 finalize_string, | |
| 2480 string_equal, 0, | |
| 2481 string_description, | |
| 2482 string_getprop, | |
| 2483 string_putprop, | |
| 2484 string_remprop, | |
| 2485 string_plist, | |
| 2486 Lisp_String); | |
| 2487 | |
| 2488 #endif /* MC_ALLOC */ | |
| 2489 | |
| 428 | 2490 struct string_chars |
| 2491 { | |
| 438 | 2492 Lisp_String *string; |
| 428 | 2493 unsigned char chars[1]; |
| 2494 }; | |
| 2495 | |
| 2496 struct unused_string_chars | |
| 2497 { | |
| 438 | 2498 Lisp_String *string; |
| 428 | 2499 EMACS_INT fullsize; |
| 2500 }; | |
| 2501 | |
| 2502 static void | |
| 2503 init_string_chars_alloc (void) | |
| 2504 { | |
| 2505 first_string_chars_block = xnew (struct string_chars_block); | |
| 2506 first_string_chars_block->prev = 0; | |
| 2507 first_string_chars_block->next = 0; | |
| 2508 first_string_chars_block->pos = 0; | |
| 2509 current_string_chars_block = first_string_chars_block; | |
| 2510 } | |
| 2511 | |
| 1550 | 2512 static Ibyte * |
| 2513 allocate_big_string_chars (Bytecount length) | |
| 2514 { | |
| 2515 Ibyte *p = xnew_array (Ibyte, length); | |
| 2516 INCREMENT_CONS_COUNTER (length, "string chars"); | |
| 2517 return p; | |
| 2518 } | |
| 2519 | |
| 428 | 2520 static struct string_chars * |
| 793 | 2521 allocate_string_chars_struct (Lisp_Object string_it_goes_with, |
| 814 | 2522 Bytecount fullsize) |
| 428 | 2523 { |
| 2524 struct string_chars *s_chars; | |
| 2525 | |
| 438 | 2526 if (fullsize <= |
| 2527 (countof (current_string_chars_block->string_chars) | |
| 2528 - current_string_chars_block->pos)) | |
| 428 | 2529 { |
| 2530 /* This string can fit in the current string chars block */ | |
| 2531 s_chars = (struct string_chars *) | |
| 2532 (current_string_chars_block->string_chars | |
| 2533 + current_string_chars_block->pos); | |
| 2534 current_string_chars_block->pos += fullsize; | |
| 2535 } | |
| 2536 else | |
| 2537 { | |
| 2538 /* Make a new current string chars block */ | |
| 2539 struct string_chars_block *new_scb = xnew (struct string_chars_block); | |
| 2540 | |
| 2541 current_string_chars_block->next = new_scb; | |
| 2542 new_scb->prev = current_string_chars_block; | |
| 2543 new_scb->next = 0; | |
| 2544 current_string_chars_block = new_scb; | |
| 2545 new_scb->pos = fullsize; | |
| 2546 s_chars = (struct string_chars *) | |
| 2547 current_string_chars_block->string_chars; | |
| 2548 } | |
| 2549 | |
| 793 | 2550 s_chars->string = XSTRING (string_it_goes_with); |
| 428 | 2551 |
| 2552 INCREMENT_CONS_COUNTER (fullsize, "string chars"); | |
| 2553 | |
| 2554 return s_chars; | |
| 2555 } | |
| 2556 | |
| 771 | 2557 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN |
| 2558 void | |
| 2559 sledgehammer_check_ascii_begin (Lisp_Object str) | |
| 2560 { | |
| 2561 Bytecount i; | |
| 2562 | |
| 2563 for (i = 0; i < XSTRING_LENGTH (str); i++) | |
| 2564 { | |
| 826 | 2565 if (!byte_ascii_p (string_byte (str, i))) |
| 771 | 2566 break; |
| 2567 } | |
| 2568 | |
| 2569 assert (i == (Bytecount) XSTRING_ASCII_BEGIN (str) || | |
| 2570 (i > MAX_STRING_ASCII_BEGIN && | |
| 2571 (Bytecount) XSTRING_ASCII_BEGIN (str) == | |
| 2572 (Bytecount) MAX_STRING_ASCII_BEGIN)); | |
| 2573 } | |
| 2574 #endif | |
| 2575 | |
| 2576 /* You do NOT want to be calling this! (And if you do, you must call | |
| 851 | 2577 XSET_STRING_ASCII_BEGIN() after modifying the string.) Use ALLOCA () |
| 771 | 2578 instead and then call make_string() like the rest of the world. */ |
| 2579 | |
| 428 | 2580 Lisp_Object |
| 2581 make_uninit_string (Bytecount length) | |
| 2582 { | |
| 438 | 2583 Lisp_String *s; |
| 814 | 2584 Bytecount fullsize = STRING_FULLSIZE (length); |
| 428 | 2585 |
| 438 | 2586 assert (length >= 0 && fullsize > 0); |
| 428 | 2587 |
| 2720 | 2588 #ifdef MC_ALLOC |
| 2589 s = alloc_lrecord_type (Lisp_String, &lrecord_string); | |
| 2590 #else /* not MC_ALLOC */ | |
| 428 | 2591 /* Allocate the string header */ |
| 438 | 2592 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
| 793 | 2593 xzero (*s); |
| 771 | 2594 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
| 2720 | 2595 #endif /* not MC_ALLOC */ |
| 2596 | |
| 826 | 2597 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize) |
| 2720 | 2598 ? allocate_big_string_chars (length + 1) |
| 2599 : allocate_string_chars_struct (wrap_string (s), | |
| 2600 fullsize)->chars); | |
| 438 | 2601 |
| 826 | 2602 set_lispstringp_length (s, length); |
| 428 | 2603 s->plist = Qnil; |
| 793 | 2604 set_string_byte (wrap_string (s), length, 0); |
| 2605 | |
| 2606 return wrap_string (s); | |
| 428 | 2607 } |
| 2608 | |
| 2609 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
| 2610 static void verify_string_chars_integrity (void); | |
| 2611 #endif | |
| 2612 | |
| 2613 /* Resize the string S so that DELTA bytes can be inserted starting | |
| 2614 at POS. If DELTA < 0, it means deletion starting at POS. If | |
| 2615 POS < 0, resize the string but don't copy any characters. Use | |
| 2616 this if you're planning on completely overwriting the string. | |
| 2617 */ | |
| 2618 | |
| 2619 void | |
| 793 | 2620 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta) |
| 428 | 2621 { |
| 438 | 2622 Bytecount oldfullsize, newfullsize; |
| 428 | 2623 #ifdef VERIFY_STRING_CHARS_INTEGRITY |
| 2624 verify_string_chars_integrity (); | |
| 2625 #endif | |
| 800 | 2626 #ifdef ERROR_CHECK_TEXT |
| 428 | 2627 if (pos >= 0) |
| 2628 { | |
| 793 | 2629 assert (pos <= XSTRING_LENGTH (s)); |
| 428 | 2630 if (delta < 0) |
| 793 | 2631 assert (pos + (-delta) <= XSTRING_LENGTH (s)); |
| 428 | 2632 } |
| 2633 else | |
| 2634 { | |
| 2635 if (delta < 0) | |
| 793 | 2636 assert ((-delta) <= XSTRING_LENGTH (s)); |
| 428 | 2637 } |
| 800 | 2638 #endif /* ERROR_CHECK_TEXT */ |
| 428 | 2639 |
| 2640 if (delta == 0) | |
| 2641 /* simplest case: no size change. */ | |
| 2642 return; | |
| 438 | 2643 |
| 2644 if (pos >= 0 && delta < 0) | |
| 2645 /* If DELTA < 0, the functions below will delete the characters | |
| 2646 before POS. We want to delete characters *after* POS, however, | |
| 2647 so convert this to the appropriate form. */ | |
| 2648 pos += -delta; | |
| 2649 | |
| 793 | 2650 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s)); |
| 2651 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta); | |
| 438 | 2652 |
| 2653 if (BIG_STRING_FULLSIZE_P (oldfullsize)) | |
| 428 | 2654 { |
| 438 | 2655 if (BIG_STRING_FULLSIZE_P (newfullsize)) |
| 428 | 2656 { |
| 440 | 2657 /* Both strings are big. We can just realloc(). |
| 2658 But careful! If the string is shrinking, we have to | |
| 2659 memmove() _before_ realloc(), and if growing, we have to | |
| 2660 memmove() _after_ realloc() - otherwise the access is | |
| 2661 illegal, and we might crash. */ | |
| 793 | 2662 Bytecount len = XSTRING_LENGTH (s) + 1 - pos; |
| 440 | 2663 |
| 2664 if (delta < 0 && pos >= 0) | |
| 793 | 2665 memmove (XSTRING_DATA (s) + pos + delta, |
| 2666 XSTRING_DATA (s) + pos, len); | |
| 2667 XSET_STRING_DATA | |
| 867 | 2668 (s, (Ibyte *) xrealloc (XSTRING_DATA (s), |
| 793 | 2669 XSTRING_LENGTH (s) + delta + 1)); |
| 440 | 2670 if (delta > 0 && pos >= 0) |
| 793 | 2671 memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos, |
| 2672 len); | |
| 1550 | 2673 /* Bump the cons counter. |
| 2674 Conservative; Martin let the increment be delta. */ | |
| 2675 INCREMENT_CONS_COUNTER (newfullsize, "string chars"); | |
| 428 | 2676 } |
| 438 | 2677 else /* String has been demoted from BIG_STRING. */ |
| 428 | 2678 { |
| 867 | 2679 Ibyte *new_data = |
| 438 | 2680 allocate_string_chars_struct (s, newfullsize)->chars; |
| 867 | 2681 Ibyte *old_data = XSTRING_DATA (s); |
| 438 | 2682 |
| 2683 if (pos >= 0) | |
| 2684 { | |
| 2685 memcpy (new_data, old_data, pos); | |
| 2686 memcpy (new_data + pos + delta, old_data + pos, | |
| 793 | 2687 XSTRING_LENGTH (s) + 1 - pos); |
| 438 | 2688 } |
| 793 | 2689 XSET_STRING_DATA (s, new_data); |
| 1726 | 2690 xfree (old_data, Ibyte *); |
| 438 | 2691 } |
| 2692 } | |
| 2693 else /* old string is small */ | |
| 2694 { | |
| 2695 if (oldfullsize == newfullsize) | |
| 2696 { | |
| 2697 /* special case; size change but the necessary | |
| 2698 allocation size won't change (up or down; code | |
| 2699 somewhere depends on there not being any unused | |
| 2700 allocation space, modulo any alignment | |
| 2701 constraints). */ | |
| 428 | 2702 if (pos >= 0) |
| 2703 { | |
| 867 | 2704 Ibyte *addroff = pos + XSTRING_DATA (s); |
| 428 | 2705 |
| 2706 memmove (addroff + delta, addroff, | |
| 2707 /* +1 due to zero-termination. */ | |
| 793 | 2708 XSTRING_LENGTH (s) + 1 - pos); |
| 428 | 2709 } |
| 2710 } | |
| 2711 else | |
| 2712 { | |
| 867 | 2713 Ibyte *old_data = XSTRING_DATA (s); |
| 2714 Ibyte *new_data = | |
| 438 | 2715 BIG_STRING_FULLSIZE_P (newfullsize) |
| 1550 | 2716 ? allocate_big_string_chars (XSTRING_LENGTH (s) + delta + 1) |
| 438 | 2717 : allocate_string_chars_struct (s, newfullsize)->chars; |
| 2718 | |
| 428 | 2719 if (pos >= 0) |
| 2720 { | |
| 438 | 2721 memcpy (new_data, old_data, pos); |
| 2722 memcpy (new_data + pos + delta, old_data + pos, | |
| 793 | 2723 XSTRING_LENGTH (s) + 1 - pos); |
| 428 | 2724 } |
| 793 | 2725 XSET_STRING_DATA (s, new_data); |
| 438 | 2726 |
| 2727 { | |
| 2728 /* We need to mark this chunk of the string_chars_block | |
| 2729 as unused so that compact_string_chars() doesn't | |
| 2730 freak. */ | |
| 2731 struct string_chars *old_s_chars = (struct string_chars *) | |
| 2732 ((char *) old_data - offsetof (struct string_chars, chars)); | |
| 2733 /* Sanity check to make sure we aren't hosed by strange | |
| 2734 alignment/padding. */ | |
| 793 | 2735 assert (old_s_chars->string == XSTRING (s)); |
| 454 | 2736 MARK_STRING_CHARS_AS_FREE (old_s_chars); |
| 438 | 2737 ((struct unused_string_chars *) old_s_chars)->fullsize = |
| 2738 oldfullsize; | |
| 2739 } | |
| 428 | 2740 } |
| 438 | 2741 } |
| 2742 | |
| 793 | 2743 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta); |
| 438 | 2744 /* If pos < 0, the string won't be zero-terminated. |
| 2745 Terminate now just to make sure. */ | |
| 793 | 2746 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0'; |
| 438 | 2747 |
| 2748 if (pos >= 0) | |
| 793 | 2749 /* We also have to adjust all of the extent indices after the |
| 2750 place we did the change. We say "pos - 1" because | |
| 2751 adjust_extents() is exclusive of the starting position | |
| 2752 passed to it. */ | |
| 2753 adjust_extents (s, pos - 1, XSTRING_LENGTH (s), delta); | |
| 428 | 2754 |
| 2755 #ifdef VERIFY_STRING_CHARS_INTEGRITY | |
| 2756 verify_string_chars_integrity (); | |
| 2757 #endif | |
| 2758 } | |
| 2759 | |
| 2760 #ifdef MULE | |
| 2761 | |
| 771 | 2762 /* WARNING: If you modify an existing string, you must call |
| 2763 CHECK_LISP_WRITEABLE() before and bump_string_modiff() afterwards. */ | |
| 428 | 2764 void |
| 867 | 2765 set_string_char (Lisp_Object s, Charcount i, Ichar c) |
| 428 | 2766 { |
| 867 | 2767 Ibyte newstr[MAX_ICHAR_LEN]; |
| 771 | 2768 Bytecount bytoff = string_index_char_to_byte (s, i); |
| 867 | 2769 Bytecount oldlen = itext_ichar_len (XSTRING_DATA (s) + bytoff); |
| 2770 Bytecount newlen = set_itext_ichar (newstr, c); | |
| 428 | 2771 |
| 793 | 2772 sledgehammer_check_ascii_begin (s); |
| 428 | 2773 if (oldlen != newlen) |
| 2774 resize_string (s, bytoff, newlen - oldlen); | |
| 793 | 2775 /* Remember, XSTRING_DATA (s) might have changed so we can't cache it. */ |
| 2776 memcpy (XSTRING_DATA (s) + bytoff, newstr, newlen); | |
| 771 | 2777 if (oldlen != newlen) |
| 2778 { | |
| 793 | 2779 if (newlen > 1 && i <= (Charcount) XSTRING_ASCII_BEGIN (s)) |
| 771 | 2780 /* Everything starting with the new char is no longer part of |
| 2781 ascii_begin */ | |
| 793 | 2782 XSET_STRING_ASCII_BEGIN (s, i); |
| 2783 else if (newlen == 1 && i == (Charcount) XSTRING_ASCII_BEGIN (s)) | |
| 771 | 2784 /* We've extended ascii_begin, and we have to figure out how much by */ |
| 2785 { | |
| 2786 Bytecount j; | |
| 814 | 2787 for (j = (Bytecount) i + 1; j < XSTRING_LENGTH (s); j++) |
| 771 | 2788 { |
| 826 | 2789 if (!byte_ascii_p (XSTRING_DATA (s)[j])) |
| 771 | 2790 break; |
| 2791 } | |
| 814 | 2792 XSET_STRING_ASCII_BEGIN (s, min (j, (Bytecount) MAX_STRING_ASCII_BEGIN)); |
| 771 | 2793 } |
| 2794 } | |
| 793 | 2795 sledgehammer_check_ascii_begin (s); |
| 428 | 2796 } |
| 2797 | |
| 2798 #endif /* MULE */ | |
| 2799 | |
| 2800 DEFUN ("make-string", Fmake_string, 2, 2, 0, /* | |
| 444 | 2801 Return a new string consisting of LENGTH copies of CHARACTER. |
| 2802 LENGTH must be a non-negative integer. | |
| 428 | 2803 */ |
| 444 | 2804 (length, character)) |
| 428 | 2805 { |
| 2806 CHECK_NATNUM (length); | |
| 444 | 2807 CHECK_CHAR_COERCE_INT (character); |
| 428 | 2808 { |
| 867 | 2809 Ibyte init_str[MAX_ICHAR_LEN]; |
| 2810 int len = set_itext_ichar (init_str, XCHAR (character)); | |
| 428 | 2811 Lisp_Object val = make_uninit_string (len * XINT (length)); |
| 2812 | |
| 2813 if (len == 1) | |
| 771 | 2814 { |
| 2815 /* Optimize the single-byte case */ | |
| 2816 memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val)); | |
| 793 | 2817 XSET_STRING_ASCII_BEGIN (val, min (MAX_STRING_ASCII_BEGIN, |
| 2818 len * XINT (length))); | |
| 771 | 2819 } |
| 428 | 2820 else |
| 2821 { | |
| 647 | 2822 EMACS_INT i; |
| 867 | 2823 Ibyte *ptr = XSTRING_DATA (val); |
| 428 | 2824 |
| 2720 | 2825 #ifdef MC_ALLOC |
| 2826 /* Need this for the new allocator: strings are using the uid | |
| 2827 field for ascii_begin. The uid field is set for debugging, | |
| 2828 but the string code assumes here that ascii_begin is always | |
| 2829 zero, when not touched. This assumption is not true with | |
| 2830 the new allocator, so ascii_begin has to be set to zero | |
| 2831 here. */ | |
| 2832 XSET_STRING_ASCII_BEGIN (val, 0); | |
| 2833 #endif /* not MC_ALLOC */ | |
| 2834 | |
| 428 | 2835 for (i = XINT (length); i; i--) |
| 2836 { | |
| 867 | 2837 Ibyte *init_ptr = init_str; |
| 428 | 2838 switch (len) |
| 2839 { | |
| 2840 case 4: *ptr++ = *init_ptr++; | |
| 2841 case 3: *ptr++ = *init_ptr++; | |
| 2842 case 2: *ptr++ = *init_ptr++; | |
| 2843 case 1: *ptr++ = *init_ptr++; | |
| 2844 } | |
| 2845 } | |
| 2846 } | |
| 771 | 2847 sledgehammer_check_ascii_begin (val); |
| 428 | 2848 return val; |
| 2849 } | |
| 2850 } | |
| 2851 | |
| 2852 DEFUN ("string", Fstring, 0, MANY, 0, /* | |
| 2853 Concatenate all the argument characters and make the result a string. | |
| 2854 */ | |
| 2855 (int nargs, Lisp_Object *args)) | |
| 2856 { | |
| 2367 | 2857 Ibyte *storage = alloca_ibytes (nargs * MAX_ICHAR_LEN); |
| 867 | 2858 Ibyte *p = storage; |
| 428 | 2859 |
| 2860 for (; nargs; nargs--, args++) | |
| 2861 { | |
| 2862 Lisp_Object lisp_char = *args; | |
| 2863 CHECK_CHAR_COERCE_INT (lisp_char); | |
| 867 | 2864 p += set_itext_ichar (p, XCHAR (lisp_char)); |
| 428 | 2865 } |
| 2866 return make_string (storage, p - storage); | |
| 2867 } | |
| 2868 | |
| 771 | 2869 /* Initialize the ascii_begin member of a string to the correct value. */ |
| 2870 | |
| 2871 void | |
| 2872 init_string_ascii_begin (Lisp_Object string) | |
| 2873 { | |
| 2874 #ifdef MULE | |
| 2875 int i; | |
| 2876 Bytecount length = XSTRING_LENGTH (string); | |
| 867 | 2877 Ibyte *contents = XSTRING_DATA (string); |
| 771 | 2878 |
| 2879 for (i = 0; i < length; i++) | |
| 2880 { | |
| 826 | 2881 if (!byte_ascii_p (contents[i])) |
| 771 | 2882 break; |
| 2883 } | |
| 793 | 2884 XSET_STRING_ASCII_BEGIN (string, min (i, MAX_STRING_ASCII_BEGIN)); |
| 771 | 2885 #else |
| 793 | 2886 XSET_STRING_ASCII_BEGIN (string, min (XSTRING_LENGTH (string), |
| 2887 MAX_STRING_ASCII_BEGIN)); | |
| 771 | 2888 #endif |
| 2889 sledgehammer_check_ascii_begin (string); | |
| 2890 } | |
| 428 | 2891 |
| 2892 /* Take some raw memory, which MUST already be in internal format, | |
| 2893 and package it up into a Lisp string. */ | |
| 2894 Lisp_Object | |
| 867 | 2895 make_string (const Ibyte *contents, Bytecount length) |
| 428 | 2896 { |
| 2897 Lisp_Object val; | |
| 2898 | |
| 2899 /* Make sure we find out about bad make_string's when they happen */ | |
| 800 | 2900 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
| 428 | 2901 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
| 2902 #endif | |
| 2903 | |
| 2904 val = make_uninit_string (length); | |
| 2905 memcpy (XSTRING_DATA (val), contents, length); | |
| 771 | 2906 init_string_ascii_begin (val); |
| 2907 sledgehammer_check_ascii_begin (val); | |
| 428 | 2908 return val; |
| 2909 } | |
| 2910 | |
| 2911 /* Take some raw memory, encoded in some external data format, | |
| 2912 and convert it into a Lisp string. */ | |
| 2913 Lisp_Object | |
| 442 | 2914 make_ext_string (const Extbyte *contents, EMACS_INT length, |
| 440 | 2915 Lisp_Object coding_system) |
| 428 | 2916 { |
| 440 | 2917 Lisp_Object string; |
| 2918 TO_INTERNAL_FORMAT (DATA, (contents, length), | |
| 2919 LISP_STRING, string, | |
| 2920 coding_system); | |
| 2921 return string; | |
| 428 | 2922 } |
| 2923 | |
| 2924 Lisp_Object | |
| 867 | 2925 build_intstring (const Ibyte *str) |
| 771 | 2926 { |
| 2927 /* Some strlen's crash and burn if passed null. */ | |
| 814 | 2928 return make_string (str, (str ? qxestrlen (str) : (Bytecount) 0)); |
| 771 | 2929 } |
| 2930 | |
| 2931 Lisp_Object | |
| 867 | 2932 build_string (const CIbyte *str) |
| 428 | 2933 { |
| 2934 /* Some strlen's crash and burn if passed null. */ | |
| 867 | 2935 return make_string ((const Ibyte *) str, (str ? strlen (str) : 0)); |
| 428 | 2936 } |
| 2937 | |
| 2938 Lisp_Object | |
| 593 | 2939 build_ext_string (const Extbyte *str, Lisp_Object coding_system) |
| 428 | 2940 { |
| 2941 /* Some strlen's crash and burn if passed null. */ | |
| 2367 | 2942 return make_ext_string ((const Extbyte *) str, |
| 2943 (str ? dfc_external_data_len (str, coding_system) : | |
| 2944 0), | |
| 440 | 2945 coding_system); |
| 428 | 2946 } |
| 2947 | |
| 2948 Lisp_Object | |
| 867 | 2949 build_msg_intstring (const Ibyte *str) |
| 428 | 2950 { |
| 771 | 2951 return build_intstring (GETTEXT (str)); |
| 2952 } | |
| 2953 | |
| 2954 Lisp_Object | |
| 867 | 2955 build_msg_string (const CIbyte *str) |
| 771 | 2956 { |
| 2957 return build_string (CGETTEXT (str)); | |
| 428 | 2958 } |
| 2959 | |
| 2960 Lisp_Object | |
| 867 | 2961 make_string_nocopy (const Ibyte *contents, Bytecount length) |
| 428 | 2962 { |
| 438 | 2963 Lisp_String *s; |
| 428 | 2964 Lisp_Object val; |
| 2965 | |
| 2966 /* Make sure we find out about bad make_string_nocopy's when they happen */ | |
| 800 | 2967 #if defined (ERROR_CHECK_TEXT) && defined (MULE) |
| 428 | 2968 bytecount_to_charcount (contents, length); /* Just for the assertions */ |
| 2969 #endif | |
| 2970 | |
| 2720 | 2971 #ifdef MC_ALLOC |
| 2972 s = alloc_lrecord_type (Lisp_String, &lrecord_string); | |
| 2973 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get | |
| 2974 collected and static data is tried to | |
| 2975 be freed. */ | |
| 2976 #else /* not MC_ALLOC */ | |
| 428 | 2977 /* Allocate the string header */ |
| 438 | 2978 ALLOCATE_FIXED_TYPE (string, Lisp_String, s); |
| 771 | 2979 set_lheader_implementation (&s->u.lheader, &lrecord_string); |
| 2980 SET_C_READONLY_RECORD_HEADER (&s->u.lheader); | |
| 2720 | 2981 #endif /* not MC_ALLOC */ |
| 428 | 2982 s->plist = Qnil; |
| 867 | 2983 set_lispstringp_data (s, (Ibyte *) contents); |
| 826 | 2984 set_lispstringp_length (s, length); |
| 793 | 2985 val = wrap_string (s); |
| 771 | 2986 init_string_ascii_begin (val); |
| 2987 sledgehammer_check_ascii_begin (val); | |
| 2988 | |
| 428 | 2989 return val; |
| 2990 } | |
| 2991 | |
| 2992 | |
| 2720 | 2993 #ifndef MC_ALLOC |
| 428 | 2994 /************************************************************************/ |
| 2995 /* lcrecord lists */ | |
| 2996 /************************************************************************/ | |
| 2997 | |
| 2998 /* Lcrecord lists are used to manage the allocation of particular | |
| 1204 | 2999 sorts of lcrecords, to avoid calling basic_alloc_lcrecord() (and thus |
| 428 | 3000 malloc() and garbage-collection junk) as much as possible. |
| 3001 It is similar to the Blocktype class. | |
| 3002 | |
| 1204 | 3003 See detailed comment in lcrecord.h. |
| 3004 */ | |
| 3005 | |
| 3006 const struct memory_description free_description[] = { | |
| 2551 | 3007 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 }, |
| 1204 | 3008 XD_FLAG_FREE_LISP_OBJECT }, |
| 3009 { XD_END } | |
| 3010 }; | |
| 3011 | |
| 3012 DEFINE_LRECORD_IMPLEMENTATION ("free", free, | |
| 3013 0, /*dumpable-flag*/ | |
| 3014 0, internal_object_printer, | |
| 3015 0, 0, 0, free_description, | |
| 3016 struct free_lcrecord_header); | |
| 3017 | |
| 3018 const struct memory_description lcrecord_list_description[] = { | |
| 2551 | 3019 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 }, |
| 1204 | 3020 XD_FLAG_FREE_LISP_OBJECT }, |
| 3021 { XD_END } | |
| 3022 }; | |
| 428 | 3023 |
| 3024 static Lisp_Object | |
| 3025 mark_lcrecord_list (Lisp_Object obj) | |
| 3026 { | |
| 3027 struct lcrecord_list *list = XLCRECORD_LIST (obj); | |
| 3028 Lisp_Object chain = list->free; | |
| 3029 | |
| 3030 while (!NILP (chain)) | |
| 3031 { | |
| 3032 struct lrecord_header *lheader = XRECORD_LHEADER (chain); | |
| 3033 struct free_lcrecord_header *free_header = | |
| 3034 (struct free_lcrecord_header *) lheader; | |
| 3035 | |
| 442 | 3036 gc_checking_assert |
| 3037 (/* There should be no other pointers to the free list. */ | |
| 3038 ! MARKED_RECORD_HEADER_P (lheader) | |
| 3039 && | |
| 3040 /* Only lcrecords should be here. */ | |
| 1204 | 3041 ! list->implementation->basic_p |
| 442 | 3042 && |
| 3043 /* Only free lcrecords should be here. */ | |
| 3044 free_header->lcheader.free | |
| 3045 && | |
| 3046 /* The type of the lcrecord must be right. */ | |
| 1204 | 3047 lheader->type == lrecord_type_free |
| 442 | 3048 && |
| 3049 /* So must the size. */ | |
| 1204 | 3050 (list->implementation->static_size == 0 || |
| 3051 list->implementation->static_size == list->size) | |
| 442 | 3052 ); |
| 428 | 3053 |
| 3054 MARK_RECORD_HEADER (lheader); | |
| 3055 chain = free_header->chain; | |
| 3056 } | |
| 3057 | |
| 3058 return Qnil; | |
| 3059 } | |
| 3060 | |
| 934 | 3061 DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list, |
| 3062 0, /*dumpable-flag*/ | |
| 3063 mark_lcrecord_list, internal_object_printer, | |
| 1204 | 3064 0, 0, 0, lcrecord_list_description, |
| 3065 struct lcrecord_list); | |
| 934 | 3066 |
| 428 | 3067 Lisp_Object |
| 665 | 3068 make_lcrecord_list (Elemcount size, |
| 442 | 3069 const struct lrecord_implementation *implementation) |
| 428 | 3070 { |
| 1204 | 3071 /* Don't use alloc_lcrecord_type() avoid infinite recursion |
| 3072 allocating this, */ | |
| 3073 struct lcrecord_list *p = (struct lcrecord_list *) | |
| 3074 basic_alloc_lcrecord (sizeof (struct lcrecord_list), | |
| 3075 &lrecord_lcrecord_list); | |
| 428 | 3076 |
| 3077 p->implementation = implementation; | |
| 3078 p->size = size; | |
| 3079 p->free = Qnil; | |
| 793 | 3080 return wrap_lcrecord_list (p); |
| 428 | 3081 } |
| 3082 | |
| 3083 Lisp_Object | |
| 1204 | 3084 alloc_managed_lcrecord (Lisp_Object lcrecord_list) |
| 428 | 3085 { |
| 3086 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
| 3087 if (!NILP (list->free)) | |
| 3088 { | |
| 3089 Lisp_Object val = list->free; | |
| 3090 struct free_lcrecord_header *free_header = | |
| 3091 (struct free_lcrecord_header *) XPNTR (val); | |
| 1204 | 3092 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
| 428 | 3093 |
| 3094 #ifdef ERROR_CHECK_GC | |
| 1204 | 3095 /* Major overkill here. */ |
| 428 | 3096 /* There should be no other pointers to the free list. */ |
| 442 | 3097 assert (! MARKED_RECORD_HEADER_P (lheader)); |
| 428 | 3098 /* Only free lcrecords should be here. */ |
| 3099 assert (free_header->lcheader.free); | |
| 1204 | 3100 assert (lheader->type == lrecord_type_free); |
| 3101 /* Only lcrecords should be here. */ | |
| 3102 assert (! (list->implementation->basic_p)); | |
| 3103 #if 0 /* Not used anymore, now that we set the type of the header to | |
| 3104 lrecord_type_free. */ | |
| 428 | 3105 /* The type of the lcrecord must be right. */ |
| 442 | 3106 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation); |
| 1204 | 3107 #endif /* 0 */ |
| 428 | 3108 /* So must the size. */ |
| 1204 | 3109 assert (list->implementation->static_size == 0 || |
| 3110 list->implementation->static_size == list->size); | |
| 428 | 3111 #endif /* ERROR_CHECK_GC */ |
| 442 | 3112 |
| 428 | 3113 list->free = free_header->chain; |
| 3114 free_header->lcheader.free = 0; | |
| 1204 | 3115 /* Put back the correct type, as we set it to lrecord_type_free. */ |
| 3116 lheader->type = list->implementation->lrecord_type_index; | |
| 3117 zero_sized_lcrecord (free_header, list->size); | |
| 428 | 3118 return val; |
| 3119 } | |
| 3120 else | |
| 1204 | 3121 return wrap_pointer_1 (basic_alloc_lcrecord (list->size, |
| 3122 list->implementation)); | |
| 428 | 3123 } |
| 3124 | |
| 771 | 3125 /* "Free" a Lisp object LCRECORD by placing it on its associated free list |
| 1204 | 3126 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the |
| 771 | 3127 same LCRECORD_LIST as its parameter, it will return an object from the |
| 3128 free list, which may be this one. Be VERY VERY SURE there are no | |
| 3129 pointers to this object hanging around anywhere where they might be | |
| 3130 used! | |
| 3131 | |
| 3132 The first thing this does before making any global state change is to | |
| 3133 call the finalize method of the object, if it exists. */ | |
| 3134 | |
| 428 | 3135 void |
| 3136 free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) | |
| 3137 { | |
| 3138 struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list); | |
| 3139 struct free_lcrecord_header *free_header = | |
| 3140 (struct free_lcrecord_header *) XPNTR (lcrecord); | |
| 442 | 3141 struct lrecord_header *lheader = &free_header->lcheader.lheader; |
| 3142 const struct lrecord_implementation *implementation | |
| 428 | 3143 = LHEADER_IMPLEMENTATION (lheader); |
| 3144 | |
| 771 | 3145 /* Finalizer methods may try to free objects within them, which typically |
| 3146 won't be marked and thus are scheduled for demolition. Putting them | |
| 3147 on the free list would be very bad, as we'd have xfree()d memory in | |
| 3148 the list. Even if for some reason the objects are still live | |
| 3149 (generally a logic error!), we still will have problems putting such | |
| 3150 an object on the free list right now (e.g. we'd have to avoid calling | |
| 3151 the finalizer twice, etc.). So basically, those finalizers should not | |
| 3152 be freeing any objects if during GC. Abort now to catch those | |
| 3153 problems. */ | |
| 3154 gc_checking_assert (!gc_in_progress); | |
| 3155 | |
| 428 | 3156 /* Make sure the size is correct. This will catch, for example, |
| 3157 putting a window configuration on the wrong free list. */ | |
| 1204 | 3158 gc_checking_assert (detagged_lisp_object_size (lheader) == list->size); |
| 771 | 3159 /* Make sure the object isn't already freed. */ |
| 3160 gc_checking_assert (!free_header->lcheader.free); | |
| 2367 | 3161 /* Freeing stuff in dumped memory is bad. If you trip this, you |
| 3162 may need to check for this before freeing. */ | |
| 3163 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); | |
| 771 | 3164 |
| 428 | 3165 if (implementation->finalizer) |
| 3166 implementation->finalizer (lheader, 0); | |
| 1204 | 3167 /* Yes, there are two ways to indicate freeness -- the type is |
| 3168 lrecord_type_free or the ->free flag is set. We used to do only the | |
| 3169 latter; now we do the former as well for KKCC purposes. Probably | |
| 3170 safer in any case, as we will lose quicker this way than keeping | |
| 3171 around an lrecord of apparently correct type but bogus junk in it. */ | |
| 3172 MARK_LRECORD_AS_FREE (lheader); | |
| 428 | 3173 free_header->chain = list->free; |
| 3174 free_header->lcheader.free = 1; | |
| 3175 list->free = lcrecord; | |
| 3176 } | |
| 3177 | |
| 771 | 3178 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)]; |
| 3179 | |
| 3180 void * | |
| 3181 alloc_automanaged_lcrecord (Bytecount size, | |
| 3182 const struct lrecord_implementation *imp) | |
| 3183 { | |
| 3184 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero)) | |
| 3185 all_lcrecord_lists[imp->lrecord_type_index] = | |
| 3186 make_lcrecord_list (size, imp); | |
| 3187 | |
| 1204 | 3188 return XPNTR (alloc_managed_lcrecord |
| 771 | 3189 (all_lcrecord_lists[imp->lrecord_type_index])); |
| 3190 } | |
| 3191 | |
| 3192 void | |
| 3193 free_lcrecord (Lisp_Object rec) | |
| 3194 { | |
| 3195 int type = XRECORD_LHEADER (rec)->type; | |
| 3196 | |
| 3197 assert (!EQ (all_lcrecord_lists[type], Qzero)); | |
| 3198 | |
| 3199 free_managed_lcrecord (all_lcrecord_lists[type], rec); | |
| 3200 } | |
| 2720 | 3201 #endif /* not MC_ALLOC */ |
| 428 | 3202 |
| 3203 | |
| 3204 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /* | |
| 3205 Kept for compatibility, returns its argument. | |
| 3206 Old: | |
| 3207 Make a copy of OBJECT in pure storage. | |
| 3208 Recursively copies contents of vectors and cons cells. | |
| 3209 Does not copy symbols. | |
| 3210 */ | |
| 444 | 3211 (object)) |
| 428 | 3212 { |
| 444 | 3213 return object; |
| 428 | 3214 } |
| 3215 | |
| 3216 | |
| 3217 /************************************************************************/ | |
| 3218 /* Garbage Collection */ | |
| 3219 /************************************************************************/ | |
| 3220 | |
| 442 | 3221 /* All the built-in lisp object types are enumerated in `enum lrecord_type'. |
| 3222 Additional ones may be defined by a module (none yet). We leave some | |
| 3223 room in `lrecord_implementations_table' for such new lisp object types. */ | |
| 647 | 3224 const struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; |
| 3225 int lrecord_type_count = lrecord_type_last_built_in_type; | |
| 1676 | 3226 #ifndef USE_KKCC |
| 442 | 3227 /* Object marker functions are in the lrecord_implementation structure. |
| 3228 But copying them to a parallel array is much more cache-friendly. | |
| 3229 This hack speeds up (garbage-collect) by about 5%. */ | |
| 3230 Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); | |
| 1676 | 3231 #endif /* not USE_KKCC */ |
| 428 | 3232 |
| 3233 struct gcpro *gcprolist; | |
| 3234 | |
| 771 | 3235 /* We want the staticpro list relocated, but not the pointers found |
| 3236 therein, because they refer to locations in the global data segment, not | |
| 3237 in the heap; we only dump heap objects. Hence we use a trivial | |
| 3238 description, as for pointerless objects. (Note that the data segment | |
| 3239 objects, which are global variables like Qfoo or Vbar, themselves are | |
| 3240 pointers to heap objects. Each needs to be described to pdump as a | |
| 3241 "root pointer"; this happens in the call to staticpro(). */ | |
| 1204 | 3242 static const struct memory_description staticpro_description_1[] = { |
| 452 | 3243 { XD_END } |
| 3244 }; | |
| 3245 | |
| 1204 | 3246 static const struct sized_memory_description staticpro_description = { |
| 452 | 3247 sizeof (Lisp_Object *), |
| 3248 staticpro_description_1 | |
| 3249 }; | |
| 3250 | |
| 1204 | 3251 static const struct memory_description staticpros_description_1[] = { |
| 452 | 3252 XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description), |
| 3253 { XD_END } | |
| 3254 }; | |
| 3255 | |
| 1204 | 3256 static const struct sized_memory_description staticpros_description = { |
| 452 | 3257 sizeof (Lisp_Object_ptr_dynarr), |
| 3258 staticpros_description_1 | |
| 3259 }; | |
| 3260 | |
| 771 | 3261 #ifdef DEBUG_XEMACS |
| 3262 | |
| 1204 | 3263 static const struct memory_description staticpro_one_name_description_1[] = { |
| 2367 | 3264 { XD_ASCII_STRING, 0 }, |
| 771 | 3265 { XD_END } |
| 3266 }; | |
| 3267 | |
| 1204 | 3268 static const struct sized_memory_description staticpro_one_name_description = { |
| 771 | 3269 sizeof (char *), |
| 3270 staticpro_one_name_description_1 | |
| 3271 }; | |
| 3272 | |
| 1204 | 3273 static const struct memory_description staticpro_names_description_1[] = { |
| 771 | 3274 XD_DYNARR_DESC (char_ptr_dynarr, &staticpro_one_name_description), |
| 3275 { XD_END } | |
| 3276 }; | |
| 3277 | |
| 1204 | 3278 |
| 3279 extern const struct sized_memory_description staticpro_names_description; | |
| 3280 | |
| 3281 const struct sized_memory_description staticpro_names_description = { | |
| 771 | 3282 sizeof (char_ptr_dynarr), |
| 3283 staticpro_names_description_1 | |
| 3284 }; | |
| 3285 | |
| 3286 /* Help debug crashes gc-marking a staticpro'ed object. */ | |
| 3287 | |
| 3288 Lisp_Object_ptr_dynarr *staticpros; | |
| 3289 char_ptr_dynarr *staticpro_names; | |
| 3290 | |
| 3291 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3292 garbage collection, and for dumping. */ | |
| 3293 void | |
| 3294 staticpro_1 (Lisp_Object *varaddress, char *varname) | |
| 3295 { | |
| 3296 Dynarr_add (staticpros, varaddress); | |
| 3297 Dynarr_add (staticpro_names, varname); | |
| 1204 | 3298 dump_add_root_lisp_object (varaddress); |
| 771 | 3299 } |
| 3300 | |
| 3301 | |
| 3302 Lisp_Object_ptr_dynarr *staticpros_nodump; | |
| 3303 char_ptr_dynarr *staticpro_nodump_names; | |
| 3304 | |
| 3305 /* Mark the Lisp_Object at heap VARADDRESS as a root object for | |
| 3306 garbage collection, but not for dumping. (See below.) */ | |
| 3307 void | |
| 3308 staticpro_nodump_1 (Lisp_Object *varaddress, char *varname) | |
| 3309 { | |
| 3310 Dynarr_add (staticpros_nodump, varaddress); | |
| 3311 Dynarr_add (staticpro_nodump_names, varname); | |
| 3312 } | |
| 3313 | |
| 996 | 3314 #ifdef HAVE_SHLIB |
| 3315 /* Stop treating the Lisp_Object at non-heap VARADDRESS as a root object | |
| 3316 for garbage collection, but not for dumping. */ | |
| 3317 void | |
| 3318 unstaticpro_nodump_1 (Lisp_Object *varaddress, char *varname) | |
| 3319 { | |
| 3320 Dynarr_delete_object (staticpros, varaddress); | |
| 3321 Dynarr_delete_object (staticpro_names, varname); | |
| 3322 } | |
| 3323 #endif | |
| 3324 | |
| 771 | 3325 #else /* not DEBUG_XEMACS */ |
| 3326 | |
| 452 | 3327 Lisp_Object_ptr_dynarr *staticpros; |
| 3328 | |
| 3329 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3330 garbage collection, and for dumping. */ | |
| 428 | 3331 void |
| 3332 staticpro (Lisp_Object *varaddress) | |
| 3333 { | |
| 452 | 3334 Dynarr_add (staticpros, varaddress); |
| 1204 | 3335 dump_add_root_lisp_object (varaddress); |
| 428 | 3336 } |
| 3337 | |
| 442 | 3338 |
| 452 | 3339 Lisp_Object_ptr_dynarr *staticpros_nodump; |
| 3340 | |
| 771 | 3341 /* Mark the Lisp_Object at heap VARADDRESS as a root object for garbage |
| 3342 collection, but not for dumping. This is used for objects where the | |
| 3343 only sure pointer is in the heap (rather than in the global data | |
| 3344 segment, as must be the case for pdump root pointers), but not inside of | |
| 3345 another Lisp object (where it will be marked as a result of that Lisp | |
| 3346 object's mark method). The call to staticpro_nodump() must occur *BOTH* | |
| 3347 at initialization time and at "reinitialization" time (startup, after | |
| 3348 pdump load.) (For example, this is the case with the predicate symbols | |
| 3349 for specifier and coding system types. The pointer to this symbol is | |
| 3350 inside of a methods structure, which is allocated on the heap. The | |
| 3351 methods structure will be written out to the pdump data file, and may be | |
| 3352 reloaded at a different address.) | |
| 3353 | |
| 3354 #### The necessity for reinitialization is a bug in pdump. Pdump should | |
| 3355 automatically regenerate the staticpro()s for these symbols when it | |
| 3356 loads the data in. */ | |
| 3357 | |
| 428 | 3358 void |
| 3359 staticpro_nodump (Lisp_Object *varaddress) | |
| 3360 { | |
| 452 | 3361 Dynarr_add (staticpros_nodump, varaddress); |
| 428 | 3362 } |
| 3363 | |
| 996 | 3364 #ifdef HAVE_SHLIB |
| 3365 /* Unmark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3366 garbage collection, but not for dumping. */ | |
| 3367 void | |
| 3368 unstaticpro_nodump (Lisp_Object *varaddress) | |
| 3369 { | |
| 3370 Dynarr_delete_object (staticpros, varaddress); | |
| 3371 } | |
| 3372 #endif | |
| 3373 | |
| 771 | 3374 #endif /* not DEBUG_XEMACS */ |
| 3375 | |
| 2720 | 3376 |
| 3377 | |
| 3378 | |
| 3379 | |
| 3380 #ifdef MC_ALLOC | |
| 3381 static const struct memory_description mcpro_description_1[] = { | |
| 3382 { XD_END } | |
| 3383 }; | |
| 3384 | |
| 3385 static const struct sized_memory_description mcpro_description = { | |
| 3386 sizeof (Lisp_Object *), | |
| 3387 mcpro_description_1 | |
| 3388 }; | |
| 3389 | |
| 3390 static const struct memory_description mcpros_description_1[] = { | |
| 3391 XD_DYNARR_DESC (Lisp_Object_dynarr, &mcpro_description), | |
| 3392 { XD_END } | |
| 3393 }; | |
| 3394 | |
| 3395 static const struct sized_memory_description mcpros_description = { | |
| 3396 sizeof (Lisp_Object_dynarr), | |
| 3397 mcpros_description_1 | |
| 3398 }; | |
| 3399 | |
| 3400 #ifdef DEBUG_XEMACS | |
| 3401 | |
| 3402 static const struct memory_description mcpro_one_name_description_1[] = { | |
| 3403 { XD_ASCII_STRING, 0 }, | |
| 3404 { XD_END } | |
| 3405 }; | |
| 3406 | |
| 3407 static const struct sized_memory_description mcpro_one_name_description = { | |
| 3408 sizeof (char *), | |
| 3409 mcpro_one_name_description_1 | |
| 3410 }; | |
| 3411 | |
| 3412 static const struct memory_description mcpro_names_description_1[] = { | |
| 3413 XD_DYNARR_DESC (char_ptr_dynarr, &mcpro_one_name_description), | |
| 3414 { XD_END } | |
| 3415 }; | |
| 3416 | |
| 3417 extern const struct sized_memory_description mcpro_names_description; | |
| 3418 | |
| 3419 const struct sized_memory_description mcpro_names_description = { | |
| 3420 sizeof (char_ptr_dynarr), | |
| 3421 mcpro_names_description_1 | |
| 3422 }; | |
| 3423 | |
| 3424 /* Help debug crashes gc-marking a mcpro'ed object. */ | |
| 3425 | |
| 3426 Lisp_Object_dynarr *mcpros; | |
| 3427 char_ptr_dynarr *mcpro_names; | |
| 3428 | |
| 3429 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3430 garbage collection, and for dumping. */ | |
| 3431 void | |
| 3432 mcpro_1 (Lisp_Object varaddress, char *varname) | |
| 3433 { | |
| 3434 Dynarr_add (mcpros, varaddress); | |
| 3435 Dynarr_add (mcpro_names, varname); | |
| 3436 } | |
| 3437 | |
| 3438 #else /* not DEBUG_XEMACS */ | |
| 3439 | |
| 3440 Lisp_Object_dynarr *mcpros; | |
| 3441 | |
| 3442 /* Mark the Lisp_Object at non-heap VARADDRESS as a root object for | |
| 3443 garbage collection, and for dumping. */ | |
| 3444 void | |
| 3445 mcpro (Lisp_Object varaddress) | |
| 3446 { | |
| 3447 Dynarr_add (mcpros, varaddress); | |
| 3448 } | |
| 3449 | |
| 3450 #endif /* not DEBUG_XEMACS */ | |
| 3451 #endif /* MC_ALLOC */ | |
| 3452 | |
| 442 | 3453 #ifdef ERROR_CHECK_GC |
| 2720 | 3454 #ifdef MC_ALLOC |
| 3455 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ | |
| 3456 struct lrecord_header * GCLI_lh = (lheader); \ | |
| 3457 assert (GCLI_lh != 0); \ | |
| 3458 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \ | |
| 3459 } while (0) | |
| 3460 #else /* not MC_ALLOC */ | |
| 442 | 3461 #define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \ |
| 3462 struct lrecord_header * GCLI_lh = (lheader); \ | |
| 3463 assert (GCLI_lh != 0); \ | |
| 647 | 3464 assert (GCLI_lh->type < (unsigned int) lrecord_type_count); \ |
| 442 | 3465 assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) || \ |
| 3466 (MARKED_RECORD_HEADER_P (GCLI_lh) && \ | |
| 3467 LISP_READONLY_RECORD_HEADER_P (GCLI_lh))); \ | |
| 3468 } while (0) | |
| 2720 | 3469 #endif /* not MC_ALLOC */ |
| 442 | 3470 #else |
| 3471 #define GC_CHECK_LHEADER_INVARIANTS(lheader) | |
| 3472 #endif | |
| 3473 | |
| 934 | 3474 |
| 1204 | 3475 static const struct memory_description lisp_object_description_1[] = { |
| 3476 { XD_LISP_OBJECT, 0 }, | |
| 3477 { XD_END } | |
| 3478 }; | |
| 3479 | |
| 3480 const struct sized_memory_description lisp_object_description = { | |
| 3481 sizeof (Lisp_Object), | |
| 3482 lisp_object_description_1 | |
| 3483 }; | |
| 3484 | |
| 3485 #if defined (USE_KKCC) || defined (PDUMP) | |
| 934 | 3486 |
| 3487 /* This function extracts the value of a count variable described somewhere | |
| 3488 else in the description. It is converted corresponding to the type */ | |
| 1204 | 3489 EMACS_INT |
| 3490 lispdesc_indirect_count_1 (EMACS_INT code, | |
| 3491 const struct memory_description *idesc, | |
| 3492 const void *idata) | |
| 934 | 3493 { |
| 3494 EMACS_INT count; | |
| 3495 const void *irdata; | |
| 3496 | |
| 3497 int line = XD_INDIRECT_VAL (code); | |
| 3498 int delta = XD_INDIRECT_DELTA (code); | |
| 3499 | |
| 1204 | 3500 irdata = ((char *) idata) + |
| 3501 lispdesc_indirect_count (idesc[line].offset, idesc, idata); | |
| 934 | 3502 switch (idesc[line].type) |
| 3503 { | |
| 3504 case XD_BYTECOUNT: | |
| 1204 | 3505 count = * (Bytecount *) irdata; |
| 934 | 3506 break; |
| 3507 case XD_ELEMCOUNT: | |
| 1204 | 3508 count = * (Elemcount *) irdata; |
| 934 | 3509 break; |
| 3510 case XD_HASHCODE: | |
| 1204 | 3511 count = * (Hashcode *) irdata; |
| 934 | 3512 break; |
| 3513 case XD_INT: | |
| 1204 | 3514 count = * (int *) irdata; |
| 934 | 3515 break; |
| 3516 case XD_LONG: | |
| 1204 | 3517 count = * (long *) irdata; |
| 934 | 3518 break; |
| 3519 default: | |
| 3520 stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n", | |
| 1204 | 3521 idesc[line].type, line, (long) code); |
| 2666 | 3522 #if defined(USE_KKCC) && defined(DEBUG_XEMACS) |
| 2645 | 3523 if (gc_in_progress) |
| 3524 kkcc_backtrace (); | |
| 3525 #endif | |
| 1204 | 3526 #ifdef PDUMP |
| 3527 if (in_pdump) | |
| 3528 pdump_backtrace (); | |
| 3529 #endif | |
| 934 | 3530 count = 0; /* warning suppression */ |
| 2500 | 3531 ABORT (); |
| 934 | 3532 } |
| 3533 count += delta; | |
| 3534 return count; | |
| 3535 } | |
| 3536 | |
| 1204 | 3537 /* SDESC is a "description map" (basically, a list of offsets used for |
| 3538 successive indirections) and OBJ is the first object to indirect off of. | |
| 3539 Return the description ultimately found. */ | |
| 3540 | |
| 3541 const struct sized_memory_description * | |
| 3542 lispdesc_indirect_description_1 (const void *obj, | |
| 3543 const struct sized_memory_description *sdesc) | |
| 934 | 3544 { |
| 3545 int pos; | |
| 3546 | |
| 1204 | 3547 for (pos = 0; sdesc[pos].size >= 0; pos++) |
| 3548 obj = * (const void **) ((const char *) obj + sdesc[pos].size); | |
| 3549 | |
| 3550 return (const struct sized_memory_description *) obj; | |
| 3551 } | |
| 3552 | |
| 3553 /* Compute the size of the data at RDATA, described by a single entry | |
| 3554 DESC1 in a description array. OBJ and DESC are used for | |
| 3555 XD_INDIRECT references. */ | |
| 3556 | |
| 3557 static Bytecount | |
| 3558 lispdesc_one_description_line_size (void *rdata, | |
| 3559 const struct memory_description *desc1, | |
| 3560 const void *obj, | |
| 3561 const struct memory_description *desc) | |
| 3562 { | |
| 3563 union_switcheroo: | |
| 3564 switch (desc1->type) | |
| 934 | 3565 { |
| 1204 | 3566 case XD_LISP_OBJECT_ARRAY: |
| 3567 { | |
| 3568 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); | |
| 3569 return (val * sizeof (Lisp_Object)); | |
| 3570 } | |
| 3571 case XD_LISP_OBJECT: | |
| 3572 case XD_LO_LINK: | |
| 3573 return sizeof (Lisp_Object); | |
| 3574 case XD_OPAQUE_PTR: | |
| 3575 return sizeof (void *); | |
| 2367 | 3576 case XD_BLOCK_PTR: |
| 1204 | 3577 { |
| 3578 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); | |
| 3579 return val * sizeof (void *); | |
| 3580 } | |
| 2367 | 3581 case XD_BLOCK_ARRAY: |
| 1204 | 3582 { |
| 3583 EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj); | |
| 3584 | |
| 3585 return (val * | |
| 2367 | 3586 lispdesc_block_size |
| 2551 | 3587 (rdata, |
| 3588 lispdesc_indirect_description (obj, desc1->data2.descr))); | |
| 1204 | 3589 } |
| 3590 case XD_OPAQUE_DATA_PTR: | |
| 3591 return sizeof (void *); | |
| 3592 case XD_UNION_DYNAMIC_SIZE: | |
| 3593 { | |
| 3594 /* If an explicit size was given in the first-level structure | |
| 3595 description, use it; else compute size based on current union | |
| 3596 constant. */ | |
| 3597 const struct sized_memory_description *sdesc = | |
| 2551 | 3598 lispdesc_indirect_description (obj, desc1->data2.descr); |
| 1204 | 3599 if (sdesc->size) |
| 3600 return sdesc->size; | |
| 3601 else | |
| 3602 { | |
| 3603 desc1 = lispdesc_process_xd_union (desc1, desc, obj); | |
| 3604 if (desc1) | |
| 3605 goto union_switcheroo; | |
| 934 | 3606 break; |
| 1204 | 3607 } |
| 3608 } | |
| 3609 case XD_UNION: | |
| 3610 { | |
| 3611 /* If an explicit size was given in the first-level structure | |
| 3612 description, use it; else compute size based on maximum of all | |
| 3613 possible structures. */ | |
| 3614 const struct sized_memory_description *sdesc = | |
| 2551 | 3615 lispdesc_indirect_description (obj, desc1->data2.descr); |
| 1204 | 3616 if (sdesc->size) |
| 3617 return sdesc->size; | |
| 3618 else | |
| 3619 { | |
| 3620 int count; | |
| 3621 Bytecount max_size = -1, size; | |
| 3622 | |
| 3623 desc1 = sdesc->description; | |
| 3624 | |
| 3625 for (count = 0; desc1[count].type != XD_END; count++) | |
| 3626 { | |
| 3627 size = lispdesc_one_description_line_size (rdata, | |
| 3628 &desc1[count], | |
| 3629 obj, desc); | |
| 3630 if (size > max_size) | |
| 3631 max_size = size; | |
| 3632 } | |
| 3633 return max_size; | |
| 3634 } | |
| 934 | 3635 } |
| 2367 | 3636 case XD_ASCII_STRING: |
| 1204 | 3637 return sizeof (void *); |
| 3638 case XD_DOC_STRING: | |
| 3639 return sizeof (void *); | |
| 3640 case XD_INT_RESET: | |
| 3641 return sizeof (int); | |
| 3642 case XD_BYTECOUNT: | |
| 3643 return sizeof (Bytecount); | |
| 3644 case XD_ELEMCOUNT: | |
| 3645 return sizeof (Elemcount); | |
| 3646 case XD_HASHCODE: | |
| 3647 return sizeof (Hashcode); | |
| 3648 case XD_INT: | |
| 3649 return sizeof (int); | |
| 3650 case XD_LONG: | |
| 3651 return sizeof (long); | |
| 3652 default: | |
| 3653 stderr_out ("Unsupported dump type : %d\n", desc1->type); | |
| 2500 | 3654 ABORT (); |
| 934 | 3655 } |
| 3656 | |
| 1204 | 3657 return 0; |
| 934 | 3658 } |
| 3659 | |
| 3660 | |
| 1204 | 3661 /* Return the size of the memory block (NOT necessarily a structure!) |
| 3662 described by SDESC and pointed to by OBJ. If SDESC records an | |
| 3663 explicit size (i.e. non-zero), it is simply returned; otherwise, | |
| 3664 the size is calculated by the maximum offset and the size of the | |
| 3665 object at that offset, rounded up to the maximum alignment. In | |
| 3666 this case, we may need the object, for example when retrieving an | |
| 3667 "indirect count" of an inlined array (the count is not constant, | |
| 3668 but is specified by one of the elements of the memory block). (It | |
| 3669 is generally not a problem if we return an overly large size -- we | |
| 3670 will simply end up reserving more space than necessary; but if the | |
| 3671 size is too small we could be in serious trouble, in particular | |
| 3672 with nested inlined structures, where there may be alignment | |
| 3673 padding in the middle of a block. #### In fact there is an (at | |
| 3674 least theoretical) problem with an overly large size -- we may | |
| 3675 trigger a protection fault when reading from invalid memory. We | |
| 3676 need to handle this -- perhaps in a stupid but dependable way, | |
| 3677 i.e. by trapping SIGSEGV and SIGBUS.) */ | |
| 3678 | |
| 3679 Bytecount | |
| 2367 | 3680 lispdesc_block_size_1 (const void *obj, Bytecount size, |
| 3681 const struct memory_description *desc) | |
| 934 | 3682 { |
| 1204 | 3683 EMACS_INT max_offset = -1; |
| 934 | 3684 int max_offset_pos = -1; |
| 3685 int pos; | |
| 2367 | 3686 |
| 3687 if (size) | |
| 3688 return size; | |
| 934 | 3689 |
| 3690 for (pos = 0; desc[pos].type != XD_END; pos++) | |
| 3691 { | |
| 1204 | 3692 EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj); |
| 3693 if (offset == max_offset) | |
| 934 | 3694 { |
| 3695 stderr_out ("Two relocatable elements at same offset?\n"); | |
| 2500 | 3696 ABORT (); |
| 934 | 3697 } |
| 1204 | 3698 else if (offset > max_offset) |
| 934 | 3699 { |
| 1204 | 3700 max_offset = offset; |
| 934 | 3701 max_offset_pos = pos; |
| 3702 } | |
| 3703 } | |
| 3704 | |
| 3705 if (max_offset_pos < 0) | |
| 3706 return 0; | |
| 3707 | |
| 1204 | 3708 { |
| 3709 Bytecount size_at_max; | |
| 3710 size_at_max = | |
| 3711 lispdesc_one_description_line_size ((char *) obj + max_offset, | |
| 3712 &desc[max_offset_pos], obj, desc); | |
| 3713 | |
| 3714 /* We have no way of knowing the required alignment for this structure, | |
| 3715 so just make it maximally aligned. */ | |
| 3716 return MAX_ALIGN_SIZE (max_offset + size_at_max); | |
| 3717 } | |
| 3718 } | |
| 3719 | |
| 3720 #endif /* defined (USE_KKCC) || defined (PDUMP) */ | |
| 3721 | |
| 2720 | 3722 #ifdef MC_ALLOC |
| 3723 #define GC_CHECK_NOT_FREE(lheader) \ | |
| 3724 gc_checking_assert (! LRECORD_FREE_P (lheader)); | |
| 3725 #else /* MC_ALLOC */ | |
| 1276 | 3726 #define GC_CHECK_NOT_FREE(lheader) \ |
| 2720 | 3727 gc_checking_assert (! LRECORD_FREE_P (lheader)); \ |
| 1276 | 3728 gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ |
| 3729 ! ((struct lcrecord_header *) lheader)->free) | |
| 2720 | 3730 #endif /* MC_ALLOC */ |
| 1276 | 3731 |
| 1204 | 3732 #ifdef USE_KKCC |
| 3733 /* The following functions implement the new mark algorithm. | |
| 3734 They mark objects according to their descriptions. They | |
| 3735 are modeled on the corresponding pdumper procedures. */ | |
| 3736 | |
| 2666 | 3737 #ifdef DEBUG_XEMACS |
| 3738 /* The backtrace for the KKCC mark functions. */ | |
| 3739 #define KKCC_INIT_BT_STACK_SIZE 4096 | |
| 1676 | 3740 |
| 3741 typedef struct | |
| 3742 { | |
| 2645 | 3743 void *obj; |
| 3744 const struct memory_description *desc; | |
| 3745 int pos; | |
| 2666 | 3746 } kkcc_bt_stack_entry; |
| 3747 | |
| 3748 static kkcc_bt_stack_entry *kkcc_bt; | |
| 3749 static int kkcc_bt_stack_size; | |
| 2645 | 3750 static int kkcc_bt_depth = 0; |
| 3751 | |
| 2666 | 3752 static void |
| 3753 kkcc_bt_init (void) | |
| 3754 { | |
| 3755 kkcc_bt_depth = 0; | |
| 3756 kkcc_bt_stack_size = KKCC_INIT_BT_STACK_SIZE; | |
| 3757 kkcc_bt = (kkcc_bt_stack_entry *) | |
| 3758 malloc (kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry)); | |
| 3759 if (!kkcc_bt) | |
| 3760 { | |
| 3761 stderr_out ("KKCC backtrace stack init failed for size %d\n", | |
| 3762 kkcc_bt_stack_size); | |
| 3763 ABORT (); | |
| 3764 } | |
| 3765 } | |
| 2645 | 3766 |
| 3767 void | |
| 3768 kkcc_backtrace (void) | |
| 3769 { | |
| 3770 int i; | |
| 3771 stderr_out ("KKCC mark stack backtrace :\n"); | |
| 3772 for (i = kkcc_bt_depth - 1; i >= 0; i--) | |
| 3773 { | |
| 2650 | 3774 Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj); |
| 2645 | 3775 stderr_out (" [%d]", i); |
| 2720 | 3776 #ifdef MC_ALLOC |
| 3777 if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type) | |
| 3778 #else /* not MC_ALLOC */ | |
| 2650 | 3779 if ((XRECORD_LHEADER (obj)->type >= lrecord_type_free) |
| 2720 | 3780 #endif /* not MC_ALLOC */ |
| 2650 | 3781 || (!LRECORDP (obj)) |
| 3782 || (!XRECORD_LHEADER_IMPLEMENTATION (obj))) | |
| 2645 | 3783 { |
| 3784 stderr_out (" non Lisp Object"); | |
| 3785 } | |
| 3786 else | |
| 3787 { | |
| 3788 stderr_out (" %s", | |
| 2650 | 3789 XRECORD_LHEADER_IMPLEMENTATION (obj)->name); |
| 2645 | 3790 } |
| 3791 stderr_out (" (addr: 0x%x, desc: 0x%x, ", | |
| 3792 (int) kkcc_bt[i].obj, | |
| 3793 (int) kkcc_bt[i].desc); | |
| 3794 if (kkcc_bt[i].pos >= 0) | |
| 3795 stderr_out ("pos: %d)\n", kkcc_bt[i].pos); | |
| 3796 else | |
| 3797 stderr_out ("root set)\n"); | |
| 3798 } | |
| 3799 } | |
| 3800 | |
| 3801 static void | |
| 2666 | 3802 kkcc_bt_stack_realloc (void) |
| 3803 { | |
| 3804 kkcc_bt_stack_size *= 2; | |
| 3805 kkcc_bt = (kkcc_bt_stack_entry *) | |
| 3806 realloc (kkcc_bt, kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry)); | |
| 3807 if (!kkcc_bt) | |
| 3808 { | |
| 3809 stderr_out ("KKCC backtrace stack realloc failed for size %d\n", | |
| 3810 kkcc_bt_stack_size); | |
| 3811 ABORT (); | |
| 3812 } | |
| 3813 } | |
| 3814 | |
| 3815 static void | |
| 3816 kkcc_bt_free (void) | |
| 3817 { | |
| 3818 free (kkcc_bt); | |
| 3819 kkcc_bt = 0; | |
| 3820 kkcc_bt_stack_size = 0; | |
| 3821 } | |
| 3822 | |
| 3823 static void | |
| 2645 | 3824 kkcc_bt_push (void *obj, const struct memory_description *desc, |
| 3825 int level, int pos) | |
| 3826 { | |
| 3827 kkcc_bt_depth = level; | |
| 3828 kkcc_bt[kkcc_bt_depth].obj = obj; | |
| 3829 kkcc_bt[kkcc_bt_depth].desc = desc; | |
| 3830 kkcc_bt[kkcc_bt_depth].pos = pos; | |
| 3831 kkcc_bt_depth++; | |
| 2666 | 3832 if (kkcc_bt_depth >= kkcc_bt_stack_size) |
| 3833 kkcc_bt_stack_realloc (); | |
| 2645 | 3834 } |
| 3835 | |
| 3836 #else /* not DEBUG_XEMACS */ | |
| 2666 | 3837 #define kkcc_bt_init() |
| 2645 | 3838 #define kkcc_bt_push(obj, desc, level, pos) |
| 3839 #endif /* not DEBUG_XEMACS */ | |
| 3840 | |
| 2666 | 3841 /* Object memory descriptions are in the lrecord_implementation structure. |
| 3842 But copying them to a parallel array is much more cache-friendly. */ | |
| 3843 const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)]; | |
| 3844 | |
| 3845 /* the initial stack size in kkcc_gc_stack_entries */ | |
| 3846 #define KKCC_INIT_GC_STACK_SIZE 16384 | |
| 3847 | |
| 3848 typedef struct | |
| 3849 { | |
| 3850 void *data; | |
| 3851 const struct memory_description *desc; | |
| 3852 #ifdef DEBUG_XEMACS | |
| 3853 int level; | |
| 3854 int pos; | |
| 3855 #endif | |
| 3856 } kkcc_gc_stack_entry; | |
| 3857 | |
| 3858 static kkcc_gc_stack_entry *kkcc_gc_stack_ptr; | |
| 3859 static kkcc_gc_stack_entry *kkcc_gc_stack_top; | |
| 3860 static kkcc_gc_stack_entry *kkcc_gc_stack_last_entry; | |
| 3861 static int kkcc_gc_stack_size; | |
| 3862 | |
| 1676 | 3863 static void |
| 3864 kkcc_gc_stack_init (void) | |
| 3865 { | |
| 3866 kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE; | |
| 3867 kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) | |
| 3868 malloc (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); | |
| 3869 if (!kkcc_gc_stack_ptr) | |
| 3870 { | |
| 3871 stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size); | |
| 2666 | 3872 ABORT (); |
| 1676 | 3873 } |
| 3874 kkcc_gc_stack_top = kkcc_gc_stack_ptr - 1; | |
| 3875 kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1; | |
| 3876 } | |
| 3877 | |
| 3878 static void | |
| 3879 kkcc_gc_stack_free (void) | |
| 3880 { | |
| 3881 free (kkcc_gc_stack_ptr); | |
| 3882 kkcc_gc_stack_ptr = 0; | |
| 3883 kkcc_gc_stack_top = 0; | |
| 3884 kkcc_gc_stack_size = 0; | |
| 3885 } | |
| 3886 | |
| 3887 static void | |
| 3888 kkcc_gc_stack_realloc (void) | |
| 3889 { | |
| 3890 int current_offset = (int)(kkcc_gc_stack_top - kkcc_gc_stack_ptr); | |
| 3891 kkcc_gc_stack_size *= 2; | |
| 3892 kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *) | |
| 3893 realloc (kkcc_gc_stack_ptr, | |
| 3894 kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry)); | |
| 3895 if (!kkcc_gc_stack_ptr) | |
| 3896 { | |
| 3897 stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size); | |
| 2666 | 3898 ABORT (); |
| 1676 | 3899 } |
| 3900 kkcc_gc_stack_top = kkcc_gc_stack_ptr + current_offset; | |
| 3901 kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1; | |
| 3902 } | |
| 3903 | |
| 3904 #define KKCC_GC_STACK_FULL (kkcc_gc_stack_top >= kkcc_gc_stack_last_entry) | |
| 3905 #define KKCC_GC_STACK_EMPTY (kkcc_gc_stack_top < kkcc_gc_stack_ptr) | |
| 3906 | |
| 3907 static void | |
| 2645 | 3908 #ifdef DEBUG_XEMACS |
| 3909 kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc, | |
| 3910 int level, int pos) | |
| 3911 #else | |
| 3912 kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc) | |
| 3913 #endif | |
| 1676 | 3914 { |
| 3915 if (KKCC_GC_STACK_FULL) | |
| 3916 kkcc_gc_stack_realloc(); | |
| 3917 kkcc_gc_stack_top++; | |
| 3918 kkcc_gc_stack_top->data = data; | |
| 3919 kkcc_gc_stack_top->desc = desc; | |
| 2645 | 3920 #ifdef DEBUG_XEMACS |
| 3921 kkcc_gc_stack_top->level = level; | |
| 3922 kkcc_gc_stack_top->pos = pos; | |
| 3923 #endif | |
| 3924 } | |
| 3925 | |
| 3926 #ifdef DEBUG_XEMACS | |
| 3927 #define kkcc_gc_stack_push(data, desc, level, pos) \ | |
| 3928 kkcc_gc_stack_push_1 (data, desc, level, pos) | |
| 3929 #else | |
| 3930 #define kkcc_gc_stack_push(data, desc, level, pos) \ | |
| 3931 kkcc_gc_stack_push_1 (data, desc) | |
| 3932 #endif | |
| 1676 | 3933 |
| 3934 static kkcc_gc_stack_entry * | |
| 3935 kkcc_gc_stack_pop (void) | |
| 3936 { | |
| 3937 if (KKCC_GC_STACK_EMPTY) | |
| 3938 return 0; | |
| 3939 kkcc_gc_stack_top--; | |
| 3940 return kkcc_gc_stack_top + 1; | |
| 3941 } | |
| 3942 | |
| 3943 void | |
| 2645 | 3944 #ifdef DEBUG_XEMACS |
| 3945 kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos) | |
| 3946 #else | |
| 3947 kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj) | |
| 3948 #endif | |
| 1676 | 3949 { |
| 3950 if (XTYPE (obj) == Lisp_Type_Record) | |
| 3951 { | |
| 3952 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 3953 const struct memory_description *desc; | |
| 3954 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 3955 desc = RECORD_DESCRIPTION (lheader); | |
| 3956 if (! MARKED_RECORD_HEADER_P (lheader)) | |
| 3957 { | |
| 3958 MARK_RECORD_HEADER (lheader); | |
| 2666 | 3959 kkcc_gc_stack_push ((void*) lheader, desc, level, pos); |
| 1676 | 3960 } |
| 3961 } | |
| 3962 } | |
| 3963 | |
| 2645 | 3964 #ifdef DEBUG_XEMACS |
| 3965 #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ | |
| 3966 kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) | |
| 3967 #else | |
| 3968 #define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ | |
| 3969 kkcc_gc_stack_push_lisp_object_1 (obj) | |
| 3970 #endif | |
| 3971 | |
| 1265 | 3972 #ifdef ERROR_CHECK_GC |
| 3973 #define KKCC_DO_CHECK_FREE(obj, allow_free) \ | |
| 3974 do \ | |
| 3975 { \ | |
| 3976 if (!allow_free && XTYPE (obj) == Lisp_Type_Record) \ | |
| 3977 { \ | |
| 3978 struct lrecord_header *lheader = XRECORD_LHEADER (obj); \ | |
| 3979 GC_CHECK_NOT_FREE (lheader); \ | |
| 3980 } \ | |
| 3981 } while (0) | |
| 3982 #else | |
| 3983 #define KKCC_DO_CHECK_FREE(obj, allow_free) | |
| 3984 #endif | |
| 1204 | 3985 |
| 3986 #ifdef ERROR_CHECK_GC | |
| 2645 | 3987 #ifdef DEBUG_XEMACS |
| 1598 | 3988 static void |
| 2645 | 3989 mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free, |
| 3990 int level, int pos) | |
| 3991 #else | |
| 3992 static void | |
| 3993 mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free) | |
| 3994 #endif | |
| 1204 | 3995 { |
| 1265 | 3996 KKCC_DO_CHECK_FREE (obj, allow_free); |
| 2645 | 3997 kkcc_gc_stack_push_lisp_object (obj, level, pos); |
| 3998 } | |
| 3999 | |
| 4000 #ifdef DEBUG_XEMACS | |
| 4001 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ | |
| 4002 mark_object_maybe_checking_free_1 (obj, allow_free, level, pos) | |
| 1204 | 4003 #else |
| 2645 | 4004 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ |
| 4005 mark_object_maybe_checking_free_1 (obj, allow_free) | |
| 4006 #endif | |
| 4007 #else /* not ERROR_CHECK_GC */ | |
| 4008 #define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ | |
| 4009 kkcc_gc_stack_push_lisp_object (obj, level, pos) | |
| 4010 #endif /* not ERROR_CHECK_GC */ | |
| 1204 | 4011 |
| 934 | 4012 |
| 4013 /* This function loops all elements of a struct pointer and calls | |
| 4014 mark_with_description with each element. */ | |
| 4015 static void | |
| 2645 | 4016 #ifdef DEBUG_XEMACS |
| 4017 mark_struct_contents_1 (const void *data, | |
| 4018 const struct sized_memory_description *sdesc, | |
| 4019 int count, int level, int pos) | |
| 4020 #else | |
| 4021 mark_struct_contents_1 (const void *data, | |
| 1204 | 4022 const struct sized_memory_description *sdesc, |
| 4023 int count) | |
| 2645 | 4024 #endif |
| 934 | 4025 { |
| 4026 int i; | |
| 4027 Bytecount elsize; | |
| 2367 | 4028 elsize = lispdesc_block_size (data, sdesc); |
| 934 | 4029 |
| 4030 for (i = 0; i < count; i++) | |
| 4031 { | |
| 2645 | 4032 kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description, |
| 4033 level, pos); | |
| 934 | 4034 } |
| 4035 } | |
| 4036 | |
| 2645 | 4037 #ifdef DEBUG_XEMACS |
| 4038 #define mark_struct_contents(data, sdesc, count, level, pos) \ | |
| 4039 mark_struct_contents_1 (data, sdesc, count, level, pos) | |
| 4040 #else | |
| 4041 #define mark_struct_contents(data, sdesc, count, level, pos) \ | |
| 4042 mark_struct_contents_1 (data, sdesc, count) | |
| 4043 #endif | |
| 1598 | 4044 |
| 4045 /* This function implements the KKCC mark algorithm. | |
| 4046 Instead of calling mark_object, all the alive Lisp_Objects are pushed | |
| 4047 on the kkcc_gc_stack. This function processes all elements on the stack | |
| 4048 according to their descriptions. */ | |
| 4049 static void | |
| 4050 kkcc_marking (void) | |
| 4051 { | |
| 4052 kkcc_gc_stack_entry *stack_entry = 0; | |
| 4053 void *data = 0; | |
| 4054 const struct memory_description *desc = 0; | |
| 4055 int pos; | |
| 2645 | 4056 #ifdef DEBUG_XEMACS |
| 4057 int level = 0; | |
| 2666 | 4058 kkcc_bt_init (); |
| 2645 | 4059 #endif |
| 1598 | 4060 |
| 4061 while ((stack_entry = kkcc_gc_stack_pop ()) != 0) | |
| 4062 { | |
| 4063 data = stack_entry->data; | |
| 4064 desc = stack_entry->desc; | |
| 2645 | 4065 #ifdef DEBUG_XEMACS |
| 4066 level = stack_entry->level + 1; | |
| 4067 #endif | |
| 4068 | |
| 4069 kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos); | |
| 1598 | 4070 |
| 2720 | 4071 gc_checking_assert (data); |
| 4072 gc_checking_assert (desc); | |
| 4073 | |
| 1598 | 4074 for (pos = 0; desc[pos].type != XD_END; pos++) |
| 4075 { | |
| 4076 const struct memory_description *desc1 = &desc[pos]; | |
| 4077 const void *rdata = | |
| 4078 (const char *) data + lispdesc_indirect_count (desc1->offset, | |
| 4079 desc, data); | |
| 4080 union_switcheroo: | |
| 4081 | |
| 4082 /* If the flag says don't mark, then don't mark. */ | |
| 4083 if ((desc1->flags) & XD_FLAG_NO_KKCC) | |
| 4084 continue; | |
| 4085 | |
| 4086 switch (desc1->type) | |
| 4087 { | |
| 4088 case XD_BYTECOUNT: | |
| 4089 case XD_ELEMCOUNT: | |
| 4090 case XD_HASHCODE: | |
| 4091 case XD_INT: | |
| 4092 case XD_LONG: | |
| 4093 case XD_INT_RESET: | |
| 4094 case XD_LO_LINK: | |
| 4095 case XD_OPAQUE_PTR: | |
| 4096 case XD_OPAQUE_DATA_PTR: | |
| 2367 | 4097 case XD_ASCII_STRING: |
| 1598 | 4098 case XD_DOC_STRING: |
| 4099 break; | |
| 4100 case XD_LISP_OBJECT: | |
| 4101 { | |
| 4102 const Lisp_Object *stored_obj = (const Lisp_Object *) rdata; | |
| 4103 | |
| 4104 /* Because of the way that tagged objects work (pointers and | |
| 4105 Lisp_Objects have the same representation), XD_LISP_OBJECT | |
| 4106 can be used for untagged pointers. They might be NULL, | |
| 4107 though. */ | |
| 4108 if (EQ (*stored_obj, Qnull_pointer)) | |
| 4109 break; | |
| 2720 | 4110 #ifdef MC_ALLOC |
| 4111 mark_object_maybe_checking_free (*stored_obj, 0, level, pos); | |
| 4112 #else /* not MC_ALLOC */ | |
| 1598 | 4113 mark_object_maybe_checking_free |
| 2645 | 4114 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, |
| 4115 level, pos); | |
| 1598 | 4116 break; |
| 2720 | 4117 #endif /* not MC_ALLOC */ |
| 1598 | 4118 } |
| 4119 case XD_LISP_OBJECT_ARRAY: | |
| 4120 { | |
| 4121 int i; | |
| 4122 EMACS_INT count = | |
| 4123 lispdesc_indirect_count (desc1->data1, desc, data); | |
| 4124 | |
| 4125 for (i = 0; i < count; i++) | |
| 4126 { | |
| 4127 const Lisp_Object *stored_obj = | |
| 4128 (const Lisp_Object *) rdata + i; | |
| 4129 | |
| 4130 if (EQ (*stored_obj, Qnull_pointer)) | |
| 4131 break; | |
| 2720 | 4132 #ifdef MC_ALLOC |
| 4133 mark_object_maybe_checking_free (*stored_obj, 0, level, pos); | |
| 4134 #else /* not MC_ALLOC */ | |
| 1598 | 4135 mark_object_maybe_checking_free |
| 2645 | 4136 (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, |
| 4137 level, pos); | |
| 2720 | 4138 #endif /* not MC_ALLOC */ |
| 1598 | 4139 } |
| 4140 break; | |
| 4141 } | |
| 2367 | 4142 case XD_BLOCK_PTR: |
| 1598 | 4143 { |
| 4144 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, | |
| 4145 data); | |
| 4146 const struct sized_memory_description *sdesc = | |
| 2551 | 4147 lispdesc_indirect_description (data, desc1->data2.descr); |
| 1598 | 4148 const char *dobj = * (const char **) rdata; |
| 4149 if (dobj) | |
| 2645 | 4150 mark_struct_contents (dobj, sdesc, count, level, pos); |
| 1598 | 4151 break; |
| 4152 } | |
| 2367 | 4153 case XD_BLOCK_ARRAY: |
| 1598 | 4154 { |
| 4155 EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, | |
| 4156 data); | |
| 4157 const struct sized_memory_description *sdesc = | |
| 2551 | 4158 lispdesc_indirect_description (data, desc1->data2.descr); |
| 1598 | 4159 |
| 2645 | 4160 mark_struct_contents (rdata, sdesc, count, level, pos); |
| 1598 | 4161 break; |
| 4162 } | |
| 4163 case XD_UNION: | |
| 4164 case XD_UNION_DYNAMIC_SIZE: | |
| 4165 desc1 = lispdesc_process_xd_union (desc1, desc, data); | |
| 4166 if (desc1) | |
| 4167 goto union_switcheroo; | |
| 4168 break; | |
| 4169 | |
| 4170 default: | |
| 4171 stderr_out ("Unsupported description type : %d\n", desc1->type); | |
| 2645 | 4172 kkcc_backtrace (); |
| 2500 | 4173 ABORT (); |
| 1598 | 4174 } |
| 4175 } | |
| 4176 } | |
| 2666 | 4177 #ifdef DEBUG_XEMACS |
| 4178 kkcc_bt_free (); | |
| 4179 #endif | |
| 1598 | 4180 } |
| 934 | 4181 #endif /* USE_KKCC */ |
| 4182 | |
| 428 | 4183 /* Mark reference to a Lisp_Object. If the object referred to has not been |
| 4184 seen yet, recursively mark all the references contained in it. */ | |
| 4185 | |
| 4186 void | |
| 2286 | 4187 mark_object ( |
| 4188 #ifdef USE_KKCC | |
| 4189 Lisp_Object UNUSED (obj) | |
| 4190 #else | |
| 4191 Lisp_Object obj | |
| 4192 #endif | |
| 4193 ) | |
| 428 | 4194 { |
| 1598 | 4195 #ifdef USE_KKCC |
| 4196 /* this code should never be reached when configured for KKCC */ | |
| 4197 stderr_out ("KKCC: Invalid mark_object call.\n"); | |
| 4198 stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n"); | |
| 2500 | 4199 ABORT (); |
| 1676 | 4200 #else /* not USE_KKCC */ |
| 1598 | 4201 |
| 428 | 4202 tail_recurse: |
| 4203 | |
| 4204 /* Checks we used to perform */ | |
| 4205 /* if (EQ (obj, Qnull_pointer)) return; */ | |
| 4206 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ | |
| 4207 /* if (PURIFIED (XPNTR (obj))) return; */ | |
| 4208 | |
| 4209 if (XTYPE (obj) == Lisp_Type_Record) | |
| 4210 { | |
| 4211 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 442 | 4212 |
| 4213 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 4214 | |
| 1204 | 4215 /* We handle this separately, above, so we can mark free objects */ |
| 1265 | 4216 GC_CHECK_NOT_FREE (lheader); |
| 1204 | 4217 |
| 442 | 4218 /* All c_readonly objects have their mark bit set, |
| 4219 so that we only need to check the mark bit here. */ | |
| 4220 if (! MARKED_RECORD_HEADER_P (lheader)) | |
| 428 | 4221 { |
| 4222 MARK_RECORD_HEADER (lheader); | |
| 442 | 4223 |
| 1598 | 4224 if (RECORD_MARKER (lheader)) |
| 4225 { | |
| 4226 obj = RECORD_MARKER (lheader) (obj); | |
| 4227 if (!NILP (obj)) goto tail_recurse; | |
| 4228 } | |
| 428 | 4229 } |
| 4230 } | |
| 1676 | 4231 #endif /* not KKCC */ |
| 428 | 4232 } |
| 4233 | |
| 4234 | |
| 2720 | 4235 #ifndef MC_ALLOC |
| 428 | 4236 static int gc_count_num_short_string_in_use; |
| 647 | 4237 static Bytecount gc_count_string_total_size; |
| 4238 static Bytecount gc_count_short_string_total_size; | |
| 428 | 4239 |
| 4240 /* static int gc_count_total_records_used, gc_count_records_total_size; */ | |
| 4241 | |
| 4242 | |
| 4243 /* stats on lcrecords in use - kinda kludgy */ | |
| 4244 | |
| 4245 static struct | |
| 4246 { | |
| 4247 int instances_in_use; | |
| 4248 int bytes_in_use; | |
| 4249 int instances_freed; | |
| 4250 int bytes_freed; | |
| 4251 int instances_on_free_list; | |
| 707 | 4252 } lcrecord_stats [countof (lrecord_implementations_table) |
| 4253 + MODULE_DEFINABLE_TYPE_COUNT]; | |
| 428 | 4254 |
| 4255 static void | |
| 442 | 4256 tick_lcrecord_stats (const struct lrecord_header *h, int free_p) |
| 428 | 4257 { |
| 647 | 4258 int type_index = h->type; |
| 428 | 4259 |
| 4260 if (((struct lcrecord_header *) h)->free) | |
| 4261 { | |
| 442 | 4262 gc_checking_assert (!free_p); |
| 428 | 4263 lcrecord_stats[type_index].instances_on_free_list++; |
| 4264 } | |
| 4265 else | |
| 4266 { | |
| 1204 | 4267 Bytecount sz = detagged_lisp_object_size (h); |
| 4268 | |
| 428 | 4269 if (free_p) |
| 4270 { | |
| 4271 lcrecord_stats[type_index].instances_freed++; | |
| 4272 lcrecord_stats[type_index].bytes_freed += sz; | |
| 4273 } | |
| 4274 else | |
| 4275 { | |
| 4276 lcrecord_stats[type_index].instances_in_use++; | |
| 4277 lcrecord_stats[type_index].bytes_in_use += sz; | |
| 4278 } | |
| 4279 } | |
| 4280 } | |
| 2720 | 4281 #endif /* not MC_ALLOC */ |
| 428 | 4282 |
| 4283 | |
| 2720 | 4284 #ifndef MC_ALLOC |
| 428 | 4285 /* Free all unmarked records */ |
| 4286 static void | |
| 4287 sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) | |
| 4288 { | |
| 4289 struct lcrecord_header *header; | |
| 4290 int num_used = 0; | |
| 4291 /* int total_size = 0; */ | |
| 4292 | |
| 4293 xzero (lcrecord_stats); /* Reset all statistics to 0. */ | |
| 4294 | |
| 4295 /* First go through and call all the finalize methods. | |
| 4296 Then go through and free the objects. There used to | |
| 4297 be only one loop here, with the call to the finalizer | |
| 4298 occurring directly before the xfree() below. That | |
| 4299 is marginally faster but much less safe -- if the | |
| 4300 finalize method for an object needs to reference any | |
| 4301 other objects contained within it (and many do), | |
| 4302 we could easily be screwed by having already freed that | |
| 4303 other object. */ | |
| 4304 | |
| 4305 for (header = *prev; header; header = header->next) | |
| 4306 { | |
| 4307 struct lrecord_header *h = &(header->lheader); | |
| 442 | 4308 |
| 4309 GC_CHECK_LHEADER_INVARIANTS (h); | |
| 4310 | |
| 4311 if (! MARKED_RECORD_HEADER_P (h) && ! header->free) | |
| 428 | 4312 { |
| 4313 if (LHEADER_IMPLEMENTATION (h)->finalizer) | |
| 4314 LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); | |
| 4315 } | |
| 4316 } | |
| 4317 | |
| 4318 for (header = *prev; header; ) | |
| 4319 { | |
| 4320 struct lrecord_header *h = &(header->lheader); | |
| 442 | 4321 if (MARKED_RECORD_HEADER_P (h)) |
| 428 | 4322 { |
| 442 | 4323 if (! C_READONLY_RECORD_HEADER_P (h)) |
| 428 | 4324 UNMARK_RECORD_HEADER (h); |
| 4325 num_used++; | |
| 4326 /* total_size += n->implementation->size_in_bytes (h);*/ | |
| 440 | 4327 /* #### May modify header->next on a C_READONLY lcrecord */ |
| 428 | 4328 prev = &(header->next); |
| 4329 header = *prev; | |
| 4330 tick_lcrecord_stats (h, 0); | |
| 4331 } | |
| 4332 else | |
| 4333 { | |
| 4334 struct lcrecord_header *next = header->next; | |
| 4335 *prev = next; | |
| 4336 tick_lcrecord_stats (h, 1); | |
| 4337 /* used to call finalizer right here. */ | |
| 1726 | 4338 xfree (header, struct lcrecord_header *); |
| 428 | 4339 header = next; |
| 4340 } | |
| 4341 } | |
| 4342 *used = num_used; | |
| 4343 /* *total = total_size; */ | |
| 4344 } | |
| 4345 | |
| 4346 /* And the Lord said: Thou shalt use the `c-backslash-region' command | |
| 4347 to make macros prettier. */ | |
| 4348 | |
| 4349 #ifdef ERROR_CHECK_GC | |
| 4350 | |
| 771 | 4351 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 428 | 4352 do { \ |
| 4353 struct typename##_block *SFTB_current; \ | |
| 4354 int SFTB_limit; \ | |
| 4355 int num_free = 0, num_used = 0; \ | |
| 4356 \ | |
| 444 | 4357 for (SFTB_current = current_##typename##_block, \ |
| 428 | 4358 SFTB_limit = current_##typename##_block_index; \ |
| 4359 SFTB_current; \ | |
| 4360 ) \ | |
| 4361 { \ | |
| 4362 int SFTB_iii; \ | |
| 4363 \ | |
| 4364 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 4365 { \ | |
| 4366 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 4367 \ | |
| 454 | 4368 if (LRECORD_FREE_P (SFTB_victim)) \ |
| 428 | 4369 { \ |
| 4370 num_free++; \ | |
| 4371 } \ | |
| 4372 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 4373 { \ | |
| 4374 num_used++; \ | |
| 4375 } \ | |
| 442 | 4376 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ |
| 428 | 4377 { \ |
| 4378 num_free++; \ | |
| 4379 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 4380 } \ | |
| 4381 else \ | |
| 4382 { \ | |
| 4383 num_used++; \ | |
| 4384 UNMARK_##typename (SFTB_victim); \ | |
| 4385 } \ | |
| 4386 } \ | |
| 4387 SFTB_current = SFTB_current->prev; \ | |
| 4388 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 4389 } \ | |
| 4390 \ | |
| 4391 gc_count_num_##typename##_in_use = num_used; \ | |
| 4392 gc_count_num_##typename##_freelist = num_free; \ | |
| 4393 } while (0) | |
| 4394 | |
| 4395 #else /* !ERROR_CHECK_GC */ | |
| 4396 | |
| 771 | 4397 #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ |
| 4398 do { \ | |
| 4399 struct typename##_block *SFTB_current; \ | |
| 4400 struct typename##_block **SFTB_prev; \ | |
| 4401 int SFTB_limit; \ | |
| 4402 int num_free = 0, num_used = 0; \ | |
| 4403 \ | |
| 4404 typename##_free_list = 0; \ | |
| 4405 \ | |
| 4406 for (SFTB_prev = ¤t_##typename##_block, \ | |
| 4407 SFTB_current = current_##typename##_block, \ | |
| 4408 SFTB_limit = current_##typename##_block_index; \ | |
| 4409 SFTB_current; \ | |
| 4410 ) \ | |
| 4411 { \ | |
| 4412 int SFTB_iii; \ | |
| 4413 int SFTB_empty = 1; \ | |
| 4414 Lisp_Free *SFTB_old_free_list = typename##_free_list; \ | |
| 4415 \ | |
| 4416 for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ | |
| 4417 { \ | |
| 4418 obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ | |
| 4419 \ | |
| 4420 if (LRECORD_FREE_P (SFTB_victim)) \ | |
| 4421 { \ | |
| 4422 num_free++; \ | |
| 4423 PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ | |
| 4424 } \ | |
| 4425 else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 4426 { \ | |
| 4427 SFTB_empty = 0; \ | |
| 4428 num_used++; \ | |
| 4429 } \ | |
| 4430 else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \ | |
| 4431 { \ | |
| 4432 num_free++; \ | |
| 4433 FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ | |
| 4434 } \ | |
| 4435 else \ | |
| 4436 { \ | |
| 4437 SFTB_empty = 0; \ | |
| 4438 num_used++; \ | |
| 4439 UNMARK_##typename (SFTB_victim); \ | |
| 4440 } \ | |
| 4441 } \ | |
| 4442 if (!SFTB_empty) \ | |
| 4443 { \ | |
| 4444 SFTB_prev = &(SFTB_current->prev); \ | |
| 4445 SFTB_current = SFTB_current->prev; \ | |
| 4446 } \ | |
| 4447 else if (SFTB_current == current_##typename##_block \ | |
| 4448 && !SFTB_current->prev) \ | |
| 4449 { \ | |
| 4450 /* No real point in freeing sole allocation block */ \ | |
| 4451 break; \ | |
| 4452 } \ | |
| 4453 else \ | |
| 4454 { \ | |
| 4455 struct typename##_block *SFTB_victim_block = SFTB_current; \ | |
| 4456 if (SFTB_victim_block == current_##typename##_block) \ | |
| 4457 current_##typename##_block_index \ | |
| 4458 = countof (current_##typename##_block->block); \ | |
| 4459 SFTB_current = SFTB_current->prev; \ | |
| 4460 { \ | |
| 4461 *SFTB_prev = SFTB_current; \ | |
| 1726 | 4462 xfree (SFTB_victim_block, struct typename##_block *); \ |
| 771 | 4463 /* Restore free list to what it was before victim was swept */ \ |
| 4464 typename##_free_list = SFTB_old_free_list; \ | |
| 4465 num_free -= SFTB_limit; \ | |
| 4466 } \ | |
| 4467 } \ | |
| 4468 SFTB_limit = countof (current_##typename##_block->block); \ | |
| 4469 } \ | |
| 4470 \ | |
| 4471 gc_count_num_##typename##_in_use = num_used; \ | |
| 4472 gc_count_num_##typename##_freelist = num_free; \ | |
| 428 | 4473 } while (0) |
| 4474 | |
| 4475 #endif /* !ERROR_CHECK_GC */ | |
| 4476 | |
| 771 | 4477 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ |
| 4478 SWEEP_FIXED_TYPE_BLOCK_1 (typename, obj_type, lheader) | |
| 4479 | |
| 2720 | 4480 #endif /* not MC_ALLOC */ |
| 4481 | |
| 428 | 4482 |
| 2720 | 4483 #ifndef MC_ALLOC |
| 428 | 4484 static void |
| 4485 sweep_conses (void) | |
| 4486 { | |
| 4487 #define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4488 #define ADDITIONAL_FREE_cons(ptr) | |
| 4489 | |
| 440 | 4490 SWEEP_FIXED_TYPE_BLOCK (cons, Lisp_Cons); |
| 428 | 4491 } |
| 2720 | 4492 #endif /* not MC_ALLOC */ |
| 428 | 4493 |
| 4494 /* Explicitly free a cons cell. */ | |
| 4495 void | |
| 853 | 4496 free_cons (Lisp_Object cons) |
| 428 | 4497 { |
| 2720 | 4498 #ifndef MC_ALLOC /* to avoid compiler warning */ |
| 853 | 4499 Lisp_Cons *ptr = XCONS (cons); |
| 2720 | 4500 #endif /* MC_ALLOC */ |
| 853 | 4501 |
| 428 | 4502 #ifdef ERROR_CHECK_GC |
| 2720 | 4503 #ifdef MC_ALLOC |
| 4504 Lisp_Cons *ptr = XCONS (cons); | |
| 4505 #endif /* MC_ALLOC */ | |
| 428 | 4506 /* If the CAR is not an int, then it will be a pointer, which will |
| 4507 always be four-byte aligned. If this cons cell has already been | |
| 4508 placed on the free list, however, its car will probably contain | |
| 4509 a chain pointer to the next cons on the list, which has cleverly | |
| 4510 had all its 0's and 1's inverted. This allows for a quick | |
| 1204 | 4511 check to make sure we're not freeing something already freed. |
| 4512 | |
| 4513 NOTE: This check may not be necessary. Freeing an object sets its | |
| 4514 type to lrecord_type_free, which will trip up the XCONS() above -- as | |
| 4515 well as a check in FREE_FIXED_TYPE(). */ | |
| 853 | 4516 if (POINTER_TYPE_P (XTYPE (cons_car (ptr)))) |
| 4517 ASSERT_VALID_POINTER (XPNTR (cons_car (ptr))); | |
| 428 | 4518 #endif /* ERROR_CHECK_GC */ |
| 4519 | |
| 2720 | 4520 #ifdef MC_ALLOC |
| 4521 free_lrecord (cons); | |
| 4522 #else /* not MC_ALLOC */ | |
| 440 | 4523 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, Lisp_Cons, ptr); |
| 2720 | 4524 #endif /* not MC_ALLOC */ |
| 428 | 4525 } |
| 4526 | |
| 4527 /* explicitly free a list. You **must make sure** that you have | |
| 4528 created all the cons cells that make up this list and that there | |
| 4529 are no pointers to any of these cons cells anywhere else. If there | |
| 4530 are, you will lose. */ | |
| 4531 | |
| 4532 void | |
| 4533 free_list (Lisp_Object list) | |
| 4534 { | |
| 4535 Lisp_Object rest, next; | |
| 4536 | |
| 4537 for (rest = list; !NILP (rest); rest = next) | |
| 4538 { | |
| 4539 next = XCDR (rest); | |
| 853 | 4540 free_cons (rest); |
| 428 | 4541 } |
| 4542 } | |
| 4543 | |
| 4544 /* explicitly free an alist. You **must make sure** that you have | |
| 4545 created all the cons cells that make up this alist and that there | |
| 4546 are no pointers to any of these cons cells anywhere else. If there | |
| 4547 are, you will lose. */ | |
| 4548 | |
| 4549 void | |
| 4550 free_alist (Lisp_Object alist) | |
| 4551 { | |
| 4552 Lisp_Object rest, next; | |
| 4553 | |
| 4554 for (rest = alist; !NILP (rest); rest = next) | |
| 4555 { | |
| 4556 next = XCDR (rest); | |
| 853 | 4557 free_cons (XCAR (rest)); |
| 4558 free_cons (rest); | |
| 428 | 4559 } |
| 4560 } | |
| 4561 | |
| 2720 | 4562 #ifndef MC_ALLOC |
| 428 | 4563 static void |
| 4564 sweep_compiled_functions (void) | |
| 4565 { | |
| 4566 #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 945 | 4567 #define ADDITIONAL_FREE_compiled_function(ptr) \ |
| 1726 | 4568 if (ptr->args_in_array) xfree (ptr->args, Lisp_Object *) |
| 428 | 4569 |
| 4570 SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); | |
| 4571 } | |
| 4572 | |
| 4573 static void | |
| 4574 sweep_floats (void) | |
| 4575 { | |
| 4576 #define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4577 #define ADDITIONAL_FREE_float(ptr) | |
| 4578 | |
| 440 | 4579 SWEEP_FIXED_TYPE_BLOCK (float, Lisp_Float); |
| 428 | 4580 } |
| 4581 | |
| 1983 | 4582 #ifdef HAVE_BIGNUM |
| 4583 static void | |
| 4584 sweep_bignums (void) | |
| 4585 { | |
| 4586 #define UNMARK_bignum(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4587 #define ADDITIONAL_FREE_bignum(ptr) bignum_fini (ptr->data) | |
| 4588 | |
| 4589 SWEEP_FIXED_TYPE_BLOCK (bignum, Lisp_Bignum); | |
| 4590 } | |
| 4591 #endif /* HAVE_BIGNUM */ | |
| 4592 | |
| 4593 #ifdef HAVE_RATIO | |
| 4594 static void | |
| 4595 sweep_ratios (void) | |
| 4596 { | |
| 4597 #define UNMARK_ratio(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4598 #define ADDITIONAL_FREE_ratio(ptr) ratio_fini (ptr->data) | |
| 4599 | |
| 4600 SWEEP_FIXED_TYPE_BLOCK (ratio, Lisp_Ratio); | |
| 4601 } | |
| 4602 #endif /* HAVE_RATIO */ | |
| 4603 | |
| 4604 #ifdef HAVE_BIGFLOAT | |
| 4605 static void | |
| 4606 sweep_bigfloats (void) | |
| 4607 { | |
| 4608 #define UNMARK_bigfloat(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4609 #define ADDITIONAL_FREE_bigfloat(ptr) bigfloat_fini (ptr->bf) | |
| 4610 | |
| 4611 SWEEP_FIXED_TYPE_BLOCK (bigfloat, Lisp_Bigfloat); | |
| 4612 } | |
| 4613 #endif | |
| 4614 | |
| 428 | 4615 static void |
| 4616 sweep_symbols (void) | |
| 4617 { | |
| 4618 #define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4619 #define ADDITIONAL_FREE_symbol(ptr) | |
| 4620 | |
| 440 | 4621 SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol); |
| 428 | 4622 } |
| 4623 | |
| 4624 static void | |
| 4625 sweep_extents (void) | |
| 4626 { | |
| 4627 #define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4628 #define ADDITIONAL_FREE_extent(ptr) | |
| 4629 | |
| 4630 SWEEP_FIXED_TYPE_BLOCK (extent, struct extent); | |
| 4631 } | |
| 4632 | |
| 4633 static void | |
| 4634 sweep_events (void) | |
| 4635 { | |
| 4636 #define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4637 #define ADDITIONAL_FREE_event(ptr) | |
| 4638 | |
| 440 | 4639 SWEEP_FIXED_TYPE_BLOCK (event, Lisp_Event); |
| 428 | 4640 } |
| 2720 | 4641 #endif /* not MC_ALLOC */ |
| 428 | 4642 |
| 1204 | 4643 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 4644 |
| 2720 | 4645 #ifndef MC_ALLOC |
| 934 | 4646 static void |
| 4647 sweep_key_data (void) | |
| 4648 { | |
| 4649 #define UNMARK_key_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4650 #define ADDITIONAL_FREE_key_data(ptr) | |
| 4651 | |
| 4652 SWEEP_FIXED_TYPE_BLOCK (key_data, Lisp_Key_Data); | |
| 4653 } | |
| 2720 | 4654 #endif /* not MC_ALLOC */ |
| 934 | 4655 |
| 1204 | 4656 void |
| 4657 free_key_data (Lisp_Object ptr) | |
| 4658 { | |
| 2720 | 4659 #ifdef MC_ALLOC |
| 4660 free_lrecord (ptr); | |
| 4661 #else /* not MC_ALLOC */ | |
| 1204 | 4662 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (key_data, Lisp_Key_Data, XKEY_DATA (ptr)); |
| 2720 | 4663 #endif /* not MC_ALLOC */ |
| 4664 } | |
| 4665 | |
| 4666 #ifndef MC_ALLOC | |
| 934 | 4667 static void |
| 4668 sweep_button_data (void) | |
| 4669 { | |
| 4670 #define UNMARK_button_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4671 #define ADDITIONAL_FREE_button_data(ptr) | |
| 4672 | |
| 4673 SWEEP_FIXED_TYPE_BLOCK (button_data, Lisp_Button_Data); | |
| 4674 } | |
| 2720 | 4675 #endif /* not MC_ALLOC */ |
| 934 | 4676 |
| 1204 | 4677 void |
| 4678 free_button_data (Lisp_Object ptr) | |
| 4679 { | |
| 2720 | 4680 #ifdef MC_ALLOC |
| 4681 free_lrecord (ptr); | |
| 4682 #else /* not MC_ALLOC */ | |
| 1204 | 4683 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (button_data, Lisp_Button_Data, XBUTTON_DATA (ptr)); |
| 2720 | 4684 #endif /* not MC_ALLOC */ |
| 4685 } | |
| 4686 | |
| 4687 #ifndef MC_ALLOC | |
| 934 | 4688 static void |
| 4689 sweep_motion_data (void) | |
| 4690 { | |
| 4691 #define UNMARK_motion_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4692 #define ADDITIONAL_FREE_motion_data(ptr) | |
| 4693 | |
| 4694 SWEEP_FIXED_TYPE_BLOCK (motion_data, Lisp_Motion_Data); | |
| 4695 } | |
| 2720 | 4696 #endif /* not MC_ALLOC */ |
| 934 | 4697 |
| 1204 | 4698 void |
| 4699 free_motion_data (Lisp_Object ptr) | |
| 4700 { | |
| 2720 | 4701 #ifdef MC_ALLOC |
| 4702 free_lrecord (ptr); | |
| 4703 #else /* not MC_ALLOC */ | |
| 1204 | 4704 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (motion_data, Lisp_Motion_Data, XMOTION_DATA (ptr)); |
| 2720 | 4705 #endif /* not MC_ALLOC */ |
| 4706 } | |
| 4707 | |
| 4708 #ifndef MC_ALLOC | |
| 934 | 4709 static void |
| 4710 sweep_process_data (void) | |
| 4711 { | |
| 4712 #define UNMARK_process_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4713 #define ADDITIONAL_FREE_process_data(ptr) | |
| 4714 | |
| 4715 SWEEP_FIXED_TYPE_BLOCK (process_data, Lisp_Process_Data); | |
| 4716 } | |
| 2720 | 4717 #endif /* not MC_ALLOC */ |
| 934 | 4718 |
| 1204 | 4719 void |
| 4720 free_process_data (Lisp_Object ptr) | |
| 4721 { | |
| 2720 | 4722 #ifdef MC_ALLOC |
| 4723 free_lrecord (ptr); | |
| 4724 #else /* not MC_ALLOC */ | |
| 1204 | 4725 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (process_data, Lisp_Process_Data, XPROCESS_DATA (ptr)); |
| 2720 | 4726 #endif /* not MC_ALLOC */ |
| 4727 } | |
| 4728 | |
| 4729 #ifndef MC_ALLOC | |
| 934 | 4730 static void |
| 4731 sweep_timeout_data (void) | |
| 4732 { | |
| 4733 #define UNMARK_timeout_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4734 #define ADDITIONAL_FREE_timeout_data(ptr) | |
| 4735 | |
| 4736 SWEEP_FIXED_TYPE_BLOCK (timeout_data, Lisp_Timeout_Data); | |
| 4737 } | |
| 2720 | 4738 #endif /* not MC_ALLOC */ |
| 934 | 4739 |
| 1204 | 4740 void |
| 4741 free_timeout_data (Lisp_Object ptr) | |
| 4742 { | |
| 2720 | 4743 #ifdef MC_ALLOC |
| 4744 free_lrecord (ptr); | |
| 4745 #else /* not MC_ALLOC */ | |
| 1204 | 4746 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (timeout_data, Lisp_Timeout_Data, XTIMEOUT_DATA (ptr)); |
| 2720 | 4747 #endif /* not MC_ALLOC */ |
| 4748 } | |
| 4749 | |
| 4750 #ifndef MC_ALLOC | |
| 934 | 4751 static void |
| 4752 sweep_magic_data (void) | |
| 4753 { | |
| 4754 #define UNMARK_magic_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4755 #define ADDITIONAL_FREE_magic_data(ptr) | |
| 4756 | |
| 4757 SWEEP_FIXED_TYPE_BLOCK (magic_data, Lisp_Magic_Data); | |
| 4758 } | |
| 2720 | 4759 #endif /* not MC_ALLOC */ |
| 934 | 4760 |
| 1204 | 4761 void |
| 4762 free_magic_data (Lisp_Object ptr) | |
| 4763 { | |
| 2720 | 4764 #ifdef MC_ALLOC |
| 4765 free_lrecord (ptr); | |
| 4766 #else /* not MC_ALLOC */ | |
| 1204 | 4767 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_data, Lisp_Magic_Data, XMAGIC_DATA (ptr)); |
| 2720 | 4768 #endif /* not MC_ALLOC */ |
| 4769 } | |
| 4770 | |
| 4771 #ifndef MC_ALLOC | |
| 934 | 4772 static void |
| 4773 sweep_magic_eval_data (void) | |
| 4774 { | |
| 4775 #define UNMARK_magic_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4776 #define ADDITIONAL_FREE_magic_eval_data(ptr) | |
| 4777 | |
| 4778 SWEEP_FIXED_TYPE_BLOCK (magic_eval_data, Lisp_Magic_Eval_Data); | |
| 4779 } | |
| 2720 | 4780 #endif /* not MC_ALLOC */ |
| 934 | 4781 |
| 1204 | 4782 void |
| 4783 free_magic_eval_data (Lisp_Object ptr) | |
| 4784 { | |
| 2720 | 4785 #ifdef MC_ALLOC |
| 4786 free_lrecord (ptr); | |
| 4787 #else /* not MC_ALLOC */ | |
| 1204 | 4788 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (magic_eval_data, Lisp_Magic_Eval_Data, XMAGIC_EVAL_DATA (ptr)); |
| 2720 | 4789 #endif /* not MC_ALLOC */ |
| 4790 } | |
| 4791 | |
| 4792 #ifndef MC_ALLOC | |
| 934 | 4793 static void |
| 4794 sweep_eval_data (void) | |
| 4795 { | |
| 4796 #define UNMARK_eval_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4797 #define ADDITIONAL_FREE_eval_data(ptr) | |
| 4798 | |
| 4799 SWEEP_FIXED_TYPE_BLOCK (eval_data, Lisp_Eval_Data); | |
| 4800 } | |
| 2720 | 4801 #endif /* not MC_ALLOC */ |
| 934 | 4802 |
| 1204 | 4803 void |
| 4804 free_eval_data (Lisp_Object ptr) | |
| 4805 { | |
| 2720 | 4806 #ifdef MC_ALLOC |
| 4807 free_lrecord (ptr); | |
| 4808 #else /* not MC_ALLOC */ | |
| 1204 | 4809 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (eval_data, Lisp_Eval_Data, XEVAL_DATA (ptr)); |
| 2720 | 4810 #endif /* not MC_ALLOC */ |
| 4811 } | |
| 4812 | |
| 4813 #ifndef MC_ALLOC | |
| 934 | 4814 static void |
| 4815 sweep_misc_user_data (void) | |
| 4816 { | |
| 4817 #define UNMARK_misc_user_data(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4818 #define ADDITIONAL_FREE_misc_user_data(ptr) | |
| 4819 | |
| 4820 SWEEP_FIXED_TYPE_BLOCK (misc_user_data, Lisp_Misc_User_Data); | |
| 4821 } | |
| 2720 | 4822 #endif /* not MC_ALLOC */ |
| 934 | 4823 |
| 1204 | 4824 void |
| 4825 free_misc_user_data (Lisp_Object ptr) | |
| 4826 { | |
| 2720 | 4827 #ifdef MC_ALLOC |
| 4828 free_lrecord (ptr); | |
| 4829 #else /* not MC_ALLOC */ | |
| 1204 | 4830 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (misc_user_data, Lisp_Misc_User_Data, XMISC_USER_DATA (ptr)); |
| 2720 | 4831 #endif /* not MC_ALLOC */ |
| 1204 | 4832 } |
| 4833 | |
| 4834 #endif /* EVENT_DATA_AS_OBJECTS */ | |
| 934 | 4835 |
| 2720 | 4836 #ifndef MC_ALLOC |
| 428 | 4837 static void |
| 4838 sweep_markers (void) | |
| 4839 { | |
| 4840 #define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) | |
| 4841 #define ADDITIONAL_FREE_marker(ptr) \ | |
| 4842 do { Lisp_Object tem; \ | |
| 793 | 4843 tem = wrap_marker (ptr); \ |
| 428 | 4844 unchain_marker (tem); \ |
| 4845 } while (0) | |
| 4846 | |
| 440 | 4847 SWEEP_FIXED_TYPE_BLOCK (marker, Lisp_Marker); |
| 428 | 4848 } |
| 2720 | 4849 #endif /* not MC_ALLOC */ |
| 428 | 4850 |
| 4851 /* Explicitly free a marker. */ | |
| 4852 void | |
| 1204 | 4853 free_marker (Lisp_Object ptr) |
| 428 | 4854 { |
| 2720 | 4855 #ifdef MC_ALLOC |
| 4856 free_lrecord (ptr); | |
| 4857 #else /* not MC_ALLOC */ | |
| 1204 | 4858 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, XMARKER (ptr)); |
| 2720 | 4859 #endif /* not MC_ALLOC */ |
| 428 | 4860 } |
| 4861 | |
| 4862 | |
| 4863 #if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) | |
| 4864 | |
| 4865 static void | |
| 4866 verify_string_chars_integrity (void) | |
| 4867 { | |
| 4868 struct string_chars_block *sb; | |
| 4869 | |
| 4870 /* Scan each existing string block sequentially, string by string. */ | |
| 4871 for (sb = first_string_chars_block; sb; sb = sb->next) | |
| 4872 { | |
| 4873 int pos = 0; | |
| 4874 /* POS is the index of the next string in the block. */ | |
| 4875 while (pos < sb->pos) | |
| 4876 { | |
| 4877 struct string_chars *s_chars = | |
| 4878 (struct string_chars *) &(sb->string_chars[pos]); | |
| 438 | 4879 Lisp_String *string; |
| 428 | 4880 int size; |
| 4881 int fullsize; | |
| 4882 | |
| 454 | 4883 /* If the string_chars struct is marked as free (i.e. the |
| 4884 STRING pointer is NULL) then this is an unused chunk of | |
| 4885 string storage. (See below.) */ | |
| 4886 | |
| 4887 if (STRING_CHARS_FREE_P (s_chars)) | |
| 428 | 4888 { |
| 4889 fullsize = ((struct unused_string_chars *) s_chars)->fullsize; | |
| 4890 pos += fullsize; | |
| 4891 continue; | |
| 4892 } | |
| 4893 | |
| 4894 string = s_chars->string; | |
| 4895 /* Must be 32-bit aligned. */ | |
| 4896 assert ((((int) string) & 3) == 0); | |
| 4897 | |
| 793 | 4898 size = string->size_; |
| 428 | 4899 fullsize = STRING_FULLSIZE (size); |
| 4900 | |
| 4901 assert (!BIG_STRING_FULLSIZE_P (fullsize)); | |
| 2720 | 4902 assert (XSTRING_DATA (string) == s_chars->chars); |
| 428 | 4903 pos += fullsize; |
| 4904 } | |
| 4905 assert (pos == sb->pos); | |
| 4906 } | |
| 4907 } | |
| 4908 | |
| 1204 | 4909 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */ |
| 428 | 4910 |
| 4911 /* Compactify string chars, relocating the reference to each -- | |
| 4912 free any empty string_chars_block we see. */ | |
| 4913 static void | |
| 4914 compact_string_chars (void) | |
| 4915 { | |
| 4916 struct string_chars_block *to_sb = first_string_chars_block; | |
| 4917 int to_pos = 0; | |
| 4918 struct string_chars_block *from_sb; | |
| 4919 | |
| 4920 /* Scan each existing string block sequentially, string by string. */ | |
| 4921 for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next) | |
| 4922 { | |
| 4923 int from_pos = 0; | |
| 4924 /* FROM_POS is the index of the next string in the block. */ | |
| 4925 while (from_pos < from_sb->pos) | |
| 4926 { | |
| 4927 struct string_chars *from_s_chars = | |
| 4928 (struct string_chars *) &(from_sb->string_chars[from_pos]); | |
| 4929 struct string_chars *to_s_chars; | |
| 438 | 4930 Lisp_String *string; |
| 428 | 4931 int size; |
| 4932 int fullsize; | |
| 4933 | |
| 454 | 4934 /* If the string_chars struct is marked as free (i.e. the |
| 4935 STRING pointer is NULL) then this is an unused chunk of | |
| 4936 string storage. This happens under Mule when a string's | |
| 4937 size changes in such a way that its fullsize changes. | |
| 4938 (Strings can change size because a different-length | |
| 4939 character can be substituted for another character.) | |
| 4940 In this case, after the bogus string pointer is the | |
| 4941 "fullsize" of this entry, i.e. how many bytes to skip. */ | |
| 4942 | |
| 4943 if (STRING_CHARS_FREE_P (from_s_chars)) | |
| 428 | 4944 { |
| 4945 fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize; | |
| 4946 from_pos += fullsize; | |
| 4947 continue; | |
| 4948 } | |
| 4949 | |
| 4950 string = from_s_chars->string; | |
| 1204 | 4951 gc_checking_assert (!(LRECORD_FREE_P (string))); |
| 428 | 4952 |
| 793 | 4953 size = string->size_; |
| 428 | 4954 fullsize = STRING_FULLSIZE (size); |
| 4955 | |
| 442 | 4956 gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize)); |
| 428 | 4957 |
| 4958 /* Just skip it if it isn't marked. */ | |
| 771 | 4959 if (! MARKED_RECORD_HEADER_P (&(string->u.lheader))) |
| 428 | 4960 { |
| 4961 from_pos += fullsize; | |
| 4962 continue; | |
| 4963 } | |
| 4964 | |
| 4965 /* If it won't fit in what's left of TO_SB, close TO_SB out | |
| 4966 and go on to the next string_chars_block. We know that TO_SB | |
| 4967 cannot advance past FROM_SB here since FROM_SB is large enough | |
| 4968 to currently contain this string. */ | |
| 4969 if ((to_pos + fullsize) > countof (to_sb->string_chars)) | |
| 4970 { | |
| 4971 to_sb->pos = to_pos; | |
| 4972 to_sb = to_sb->next; | |
| 4973 to_pos = 0; | |
| 4974 } | |
| 4975 | |
| 4976 /* Compute new address of this string | |
| 4977 and update TO_POS for the space being used. */ | |
| 4978 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]); | |
| 4979 | |
| 4980 /* Copy the string_chars to the new place. */ | |
| 4981 if (from_s_chars != to_s_chars) | |
| 4982 memmove (to_s_chars, from_s_chars, fullsize); | |
| 4983 | |
| 4984 /* Relocate FROM_S_CHARS's reference */ | |
| 826 | 4985 set_lispstringp_data (string, &(to_s_chars->chars[0])); |
| 428 | 4986 |
| 4987 from_pos += fullsize; | |
| 4988 to_pos += fullsize; | |
| 4989 } | |
| 4990 } | |
| 4991 | |
| 4992 /* Set current to the last string chars block still used and | |
| 4993 free any that follow. */ | |
| 4994 { | |
| 4995 struct string_chars_block *victim; | |
| 4996 | |
| 4997 for (victim = to_sb->next; victim; ) | |
| 4998 { | |
| 4999 struct string_chars_block *next = victim->next; | |
| 1726 | 5000 xfree (victim, struct string_chars_block *); |
| 428 | 5001 victim = next; |
| 5002 } | |
| 5003 | |
| 5004 current_string_chars_block = to_sb; | |
| 5005 current_string_chars_block->pos = to_pos; | |
| 5006 current_string_chars_block->next = 0; | |
| 5007 } | |
| 5008 } | |
| 5009 | |
| 2720 | 5010 #ifndef MC_ALLOC |
| 428 | 5011 #if 1 /* Hack to debug missing purecopy's */ |
| 5012 static int debug_string_purity; | |
| 5013 | |
| 5014 static void | |
| 793 | 5015 debug_string_purity_print (Lisp_Object p) |
| 428 | 5016 { |
| 5017 Charcount i; | |
| 826 | 5018 Charcount s = string_char_length (p); |
| 442 | 5019 stderr_out ("\""); |
| 428 | 5020 for (i = 0; i < s; i++) |
| 5021 { | |
| 867 | 5022 Ichar ch = string_ichar (p, i); |
| 428 | 5023 if (ch < 32 || ch >= 126) |
| 5024 stderr_out ("\\%03o", ch); | |
| 5025 else if (ch == '\\' || ch == '\"') | |
| 5026 stderr_out ("\\%c", ch); | |
| 5027 else | |
| 5028 stderr_out ("%c", ch); | |
| 5029 } | |
| 5030 stderr_out ("\"\n"); | |
| 5031 } | |
| 5032 #endif /* 1 */ | |
| 2720 | 5033 #endif /* not MC_ALLOC */ |
| 5034 | |
| 5035 #ifndef MC_ALLOC | |
| 428 | 5036 static void |
| 5037 sweep_strings (void) | |
| 5038 { | |
| 647 | 5039 int num_small_used = 0; |
| 5040 Bytecount num_small_bytes = 0, num_bytes = 0; | |
| 428 | 5041 int debug = debug_string_purity; |
| 5042 | |
| 793 | 5043 #define UNMARK_string(ptr) do { \ |
| 5044 Lisp_String *p = (ptr); \ | |
| 5045 Bytecount size = p->size_; \ | |
| 5046 UNMARK_RECORD_HEADER (&(p->u.lheader)); \ | |
| 5047 num_bytes += size; \ | |
| 5048 if (!BIG_STRING_SIZE_P (size)) \ | |
| 5049 { \ | |
| 5050 num_small_bytes += size; \ | |
| 5051 num_small_used++; \ | |
| 5052 } \ | |
| 5053 if (debug) \ | |
| 5054 debug_string_purity_print (wrap_string (p)); \ | |
| 438 | 5055 } while (0) |
| 5056 #define ADDITIONAL_FREE_string(ptr) do { \ | |
| 793 | 5057 Bytecount size = ptr->size_; \ |
| 438 | 5058 if (BIG_STRING_SIZE_P (size)) \ |
| 1726 | 5059 xfree (ptr->data_, Ibyte *); \ |
| 438 | 5060 } while (0) |
| 5061 | |
| 771 | 5062 SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); |
| 428 | 5063 |
| 5064 gc_count_num_short_string_in_use = num_small_used; | |
| 5065 gc_count_string_total_size = num_bytes; | |
| 5066 gc_count_short_string_total_size = num_small_bytes; | |
| 5067 } | |
| 2720 | 5068 #endif /* not MC_ALLOC */ |
| 428 | 5069 |
| 5070 /* I hate duplicating all this crap! */ | |
| 5071 int | |
| 5072 marked_p (Lisp_Object obj) | |
| 5073 { | |
| 5074 /* Checks we used to perform. */ | |
| 5075 /* if (EQ (obj, Qnull_pointer)) return 1; */ | |
| 5076 /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ | |
| 5077 /* if (PURIFIED (XPNTR (obj))) return 1; */ | |
| 5078 | |
| 5079 if (XTYPE (obj) == Lisp_Type_Record) | |
| 5080 { | |
| 5081 struct lrecord_header *lheader = XRECORD_LHEADER (obj); | |
| 442 | 5082 |
| 5083 GC_CHECK_LHEADER_INVARIANTS (lheader); | |
| 5084 | |
| 5085 return MARKED_RECORD_HEADER_P (lheader); | |
| 428 | 5086 } |
| 5087 return 1; | |
| 5088 } | |
| 5089 | |
| 5090 static void | |
| 5091 gc_sweep (void) | |
| 5092 { | |
| 2720 | 5093 #ifdef MC_ALLOC |
| 5094 compact_string_chars (); | |
| 5095 mc_finalize (); | |
| 5096 mc_sweep (); | |
| 5097 #else /* not MC_ALLOC */ | |
| 428 | 5098 /* Free all unmarked records. Do this at the very beginning, |
| 5099 before anything else, so that the finalize methods can safely | |
| 5100 examine items in the objects. sweep_lcrecords_1() makes | |
| 5101 sure to call all the finalize methods *before* freeing anything, | |
| 5102 to complete the safety. */ | |
| 5103 { | |
| 5104 int ignored; | |
| 5105 sweep_lcrecords_1 (&all_lcrecords, &ignored); | |
| 5106 } | |
| 5107 | |
| 5108 compact_string_chars (); | |
| 5109 | |
| 5110 /* Finalize methods below (called through the ADDITIONAL_FREE_foo | |
| 5111 macros) must be *extremely* careful to make sure they're not | |
| 5112 referencing freed objects. The only two existing finalize | |
| 5113 methods (for strings and markers) pass muster -- the string | |
| 5114 finalizer doesn't look at anything but its own specially- | |
| 5115 created block, and the marker finalizer only looks at live | |
| 5116 buffers (which will never be freed) and at the markers before | |
| 5117 and after it in the chain (which, by induction, will never be | |
| 5118 freed because if so, they would have already removed themselves | |
| 5119 from the chain). */ | |
| 5120 | |
| 5121 /* Put all unmarked strings on free list, free'ing the string chars | |
| 5122 of large unmarked strings */ | |
| 5123 sweep_strings (); | |
| 5124 | |
| 5125 /* Put all unmarked conses on free list */ | |
| 5126 sweep_conses (); | |
| 5127 | |
| 5128 /* Free all unmarked compiled-function objects */ | |
| 5129 sweep_compiled_functions (); | |
| 5130 | |
| 5131 /* Put all unmarked floats on free list */ | |
| 5132 sweep_floats (); | |
| 5133 | |
| 1983 | 5134 #ifdef HAVE_BIGNUM |
| 5135 /* Put all unmarked bignums on free list */ | |
| 5136 sweep_bignums (); | |
| 5137 #endif | |
| 5138 | |
| 5139 #ifdef HAVE_RATIO | |
| 5140 /* Put all unmarked ratios on free list */ | |
| 5141 sweep_ratios (); | |
| 5142 #endif | |
| 5143 | |
| 5144 #ifdef HAVE_BIGFLOAT | |
| 5145 /* Put all unmarked bigfloats on free list */ | |
| 5146 sweep_bigfloats (); | |
| 5147 #endif | |
| 5148 | |
| 428 | 5149 /* Put all unmarked symbols on free list */ |
| 5150 sweep_symbols (); | |
| 5151 | |
| 5152 /* Put all unmarked extents on free list */ | |
| 5153 sweep_extents (); | |
| 5154 | |
| 5155 /* Put all unmarked markers on free list. | |
| 5156 Dechain each one first from the buffer into which it points. */ | |
| 5157 sweep_markers (); | |
| 5158 | |
| 5159 sweep_events (); | |
| 5160 | |
| 1204 | 5161 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 5162 sweep_key_data (); |
| 5163 sweep_button_data (); | |
| 5164 sweep_motion_data (); | |
| 5165 sweep_process_data (); | |
| 5166 sweep_timeout_data (); | |
| 5167 sweep_magic_data (); | |
| 5168 sweep_magic_eval_data (); | |
| 5169 sweep_eval_data (); | |
| 5170 sweep_misc_user_data (); | |
| 1204 | 5171 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 2720 | 5172 #endif /* not MC_ALLOC */ |
| 5173 | |
| 5174 #ifndef MC_ALLOC | |
| 428 | 5175 #ifdef PDUMP |
| 442 | 5176 pdump_objects_unmark (); |
| 428 | 5177 #endif |
| 2720 | 5178 #endif /* not MC_ALLOC */ |
| 428 | 5179 } |
| 5180 | |
| 5181 /* Clearing for disksave. */ | |
| 5182 | |
| 5183 void | |
| 5184 disksave_object_finalization (void) | |
| 5185 { | |
| 5186 /* It's important that certain information from the environment not get | |
| 5187 dumped with the executable (pathnames, environment variables, etc.). | |
| 5188 To make it easier to tell when this has happened with strings(1) we | |
| 5189 clear some known-to-be-garbage blocks of memory, so that leftover | |
| 5190 results of old evaluation don't look like potential problems. | |
| 5191 But first we set some notable variables to nil and do one more GC, | |
| 5192 to turn those strings into garbage. | |
| 440 | 5193 */ |
| 428 | 5194 |
| 5195 /* Yeah, this list is pretty ad-hoc... */ | |
| 5196 Vprocess_environment = Qnil; | |
| 771 | 5197 env_initted = 0; |
| 428 | 5198 Vexec_directory = Qnil; |
| 5199 Vdata_directory = Qnil; | |
| 5200 Vsite_directory = Qnil; | |
| 5201 Vdoc_directory = Qnil; | |
| 5202 Vexec_path = Qnil; | |
| 5203 Vload_path = Qnil; | |
| 5204 /* Vdump_load_path = Qnil; */ | |
| 5205 /* Release hash tables for locate_file */ | |
| 5206 Flocate_file_clear_hashing (Qt); | |
| 771 | 5207 uncache_home_directory (); |
| 776 | 5208 zero_out_command_line_status_vars (); |
| 872 | 5209 clear_default_devices (); |
| 428 | 5210 |
| 5211 #if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \ | |
| 5212 defined(LOADHIST_BUILTIN)) | |
| 5213 Vload_history = Qnil; | |
| 5214 #endif | |
| 5215 Vshell_file_name = Qnil; | |
| 5216 | |
| 5217 garbage_collect_1 (); | |
| 5218 | |
| 5219 /* Run the disksave finalization methods of all live objects. */ | |
| 5220 disksave_object_finalization_1 (); | |
| 5221 | |
| 5222 /* Zero out the uninitialized (really, unused) part of the containers | |
| 5223 for the live strings. */ | |
| 5224 { | |
| 5225 struct string_chars_block *scb; | |
| 5226 for (scb = first_string_chars_block; scb; scb = scb->next) | |
| 5227 { | |
| 5228 int count = sizeof (scb->string_chars) - scb->pos; | |
| 5229 | |
| 5230 assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE); | |
| 440 | 5231 if (count != 0) |
| 5232 { | |
| 5233 /* from the block's fill ptr to the end */ | |
| 5234 memset ((scb->string_chars + scb->pos), 0, count); | |
| 5235 } | |
| 428 | 5236 } |
| 5237 } | |
| 5238 | |
| 5239 /* There, that ought to be enough... */ | |
| 5240 | |
| 5241 } | |
| 5242 | |
| 5243 | |
| 771 | 5244 int |
| 5245 begin_gc_forbidden (void) | |
| 5246 { | |
| 853 | 5247 return internal_bind_int (&gc_currently_forbidden, 1); |
| 771 | 5248 } |
| 5249 | |
| 5250 void | |
| 5251 end_gc_forbidden (int count) | |
| 5252 { | |
| 5253 unbind_to (count); | |
| 5254 } | |
| 5255 | |
| 428 | 5256 /* Maybe we want to use this when doing a "panic" gc after memory_full()? */ |
| 5257 static int gc_hooks_inhibited; | |
| 5258 | |
| 611 | 5259 struct post_gc_action |
| 5260 { | |
| 5261 void (*fun) (void *); | |
| 5262 void *arg; | |
| 5263 }; | |
| 5264 | |
| 5265 typedef struct post_gc_action post_gc_action; | |
| 5266 | |
| 5267 typedef struct | |
| 5268 { | |
| 5269 Dynarr_declare (post_gc_action); | |
| 5270 } post_gc_action_dynarr; | |
| 5271 | |
| 5272 static post_gc_action_dynarr *post_gc_actions; | |
| 5273 | |
| 5274 /* Register an action to be called at the end of GC. | |
| 5275 gc_in_progress is 0 when this is called. | |
| 5276 This is used when it is discovered that an action needs to be taken, | |
| 5277 but it's during GC, so it's not safe. (e.g. in a finalize method.) | |
| 5278 | |
| 5279 As a general rule, do not use Lisp objects here. | |
| 5280 And NEVER signal an error. | |
| 5281 */ | |
| 5282 | |
| 5283 void | |
| 5284 register_post_gc_action (void (*fun) (void *), void *arg) | |
| 5285 { | |
| 5286 post_gc_action action; | |
| 5287 | |
| 5288 if (!post_gc_actions) | |
| 5289 post_gc_actions = Dynarr_new (post_gc_action); | |
| 5290 | |
| 5291 action.fun = fun; | |
| 5292 action.arg = arg; | |
| 5293 | |
| 5294 Dynarr_add (post_gc_actions, action); | |
| 5295 } | |
| 5296 | |
| 5297 static void | |
| 5298 run_post_gc_actions (void) | |
| 5299 { | |
| 5300 int i; | |
| 5301 | |
| 5302 if (post_gc_actions) | |
| 5303 { | |
| 5304 for (i = 0; i < Dynarr_length (post_gc_actions); i++) | |
| 5305 { | |
| 5306 post_gc_action action = Dynarr_at (post_gc_actions, i); | |
| 5307 (action.fun) (action.arg); | |
| 5308 } | |
| 5309 | |
| 5310 Dynarr_reset (post_gc_actions); | |
| 5311 } | |
| 5312 } | |
| 5313 | |
| 428 | 5314 |
| 5315 void | |
| 5316 garbage_collect_1 (void) | |
| 5317 { | |
| 5318 #if MAX_SAVE_STACK > 0 | |
| 5319 char stack_top_variable; | |
| 5320 extern char *stack_bottom; | |
| 5321 #endif | |
| 5322 struct frame *f; | |
| 5323 int speccount; | |
| 5324 int cursor_changed; | |
| 5325 Lisp_Object pre_gc_cursor; | |
| 5326 struct gcpro gcpro1; | |
| 1292 | 5327 PROFILE_DECLARE (); |
| 428 | 5328 |
| 1123 | 5329 assert (!in_display || gc_currently_forbidden); |
| 5330 | |
| 428 | 5331 if (gc_in_progress |
| 5332 || gc_currently_forbidden | |
| 5333 || in_display | |
| 5334 || preparing_for_armageddon) | |
| 5335 return; | |
| 5336 | |
| 1292 | 5337 PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection); |
| 5338 | |
| 428 | 5339 /* We used to call selected_frame() here. |
| 5340 | |
| 5341 The following functions cannot be called inside GC | |
| 5342 so we move to after the above tests. */ | |
| 5343 { | |
| 5344 Lisp_Object frame; | |
| 5345 Lisp_Object device = Fselected_device (Qnil); | |
| 5346 if (NILP (device)) /* Could happen during startup, eg. if always_gc */ | |
| 5347 return; | |
| 872 | 5348 frame = Fselected_frame (device); |
| 428 | 5349 if (NILP (frame)) |
| 563 | 5350 invalid_state ("No frames exist on device", device); |
| 428 | 5351 f = XFRAME (frame); |
| 5352 } | |
| 5353 | |
| 5354 pre_gc_cursor = Qnil; | |
| 5355 cursor_changed = 0; | |
| 5356 | |
| 5357 GCPRO1 (pre_gc_cursor); | |
| 5358 | |
| 5359 /* Very important to prevent GC during any of the following | |
| 5360 stuff that might run Lisp code; otherwise, we'll likely | |
| 5361 have infinite GC recursion. */ | |
| 771 | 5362 speccount = begin_gc_forbidden (); |
| 428 | 5363 |
| 887 | 5364 need_to_signal_post_gc = 0; |
| 1318 | 5365 recompute_funcall_allocation_flag (); |
| 887 | 5366 |
| 428 | 5367 if (!gc_hooks_inhibited) |
| 853 | 5368 run_hook_trapping_problems |
| 1333 | 5369 (Qgarbage_collecting, Qpre_gc_hook, |
| 853 | 5370 INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); |
| 428 | 5371 |
| 5372 /* Now show the GC cursor/message. */ | |
| 5373 if (!noninteractive) | |
| 5374 { | |
| 5375 if (FRAME_WIN_P (f)) | |
| 5376 { | |
| 771 | 5377 Lisp_Object frame = wrap_frame (f); |
| 428 | 5378 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph, |
| 5379 FRAME_SELECTED_WINDOW (f), | |
| 5380 ERROR_ME_NOT, 1); | |
| 5381 pre_gc_cursor = f->pointer; | |
| 5382 if (POINTER_IMAGE_INSTANCEP (cursor) | |
| 5383 /* don't change if we don't know how to change back. */ | |
| 5384 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor)) | |
| 5385 { | |
| 5386 cursor_changed = 1; | |
| 5387 Fset_frame_pointer (frame, cursor); | |
| 5388 } | |
| 5389 } | |
| 5390 | |
| 5391 /* Don't print messages to the stream device. */ | |
| 5392 if (!cursor_changed && !FRAME_STREAM_P (f)) | |
| 5393 { | |
| 1154 | 5394 if (garbage_collection_messages) |
| 5395 { | |
| 5396 Lisp_Object args[2], whole_msg; | |
| 5397 args[0] = (STRINGP (Vgc_message) ? Vgc_message : | |
| 5398 build_msg_string (gc_default_message)); | |
| 5399 args[1] = build_string ("..."); | |
| 5400 whole_msg = Fconcat (2, args); | |
| 5401 echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1, | |
| 5402 Qgarbage_collecting); | |
| 5403 } | |
| 428 | 5404 } |
| 5405 } | |
| 5406 | |
| 5407 /***** Now we actually start the garbage collection. */ | |
| 5408 | |
| 5409 gc_in_progress = 1; | |
| 2367 | 5410 inhibit_non_essential_conversion_operations = 1; |
| 428 | 5411 |
| 5412 gc_generation_number[0]++; | |
| 5413 | |
| 5414 #if MAX_SAVE_STACK > 0 | |
| 5415 | |
| 5416 /* Save a copy of the contents of the stack, for debugging. */ | |
| 5417 if (!purify_flag) | |
| 5418 { | |
| 5419 /* Static buffer in which we save a copy of the C stack at each GC. */ | |
| 5420 static char *stack_copy; | |
| 665 | 5421 static Bytecount stack_copy_size; |
| 428 | 5422 |
| 5423 ptrdiff_t stack_diff = &stack_top_variable - stack_bottom; | |
| 665 | 5424 Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff); |
| 428 | 5425 if (stack_size < MAX_SAVE_STACK) |
| 5426 { | |
| 5427 if (stack_copy_size < stack_size) | |
| 5428 { | |
| 5429 stack_copy = (char *) xrealloc (stack_copy, stack_size); | |
| 5430 stack_copy_size = stack_size; | |
| 5431 } | |
| 5432 | |
| 5433 memcpy (stack_copy, | |
| 5434 stack_diff > 0 ? stack_bottom : &stack_top_variable, | |
| 5435 stack_size); | |
| 5436 } | |
| 5437 } | |
| 5438 #endif /* MAX_SAVE_STACK > 0 */ | |
| 5439 | |
| 5440 /* Do some totally ad-hoc resource clearing. */ | |
| 5441 /* #### generalize this? */ | |
| 5442 clear_event_resource (); | |
| 5443 cleanup_specifiers (); | |
| 1204 | 5444 cleanup_buffer_undo_lists (); |
| 428 | 5445 |
| 5446 /* Mark all the special slots that serve as the roots of accessibility. */ | |
| 5447 | |
| 1598 | 5448 #ifdef USE_KKCC |
| 5449 /* initialize kkcc stack */ | |
| 5450 kkcc_gc_stack_init(); | |
| 2645 | 5451 #define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1) |
| 1598 | 5452 #endif /* USE_KKCC */ |
| 5453 | |
| 428 | 5454 { /* staticpro() */ |
| 452 | 5455 Lisp_Object **p = Dynarr_begin (staticpros); |
| 665 | 5456 Elemcount count; |
| 452 | 5457 for (count = Dynarr_length (staticpros); count; count--) |
| 5458 mark_object (**p++); | |
| 5459 } | |
| 5460 | |
| 5461 { /* staticpro_nodump() */ | |
| 5462 Lisp_Object **p = Dynarr_begin (staticpros_nodump); | |
| 665 | 5463 Elemcount count; |
| 452 | 5464 for (count = Dynarr_length (staticpros_nodump); count; count--) |
| 5465 mark_object (**p++); | |
| 428 | 5466 } |
| 5467 | |
| 2720 | 5468 #ifdef MC_ALLOC |
| 5469 { /* mcpro () */ | |
| 5470 Lisp_Object *p = Dynarr_begin (mcpros); | |
| 5471 Elemcount count; | |
| 5472 for (count = Dynarr_length (mcpros); count; count--) | |
| 5473 mark_object (*p++); | |
| 5474 } | |
| 5475 #endif /* MC_ALLOC */ | |
| 5476 | |
| 428 | 5477 { /* GCPRO() */ |
| 5478 struct gcpro *tail; | |
| 5479 int i; | |
| 5480 for (tail = gcprolist; tail; tail = tail->next) | |
| 5481 for (i = 0; i < tail->nvars; i++) | |
| 5482 mark_object (tail->var[i]); | |
| 5483 } | |
| 5484 | |
| 5485 { /* specbind() */ | |
| 5486 struct specbinding *bind; | |
| 5487 for (bind = specpdl; bind != specpdl_ptr; bind++) | |
| 5488 { | |
| 5489 mark_object (bind->symbol); | |
| 5490 mark_object (bind->old_value); | |
| 5491 } | |
| 5492 } | |
| 5493 | |
| 5494 { | |
| 5495 struct catchtag *catch; | |
| 5496 for (catch = catchlist; catch; catch = catch->next) | |
| 5497 { | |
| 5498 mark_object (catch->tag); | |
| 5499 mark_object (catch->val); | |
| 853 | 5500 mark_object (catch->actual_tag); |
| 2532 | 5501 mark_object (catch->backtrace); |
| 428 | 5502 } |
| 5503 } | |
| 5504 | |
| 5505 { | |
| 5506 struct backtrace *backlist; | |
| 5507 for (backlist = backtrace_list; backlist; backlist = backlist->next) | |
| 5508 { | |
| 5509 int nargs = backlist->nargs; | |
| 5510 int i; | |
| 5511 | |
| 5512 mark_object (*backlist->function); | |
| 1292 | 5513 if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */ |
| 5514 /* might be fake (internal profiling entry) */ | |
| 5515 && backlist->args) | |
| 428 | 5516 mark_object (backlist->args[0]); |
| 5517 else | |
| 5518 for (i = 0; i < nargs; i++) | |
| 5519 mark_object (backlist->args[i]); | |
| 5520 } | |
| 5521 } | |
| 5522 | |
| 5523 mark_profiling_info (); | |
| 5524 | |
| 5525 /* OK, now do the after-mark stuff. This is for things that | |
| 5526 are only marked when something else is marked (e.g. weak hash tables). | |
| 5527 There may be complex dependencies between such objects -- e.g. | |
| 5528 a weak hash table might be unmarked, but after processing a later | |
| 5529 weak hash table, the former one might get marked. So we have to | |
| 5530 iterate until nothing more gets marked. */ | |
| 1598 | 5531 #ifdef USE_KKCC |
| 5532 kkcc_marking (); | |
| 5533 #endif /* USE_KKCC */ | |
| 1590 | 5534 init_marking_ephemerons (); |
| 428 | 5535 while (finish_marking_weak_hash_tables () > 0 || |
| 887 | 5536 finish_marking_weak_lists () > 0 || |
| 1590 | 5537 continue_marking_ephemerons () > 0) |
|
1773
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5538 #ifdef USE_KKCC |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5539 { |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5540 kkcc_marking (); |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5541 } |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5542 #else /* NOT USE_KKCC */ |
| 1590 | 5543 ; |
| 1598 | 5544 #endif /* USE_KKCC */ |
| 5545 | |
| 1590 | 5546 /* At this point, we know which objects need to be finalized: we |
| 5547 still need to resurrect them */ | |
| 5548 | |
| 5549 while (finish_marking_ephemerons () > 0 || | |
| 5550 finish_marking_weak_lists () > 0 || | |
| 5551 finish_marking_weak_hash_tables () > 0) | |
| 1643 | 5552 #ifdef USE_KKCC |
|
1773
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5553 { |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5554 kkcc_marking (); |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5555 } |
| 1643 | 5556 kkcc_gc_stack_free (); |
| 1676 | 5557 #undef mark_object |
|
1773
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5558 #else /* NOT USE_KKCC */ |
|
aa0db78e67c4
[xemacs-hg @ 2003-11-01 14:54:53 by kaltenbach]
kaltenbach
parents:
1739
diff
changeset
|
5559 ; |
| 1643 | 5560 #endif /* USE_KKCC */ |
| 5561 | |
| 428 | 5562 /* And prune (this needs to be called after everything else has been |
| 5563 marked and before we do any sweeping). */ | |
| 5564 /* #### this is somewhat ad-hoc and should probably be an object | |
| 5565 method */ | |
| 5566 prune_weak_hash_tables (); | |
| 5567 prune_weak_lists (); | |
| 5568 prune_specifiers (); | |
| 5569 prune_syntax_tables (); | |
| 5570 | |
| 887 | 5571 prune_ephemerons (); |
| 858 | 5572 prune_weak_boxes (); |
| 5573 | |
| 428 | 5574 gc_sweep (); |
| 5575 | |
| 5576 consing_since_gc = 0; | |
| 5577 #ifndef DEBUG_XEMACS | |
| 5578 /* Allow you to set it really fucking low if you really want ... */ | |
| 5579 if (gc_cons_threshold < 10000) | |
| 5580 gc_cons_threshold = 10000; | |
| 5581 #endif | |
| 814 | 5582 recompute_need_to_garbage_collect (); |
| 428 | 5583 |
| 2367 | 5584 inhibit_non_essential_conversion_operations = 0; |
| 428 | 5585 gc_in_progress = 0; |
| 5586 | |
| 611 | 5587 run_post_gc_actions (); |
| 5588 | |
| 428 | 5589 /******* End of garbage collection ********/ |
| 5590 | |
| 5591 /* Now remove the GC cursor/message */ | |
| 5592 if (!noninteractive) | |
| 5593 { | |
| 5594 if (cursor_changed) | |
| 771 | 5595 Fset_frame_pointer (wrap_frame (f), pre_gc_cursor); |
| 428 | 5596 else if (!FRAME_STREAM_P (f)) |
| 5597 { | |
| 5598 /* Show "...done" only if the echo area would otherwise be empty. */ | |
| 5599 if (NILP (clear_echo_area (selected_frame (), | |
| 5600 Qgarbage_collecting, 0))) | |
| 5601 { | |
| 1154 | 5602 if (garbage_collection_messages) |
| 5603 { | |
| 5604 Lisp_Object args[2], whole_msg; | |
| 5605 args[0] = (STRINGP (Vgc_message) ? Vgc_message : | |
| 5606 build_msg_string (gc_default_message)); | |
| 5607 args[1] = build_msg_string ("... done"); | |
| 5608 whole_msg = Fconcat (2, args); | |
| 5609 echo_area_message (selected_frame (), (Ibyte *) 0, | |
| 5610 whole_msg, 0, -1, | |
| 5611 Qgarbage_collecting); | |
| 5612 } | |
| 428 | 5613 } |
| 5614 } | |
| 5615 } | |
| 5616 | |
| 5617 /* now stop inhibiting GC */ | |
| 771 | 5618 unbind_to (speccount); |
| 428 | 5619 |
| 2720 | 5620 #ifndef MC_ALLOC |
| 428 | 5621 if (!breathing_space) |
| 5622 { | |
| 5623 breathing_space = malloc (4096 - MALLOC_OVERHEAD); | |
| 5624 } | |
| 2720 | 5625 #endif /* not MC_ALLOC */ |
| 428 | 5626 |
| 5627 UNGCPRO; | |
| 887 | 5628 |
| 5629 need_to_signal_post_gc = 1; | |
| 5630 funcall_allocation_flag = 1; | |
| 5631 | |
| 1292 | 5632 PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection); |
| 5633 | |
| 428 | 5634 return; |
| 5635 } | |
| 5636 | |
| 2720 | 5637 #ifdef MC_ALLOC |
| 5638 #ifdef MC_ALLOC_TYPE_STATS | |
| 5639 static Lisp_Object | |
| 5640 gc_plist_hack (const Ascbyte *name, int value, Lisp_Object tail) | |
| 5641 { | |
| 5642 /* C doesn't have local functions (or closures, or GC, or readable syntax, | |
| 5643 or portable numeric datatypes, or bit-vectors, or characters, or | |
| 5644 arrays, or exceptions, or ...) */ | |
| 5645 return cons3 (intern (name), make_int (value), tail); | |
| 5646 } | |
| 5647 #endif /* MC_ALLOC_TYPE_STATS */ | |
| 5648 | |
| 5649 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* | |
| 5650 Reclaim storage for Lisp objects no longer needed. | |
| 5651 Return info on amount of space in use: | |
| 5652 ((USED-CONSES . STORAGE-CONSES) (USED-SYMS . STORAGE-SYMS) | |
| 5653 (USED-MARKERS . STORAGE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS | |
| 5654 PLIST) | |
| 5655 where `PLIST' is a list of alternating keyword/value pairs providing | |
| 5656 more detailed information. | |
| 5657 Garbage collection happens automatically if you cons more than | |
| 5658 `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
| 5659 */ | |
| 5660 ()) | |
| 5661 { | |
| 5662 #ifdef MC_ALLOC_TYPE_STATS | |
| 5663 Lisp_Object pl = Qnil; | |
| 5664 int i; | |
| 5665 #endif /* not MC_ALLOC_TYPE_STATS */ | |
| 5666 | |
| 5667 garbage_collect_1 (); | |
| 5668 | |
| 5669 #ifdef MC_ALLOC_TYPE_STATS | |
| 5670 for (i = 0; i < (countof (lrecord_implementations_table) | |
| 5671 + MODULE_DEFINABLE_TYPE_COUNT); i++) | |
| 5672 { | |
| 5673 if (lrecord_stats[i].instances_in_use != 0) | |
| 5674 { | |
| 5675 char buf [255]; | |
| 5676 const char *name = lrecord_implementations_table[i]->name; | |
| 5677 int len = strlen (name); | |
| 5678 | |
| 5679 if (lrecord_stats[i].bytes_in_use_including_overhead != | |
| 5680 lrecord_stats[i].bytes_in_use) | |
| 5681 { | |
| 5682 sprintf (buf, "%s-storage-including-overhead", name); | |
| 5683 pl = gc_plist_hack (buf, | |
| 5684 lrecord_stats[i] | |
| 5685 .bytes_in_use_including_overhead, | |
| 5686 pl); | |
| 5687 } | |
| 5688 | |
| 5689 sprintf (buf, "%s-storage", name); | |
| 5690 pl = gc_plist_hack (buf, | |
| 5691 lrecord_stats[i].bytes_in_use, | |
| 5692 pl); | |
| 5693 | |
| 5694 if (name[len-1] == 's') | |
| 5695 sprintf (buf, "%ses-used", name); | |
| 5696 else | |
| 5697 sprintf (buf, "%ss-used", name); | |
| 5698 pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); | |
| 5699 } | |
| 5700 } | |
| 5701 | |
| 5702 /* The things we do for backwards-compatibility */ | |
| 5703 return | |
| 5704 list6 | |
| 5705 (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use), | |
| 5706 make_int (lrecord_stats[lrecord_type_cons] | |
| 5707 .bytes_in_use_including_overhead)), | |
| 5708 Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use), | |
| 5709 make_int (lrecord_stats[lrecord_type_symbol] | |
| 5710 .bytes_in_use_including_overhead)), | |
| 5711 Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use), | |
| 5712 make_int (lrecord_stats[lrecord_type_marker] | |
| 5713 .bytes_in_use_including_overhead)), | |
| 5714 make_int (lrecord_stats[lrecord_type_string] | |
| 5715 .bytes_in_use_including_overhead), | |
| 5716 make_int (lrecord_stats[lrecord_type_vector] | |
| 5717 .bytes_in_use_including_overhead), | |
| 5718 pl); | |
| 5719 #else /* not MC_ALLOC_TYPE_STATS */ | |
| 5720 return Qnil; | |
| 5721 #endif /* not MC_ALLOC_TYPE_STATS */ | |
| 5722 } | |
| 5723 #else /* not MC_ALLOC */ | |
| 428 | 5724 /* Debugging aids. */ |
| 5725 | |
| 5726 static Lisp_Object | |
| 2367 | 5727 gc_plist_hack (const Ascbyte *name, int value, Lisp_Object tail) |
| 428 | 5728 { |
| 5729 /* C doesn't have local functions (or closures, or GC, or readable syntax, | |
| 5730 or portable numeric datatypes, or bit-vectors, or characters, or | |
| 5731 arrays, or exceptions, or ...) */ | |
| 5732 return cons3 (intern (name), make_int (value), tail); | |
| 5733 } | |
| 5734 | |
| 5735 #define HACK_O_MATIC(type, name, pl) do { \ | |
| 5736 int s = 0; \ | |
| 5737 struct type##_block *x = current_##type##_block; \ | |
| 5738 while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ | |
| 5739 (pl) = gc_plist_hack ((name), s, (pl)); \ | |
| 5740 } while (0) | |
| 5741 | |
| 5742 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* | |
| 5743 Reclaim storage for Lisp objects no longer needed. | |
| 5744 Return info on amount of space in use: | |
| 5745 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS) | |
| 5746 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS | |
| 5747 PLIST) | |
| 5748 where `PLIST' is a list of alternating keyword/value pairs providing | |
| 5749 more detailed information. | |
| 5750 Garbage collection happens automatically if you cons more than | |
| 5751 `gc-cons-threshold' bytes of Lisp data since previous garbage collection. | |
| 5752 */ | |
| 5753 ()) | |
| 5754 { | |
| 5755 Lisp_Object pl = Qnil; | |
| 647 | 5756 int i; |
| 428 | 5757 int gc_count_vector_total_size = 0; |
| 5758 garbage_collect_1 (); | |
| 5759 | |
| 442 | 5760 for (i = 0; i < lrecord_type_count; i++) |
| 428 | 5761 { |
| 5762 if (lcrecord_stats[i].bytes_in_use != 0 | |
| 5763 || lcrecord_stats[i].bytes_freed != 0 | |
| 5764 || lcrecord_stats[i].instances_on_free_list != 0) | |
| 5765 { | |
| 5766 char buf [255]; | |
| 442 | 5767 const char *name = lrecord_implementations_table[i]->name; |
| 428 | 5768 int len = strlen (name); |
| 5769 /* save this for the FSFmacs-compatible part of the summary */ | |
| 460 | 5770 if (i == lrecord_type_vector) |
| 428 | 5771 gc_count_vector_total_size = |
| 5772 lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed; | |
| 5773 | |
| 5774 sprintf (buf, "%s-storage", name); | |
| 5775 pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl); | |
| 5776 /* Okay, simple pluralization check for `symbol-value-varalias' */ | |
| 5777 if (name[len-1] == 's') | |
| 5778 sprintf (buf, "%ses-freed", name); | |
| 5779 else | |
| 5780 sprintf (buf, "%ss-freed", name); | |
| 5781 if (lcrecord_stats[i].instances_freed != 0) | |
| 5782 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl); | |
| 5783 if (name[len-1] == 's') | |
| 5784 sprintf (buf, "%ses-on-free-list", name); | |
| 5785 else | |
| 5786 sprintf (buf, "%ss-on-free-list", name); | |
| 5787 if (lcrecord_stats[i].instances_on_free_list != 0) | |
| 5788 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list, | |
| 5789 pl); | |
| 5790 if (name[len-1] == 's') | |
| 5791 sprintf (buf, "%ses-used", name); | |
| 5792 else | |
| 5793 sprintf (buf, "%ss-used", name); | |
| 5794 pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl); | |
| 5795 } | |
| 5796 } | |
| 5797 | |
| 5798 HACK_O_MATIC (extent, "extent-storage", pl); | |
| 5799 pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl); | |
| 5800 pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl); | |
| 5801 HACK_O_MATIC (event, "event-storage", pl); | |
| 5802 pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl); | |
| 5803 pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl); | |
| 5804 HACK_O_MATIC (marker, "marker-storage", pl); | |
| 5805 pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl); | |
| 5806 pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl); | |
| 5807 HACK_O_MATIC (float, "float-storage", pl); | |
| 5808 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl); | |
| 5809 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl); | |
| 1983 | 5810 #ifdef HAVE_BIGNUM |
| 5811 HACK_O_MATIC (bignum, "bignum-storage", pl); | |
| 5812 pl = gc_plist_hack ("bignums-free", gc_count_num_bignum_freelist, pl); | |
| 5813 pl = gc_plist_hack ("bignums-used", gc_count_num_bignum_in_use, pl); | |
| 5814 #endif /* HAVE_BIGNUM */ | |
| 5815 #ifdef HAVE_RATIO | |
| 5816 HACK_O_MATIC (ratio, "ratio-storage", pl); | |
| 5817 pl = gc_plist_hack ("ratios-free", gc_count_num_ratio_freelist, pl); | |
| 5818 pl = gc_plist_hack ("ratios-used", gc_count_num_ratio_in_use, pl); | |
| 5819 #endif /* HAVE_RATIO */ | |
| 5820 #ifdef HAVE_BIGFLOAT | |
| 5821 HACK_O_MATIC (bigfloat, "bigfloat-storage", pl); | |
| 5822 pl = gc_plist_hack ("bigfloats-free", gc_count_num_bigfloat_freelist, pl); | |
| 5823 pl = gc_plist_hack ("bigfloats-used", gc_count_num_bigfloat_in_use, pl); | |
| 5824 #endif /* HAVE_BIGFLOAT */ | |
| 428 | 5825 HACK_O_MATIC (string, "string-header-storage", pl); |
| 5826 pl = gc_plist_hack ("long-strings-total-length", | |
| 5827 gc_count_string_total_size | |
| 5828 - gc_count_short_string_total_size, pl); | |
| 5829 HACK_O_MATIC (string_chars, "short-string-storage", pl); | |
| 5830 pl = gc_plist_hack ("short-strings-total-length", | |
| 5831 gc_count_short_string_total_size, pl); | |
| 5832 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl); | |
| 5833 pl = gc_plist_hack ("long-strings-used", | |
| 5834 gc_count_num_string_in_use | |
| 5835 - gc_count_num_short_string_in_use, pl); | |
| 5836 pl = gc_plist_hack ("short-strings-used", | |
| 5837 gc_count_num_short_string_in_use, pl); | |
| 5838 | |
| 5839 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl); | |
| 5840 pl = gc_plist_hack ("compiled-functions-free", | |
| 5841 gc_count_num_compiled_function_freelist, pl); | |
| 5842 pl = gc_plist_hack ("compiled-functions-used", | |
| 5843 gc_count_num_compiled_function_in_use, pl); | |
| 5844 | |
| 5845 HACK_O_MATIC (symbol, "symbol-storage", pl); | |
| 5846 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl); | |
| 5847 pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl); | |
| 5848 | |
| 5849 HACK_O_MATIC (cons, "cons-storage", pl); | |
| 5850 pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl); | |
| 5851 pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl); | |
| 5852 | |
| 5853 /* The things we do for backwards-compatibility */ | |
| 5854 return | |
| 5855 list6 (Fcons (make_int (gc_count_num_cons_in_use), | |
| 5856 make_int (gc_count_num_cons_freelist)), | |
| 5857 Fcons (make_int (gc_count_num_symbol_in_use), | |
| 5858 make_int (gc_count_num_symbol_freelist)), | |
| 5859 Fcons (make_int (gc_count_num_marker_in_use), | |
| 5860 make_int (gc_count_num_marker_freelist)), | |
| 5861 make_int (gc_count_string_total_size), | |
| 5862 make_int (gc_count_vector_total_size), | |
| 5863 pl); | |
| 5864 } | |
| 5865 #undef HACK_O_MATIC | |
| 2720 | 5866 #endif /* not MC_ALLOC */ |
| 428 | 5867 |
| 5868 DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /* | |
| 5869 Return the number of bytes consed since the last garbage collection. | |
| 5870 \"Consed\" is a misnomer in that this actually counts allocation | |
| 5871 of all different kinds of objects, not just conses. | |
| 5872 | |
| 5873 If this value exceeds `gc-cons-threshold', a garbage collection happens. | |
| 5874 */ | |
| 5875 ()) | |
| 5876 { | |
| 5877 return make_int (consing_since_gc); | |
| 5878 } | |
| 5879 | |
| 440 | 5880 #if 0 |
| 444 | 5881 DEFUN ("memory-limit", Fmemory_limit, 0, 0, 0, /* |
| 801 | 5882 Return the address of the last byte XEmacs has allocated, divided by 1024. |
| 5883 This may be helpful in debugging XEmacs's memory usage. | |
| 428 | 5884 The value is divided by 1024 to make sure it will fit in a lisp integer. |
| 5885 */ | |
| 5886 ()) | |
| 5887 { | |
| 5888 return make_int ((EMACS_INT) sbrk (0) / 1024); | |
| 5889 } | |
| 440 | 5890 #endif |
| 428 | 5891 |
| 801 | 5892 DEFUN ("memory-usage", Fmemory_usage, 0, 0, 0, /* |
| 5893 Return the total number of bytes used by the data segment in XEmacs. | |
| 5894 This may be helpful in debugging XEmacs's memory usage. | |
| 5895 */ | |
| 5896 ()) | |
| 5897 { | |
| 5898 return make_int (total_data_usage ()); | |
| 5899 } | |
| 5900 | |
| 851 | 5901 void |
| 5902 recompute_funcall_allocation_flag (void) | |
| 5903 { | |
| 887 | 5904 funcall_allocation_flag = |
| 5905 need_to_garbage_collect || | |
| 5906 need_to_check_c_alloca || | |
| 5907 need_to_signal_post_gc; | |
| 851 | 5908 } |
| 5909 | |
| 801 | 5910 /* True if it's time to garbage collect now. */ |
| 814 | 5911 static void |
| 5912 recompute_need_to_garbage_collect (void) | |
| 801 | 5913 { |
| 5914 if (always_gc) | |
| 814 | 5915 need_to_garbage_collect = 1; |
| 5916 else | |
| 5917 need_to_garbage_collect = | |
| 5918 (consing_since_gc > gc_cons_threshold | |
| 5919 #if 0 /* #### implement this better */ | |
| 5920 && | |
| 5921 (100 * consing_since_gc) / total_data_usage () >= | |
| 5922 gc_cons_percentage | |
| 5923 #endif /* 0 */ | |
| 5924 ); | |
| 851 | 5925 recompute_funcall_allocation_flag (); |
| 801 | 5926 } |
| 5927 | |
| 428 | 5928 |
| 5929 int | |
| 5930 object_dead_p (Lisp_Object obj) | |
| 5931 { | |
| 5932 return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || | |
| 5933 (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || | |
| 5934 (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || | |
| 5935 (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || | |
| 5936 (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || | |
| 5937 (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || | |
| 5938 (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); | |
| 5939 } | |
| 5940 | |
| 5941 #ifdef MEMORY_USAGE_STATS | |
| 5942 | |
| 5943 /* Attempt to determine the actual amount of space that is used for | |
| 5944 the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". | |
| 5945 | |
| 5946 It seems that the following holds: | |
| 5947 | |
| 5948 1. When using the old allocator (malloc.c): | |
| 5949 | |
| 5950 -- blocks are always allocated in chunks of powers of two. For | |
| 5951 each block, there is an overhead of 8 bytes if rcheck is not | |
| 5952 defined, 20 bytes if it is defined. In other words, a | |
| 5953 one-byte allocation needs 8 bytes of overhead for a total of | |
| 5954 9 bytes, and needs to have 16 bytes of memory chunked out for | |
| 5955 it. | |
| 5956 | |
| 5957 2. When using the new allocator (gmalloc.c): | |
| 5958 | |
| 5959 -- blocks are always allocated in chunks of powers of two up | |
| 5960 to 4096 bytes. Larger blocks are allocated in chunks of | |
| 5961 an integral multiple of 4096 bytes. The minimum block | |
| 5962 size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG | |
| 5963 is defined. There is no per-block overhead, but there | |
| 5964 is an overhead of 3*sizeof (size_t) for each 4096 bytes | |
| 5965 allocated. | |
| 5966 | |
| 5967 3. When using the system malloc, anything goes, but they are | |
| 5968 generally slower and more space-efficient than the GNU | |
| 5969 allocators. One possibly reasonable assumption to make | |
| 5970 for want of better data is that sizeof (void *), or maybe | |
| 5971 2 * sizeof (void *), is required as overhead and that | |
| 5972 blocks are allocated in the minimum required size except | |
| 5973 that some minimum block size is imposed (e.g. 16 bytes). */ | |
| 5974 | |
| 665 | 5975 Bytecount |
| 2286 | 5976 malloced_storage_size (void *UNUSED (ptr), Bytecount claimed_size, |
| 428 | 5977 struct overhead_stats *stats) |
| 5978 { | |
| 665 | 5979 Bytecount orig_claimed_size = claimed_size; |
| 428 | 5980 |
| 5981 #ifdef GNU_MALLOC | |
| 665 | 5982 if (claimed_size < (Bytecount) (2 * sizeof (void *))) |
| 428 | 5983 claimed_size = 2 * sizeof (void *); |
| 5984 # ifdef SUNOS_LOCALTIME_BUG | |
| 5985 if (claimed_size < 16) | |
| 5986 claimed_size = 16; | |
| 5987 # endif | |
| 5988 if (claimed_size < 4096) | |
| 5989 { | |
| 2260 | 5990 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
| 5991 int log2 = 1; | |
| 428 | 5992 |
| 5993 /* compute the log base two, more or less, then use it to compute | |
| 5994 the block size needed. */ | |
| 5995 claimed_size--; | |
| 5996 /* It's big, it's heavy, it's wood! */ | |
| 5997 while ((claimed_size /= 2) != 0) | |
| 2260 | 5998 ++log2; |
| 428 | 5999 claimed_size = 1; |
| 6000 /* It's better than bad, it's good! */ | |
| 2260 | 6001 while (log2 > 0) |
| 428 | 6002 { |
| 6003 claimed_size *= 2; | |
| 2260 | 6004 log2--; |
| 428 | 6005 } |
| 6006 /* We have to come up with some average about the amount of | |
| 6007 blocks used. */ | |
| 665 | 6008 if ((Bytecount) (rand () & 4095) < claimed_size) |
| 428 | 6009 claimed_size += 3 * sizeof (void *); |
| 6010 } | |
| 6011 else | |
| 6012 { | |
| 6013 claimed_size += 4095; | |
| 6014 claimed_size &= ~4095; | |
| 6015 claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); | |
| 6016 } | |
| 6017 | |
| 6018 #elif defined (SYSTEM_MALLOC) | |
| 6019 | |
| 6020 if (claimed_size < 16) | |
| 6021 claimed_size = 16; | |
| 6022 claimed_size += 2 * sizeof (void *); | |
| 6023 | |
| 6024 #else /* old GNU allocator */ | |
| 6025 | |
| 6026 # ifdef rcheck /* #### may not be defined here */ | |
| 6027 claimed_size += 20; | |
| 6028 # else | |
| 6029 claimed_size += 8; | |
| 6030 # endif | |
| 6031 { | |
| 2260 | 6032 /* fxg: rename log->log2 to supress gcc3 shadow warning */ |
| 6033 int log2 = 1; | |
| 428 | 6034 |
| 6035 /* compute the log base two, more or less, then use it to compute | |
| 6036 the block size needed. */ | |
| 6037 claimed_size--; | |
| 6038 /* It's big, it's heavy, it's wood! */ | |
| 6039 while ((claimed_size /= 2) != 0) | |
| 2260 | 6040 ++log2; |
| 428 | 6041 claimed_size = 1; |
| 6042 /* It's better than bad, it's good! */ | |
| 2260 | 6043 while (log2 > 0) |
| 428 | 6044 { |
| 6045 claimed_size *= 2; | |
| 2260 | 6046 log2--; |
| 428 | 6047 } |
| 6048 } | |
| 6049 | |
| 6050 #endif /* old GNU allocator */ | |
| 6051 | |
| 6052 if (stats) | |
| 6053 { | |
| 6054 stats->was_requested += orig_claimed_size; | |
| 6055 stats->malloc_overhead += claimed_size - orig_claimed_size; | |
| 6056 } | |
| 6057 return claimed_size; | |
| 6058 } | |
| 6059 | |
| 2720 | 6060 #ifndef MC_ALLOC |
| 665 | 6061 Bytecount |
| 6062 fixed_type_block_overhead (Bytecount size) | |
| 428 | 6063 { |
| 665 | 6064 Bytecount per_block = TYPE_ALLOC_SIZE (cons, unsigned char); |
| 6065 Bytecount overhead = 0; | |
| 6066 Bytecount storage_size = malloced_storage_size (0, per_block, 0); | |
| 428 | 6067 while (size >= per_block) |
| 6068 { | |
| 6069 size -= per_block; | |
| 6070 overhead += sizeof (void *) + per_block - storage_size; | |
| 6071 } | |
| 6072 if (rand () % per_block < size) | |
| 6073 overhead += sizeof (void *) + per_block - storage_size; | |
| 6074 return overhead; | |
| 6075 } | |
| 2720 | 6076 #endif /* not MC_ALLOC */ |
| 428 | 6077 #endif /* MEMORY_USAGE_STATS */ |
| 6078 | |
| 6079 | |
| 6080 /* Initialization */ | |
| 771 | 6081 static void |
| 1204 | 6082 common_init_alloc_early (void) |
| 428 | 6083 { |
| 771 | 6084 #ifndef Qzero |
| 6085 Qzero = make_int (0); /* Only used if Lisp_Object is a union type */ | |
| 6086 #endif | |
| 6087 | |
| 6088 #ifndef Qnull_pointer | |
| 6089 /* C guarantees that Qnull_pointer will be initialized to all 0 bits, | |
| 6090 so the following is actually a no-op. */ | |
| 793 | 6091 Qnull_pointer = wrap_pointer_1 (0); |
| 771 | 6092 #endif |
| 6093 | |
| 428 | 6094 gc_generation_number[0] = 0; |
| 2720 | 6095 #ifndef MC_ALLOC |
| 428 | 6096 breathing_space = 0; |
| 2720 | 6097 #endif /* not MC_ALLOC */ |
| 771 | 6098 Vgc_message = Qzero; |
| 2720 | 6099 #ifndef MC_ALLOC |
| 428 | 6100 all_lcrecords = 0; |
| 2720 | 6101 #endif /* not MC_ALLOC */ |
| 428 | 6102 ignore_malloc_warnings = 1; |
| 6103 #ifdef DOUG_LEA_MALLOC | |
| 6104 mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */ | |
| 6105 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */ | |
| 6106 #if 0 /* Moved to emacs.c */ | |
| 6107 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */ | |
| 6108 #endif | |
| 6109 #endif | |
| 2720 | 6110 init_string_chars_alloc (); |
| 6111 #ifndef MC_ALLOC | |
| 428 | 6112 init_string_alloc (); |
| 6113 init_string_chars_alloc (); | |
| 6114 init_cons_alloc (); | |
| 6115 init_symbol_alloc (); | |
| 6116 init_compiled_function_alloc (); | |
| 6117 init_float_alloc (); | |
| 1983 | 6118 #ifdef HAVE_BIGNUM |
| 6119 init_bignum_alloc (); | |
| 6120 #endif | |
| 6121 #ifdef HAVE_RATIO | |
| 6122 init_ratio_alloc (); | |
| 6123 #endif | |
| 6124 #ifdef HAVE_BIGFLOAT | |
| 6125 init_bigfloat_alloc (); | |
| 6126 #endif | |
| 428 | 6127 init_marker_alloc (); |
| 6128 init_extent_alloc (); | |
| 6129 init_event_alloc (); | |
| 1204 | 6130 #ifdef EVENT_DATA_AS_OBJECTS |
| 934 | 6131 init_key_data_alloc (); |
| 6132 init_button_data_alloc (); | |
| 6133 init_motion_data_alloc (); | |
| 6134 init_process_data_alloc (); | |
| 6135 init_timeout_data_alloc (); | |
| 6136 init_magic_data_alloc (); | |
| 6137 init_magic_eval_data_alloc (); | |
| 6138 init_eval_data_alloc (); | |
| 6139 init_misc_user_data_alloc (); | |
| 1204 | 6140 #endif /* EVENT_DATA_AS_OBJECTS */ |
| 2720 | 6141 #endif /* not MC_ALLOC */ |
| 428 | 6142 |
| 6143 ignore_malloc_warnings = 0; | |
| 6144 | |
| 452 | 6145 if (staticpros_nodump) |
| 6146 Dynarr_free (staticpros_nodump); | |
| 6147 staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); | |
| 6148 Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */ | |
| 771 | 6149 #ifdef DEBUG_XEMACS |
| 6150 if (staticpro_nodump_names) | |
| 6151 Dynarr_free (staticpro_nodump_names); | |
| 6152 staticpro_nodump_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 6153 Dynarr_resize (staticpro_nodump_names, 100); /* ditto */ | |
| 6154 #endif | |
| 428 | 6155 |
| 2720 | 6156 #ifdef MC_ALLOC |
| 6157 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); | |
| 6158 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
| 6159 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
| 6160 #ifdef DEBUG_XEMACS | |
| 6161 mcpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 6162 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ | |
| 6163 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description); | |
| 6164 #endif | |
| 6165 #endif /* MC_ALLOC */ | |
| 6166 | |
| 428 | 6167 consing_since_gc = 0; |
| 814 | 6168 need_to_garbage_collect = always_gc; |
| 851 | 6169 need_to_check_c_alloca = 0; |
| 6170 funcall_allocation_flag = 0; | |
| 6171 funcall_alloca_count = 0; | |
| 814 | 6172 |
| 428 | 6173 #if 1 |
| 6174 gc_cons_threshold = 500000; /* XEmacs change */ | |
| 6175 #else | |
| 6176 gc_cons_threshold = 15000; /* debugging */ | |
| 6177 #endif | |
| 801 | 6178 gc_cons_percentage = 0; /* #### 20; Don't have an accurate measure of |
| 6179 memory usage on Windows; not verified on other | |
| 6180 systems */ | |
| 428 | 6181 lrecord_uid_counter = 259; |
| 2720 | 6182 #ifndef MC_ALLOC |
| 428 | 6183 debug_string_purity = 0; |
| 2720 | 6184 #endif /* not MC_ALLOC */ |
| 428 | 6185 |
| 6186 gc_currently_forbidden = 0; | |
| 6187 gc_hooks_inhibited = 0; | |
| 6188 | |
| 800 | 6189 #ifdef ERROR_CHECK_TYPES |
| 428 | 6190 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = |
| 6191 666; | |
| 6192 ERROR_ME_NOT. | |
| 6193 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42; | |
| 6194 ERROR_ME_WARN. | |
| 6195 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 6196 3333632; | |
| 793 | 6197 ERROR_ME_DEBUG_WARN. |
| 6198 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = | |
| 6199 8675309; | |
| 800 | 6200 #endif /* ERROR_CHECK_TYPES */ |
| 428 | 6201 } |
| 6202 | |
| 2720 | 6203 #ifndef MC_ALLOC |
| 771 | 6204 static void |
| 6205 init_lcrecord_lists (void) | |
| 6206 { | |
| 6207 int i; | |
| 6208 | |
| 6209 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 6210 { | |
| 6211 all_lcrecord_lists[i] = Qzero; /* Qnil not yet set */ | |
| 6212 staticpro_nodump (&all_lcrecord_lists[i]); | |
| 6213 } | |
| 6214 } | |
| 2720 | 6215 #endif /* not MC_ALLOC */ |
| 771 | 6216 |
| 6217 void | |
| 1204 | 6218 init_alloc_early (void) |
| 771 | 6219 { |
| 1204 | 6220 #if defined (__cplusplus) && defined (ERROR_CHECK_GC) |
| 6221 static struct gcpro initial_gcpro; | |
| 6222 | |
| 6223 initial_gcpro.next = 0; | |
| 6224 initial_gcpro.var = &Qnil; | |
| 6225 initial_gcpro.nvars = 1; | |
| 6226 gcprolist = &initial_gcpro; | |
| 6227 #else | |
| 6228 gcprolist = 0; | |
| 6229 #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */ | |
| 6230 } | |
| 6231 | |
| 6232 void | |
| 6233 reinit_alloc_early (void) | |
| 6234 { | |
| 6235 common_init_alloc_early (); | |
| 2720 | 6236 #ifndef MC_ALLOC |
| 771 | 6237 init_lcrecord_lists (); |
| 2720 | 6238 #endif /* not MC_ALLOC */ |
| 771 | 6239 } |
| 6240 | |
| 428 | 6241 void |
| 6242 init_alloc_once_early (void) | |
| 6243 { | |
| 1204 | 6244 common_init_alloc_early (); |
| 428 | 6245 |
| 442 | 6246 { |
| 6247 int i; | |
| 6248 for (i = 0; i < countof (lrecord_implementations_table); i++) | |
| 6249 lrecord_implementations_table[i] = 0; | |
| 6250 } | |
| 6251 | |
| 6252 INIT_LRECORD_IMPLEMENTATION (cons); | |
| 6253 INIT_LRECORD_IMPLEMENTATION (vector); | |
| 6254 INIT_LRECORD_IMPLEMENTATION (string); | |
| 2720 | 6255 #ifndef MC_ALLOC |
| 442 | 6256 INIT_LRECORD_IMPLEMENTATION (lcrecord_list); |
| 1204 | 6257 INIT_LRECORD_IMPLEMENTATION (free); |
| 2720 | 6258 #endif /* not MC_ALLOC */ |
| 428 | 6259 |
| 452 | 6260 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); |
| 6261 Dynarr_resize (staticpros, 1410); /* merely a small optimization */ | |
| 2367 | 6262 dump_add_root_block_ptr (&staticpros, &staticpros_description); |
| 771 | 6263 #ifdef DEBUG_XEMACS |
| 6264 staticpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 6265 Dynarr_resize (staticpro_names, 1410); /* merely a small optimization */ | |
| 2367 | 6266 dump_add_root_block_ptr (&staticpro_names, &staticpro_names_description); |
| 771 | 6267 #endif |
| 6268 | |
| 2720 | 6269 #ifdef MC_ALLOC |
| 6270 mcpros = Dynarr_new2 (Lisp_Object_dynarr, Lisp_Object); | |
| 6271 Dynarr_resize (mcpros, 1410); /* merely a small optimization */ | |
| 6272 dump_add_root_block_ptr (&mcpros, &mcpros_description); | |
| 6273 #ifdef DEBUG_XEMACS | |
| 6274 mcpro_names = Dynarr_new2 (char_ptr_dynarr, char *); | |
| 6275 Dynarr_resize (mcpro_names, 1410); /* merely a small optimization */ | |
| 6276 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description); | |
| 6277 #endif | |
| 6278 #endif /* MC_ALLOC */ | |
| 6279 | |
| 6280 #ifndef MC_ALLOC | |
| 771 | 6281 init_lcrecord_lists (); |
| 2720 | 6282 #endif /* not MC_ALLOC */ |
| 428 | 6283 } |
| 6284 | |
| 6285 void | |
| 6286 syms_of_alloc (void) | |
| 6287 { | |
| 442 | 6288 DEFSYMBOL (Qpre_gc_hook); |
| 6289 DEFSYMBOL (Qpost_gc_hook); | |
| 6290 DEFSYMBOL (Qgarbage_collecting); | |
| 428 | 6291 |
| 6292 DEFSUBR (Fcons); | |
| 6293 DEFSUBR (Flist); | |
| 6294 DEFSUBR (Fvector); | |
| 6295 DEFSUBR (Fbit_vector); | |
| 6296 DEFSUBR (Fmake_byte_code); | |
| 6297 DEFSUBR (Fmake_list); | |
| 6298 DEFSUBR (Fmake_vector); | |
| 6299 DEFSUBR (Fmake_bit_vector); | |
| 6300 DEFSUBR (Fmake_string); | |
| 6301 DEFSUBR (Fstring); | |
| 6302 DEFSUBR (Fmake_symbol); | |
| 6303 DEFSUBR (Fmake_marker); | |
| 6304 DEFSUBR (Fpurecopy); | |
| 6305 DEFSUBR (Fgarbage_collect); | |
| 440 | 6306 #if 0 |
| 428 | 6307 DEFSUBR (Fmemory_limit); |
| 440 | 6308 #endif |
| 801 | 6309 DEFSUBR (Fmemory_usage); |
| 428 | 6310 DEFSUBR (Fconsing_since_gc); |
| 6311 } | |
| 6312 | |
| 6313 void | |
| 6314 vars_of_alloc (void) | |
| 6315 { | |
| 1292 | 6316 QSin_garbage_collection = build_msg_string ("(in garbage collection)"); |
| 6317 staticpro (&QSin_garbage_collection); | |
| 6318 | |
| 428 | 6319 DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /* |
| 6320 *Number of bytes of consing between garbage collections. | |
| 6321 \"Consing\" is a misnomer in that this actually counts allocation | |
| 6322 of all different kinds of objects, not just conses. | |
| 6323 Garbage collection can happen automatically once this many bytes have been | |
| 6324 allocated since the last garbage collection. All data types count. | |
| 6325 | |
| 6326 Garbage collection happens automatically when `eval' or `funcall' are | |
| 6327 called. (Note that `funcall' is called implicitly as part of evaluation.) | |
| 6328 By binding this temporarily to a large number, you can effectively | |
| 6329 prevent garbage collection during a part of the program. | |
| 6330 | |
| 853 | 6331 Normally, you cannot set this value less than 10,000 (if you do, it is |
| 6332 automatically reset during the next garbage collection). However, if | |
| 6333 XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing | |
| 6334 you to set this value very low to track down problems with insufficient | |
| 6335 GCPRO'ing. If you set this to a negative number, garbage collection will | |
| 6336 happen at *EVERY* call to `eval' or `funcall'. This is an extremely | |
| 6337 effective way to check GCPRO problems, but be warned that your XEmacs | |
| 6338 will be unusable! You almost certainly won't have the patience to wait | |
| 6339 long enough to be able to set it back. | |
| 6340 | |
| 428 | 6341 See also `consing-since-gc'. |
| 6342 */ ); | |
| 6343 | |
| 801 | 6344 DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /* |
| 6345 *Percentage of memory allocated between garbage collections. | |
| 6346 | |
| 6347 Garbage collection will happen if this percentage of the total amount of | |
| 6348 memory used for data has been allocated since the last garbage collection. | |
| 6349 However, it will not happen if less than `gc-cons-threshold' bytes have | |
| 6350 been allocated -- this sets an absolute minimum in case very little data | |
| 6351 has been allocated or the percentage is set very low. Set this to 0 to | |
| 6352 have garbage collection always happen after `gc-cons-threshold' bytes have | |
| 6353 been allocated, regardless of current memory usage. | |
| 6354 | |
| 6355 Garbage collection happens automatically when `eval' or `funcall' are | |
| 6356 called. (Note that `funcall' is called implicitly as part of evaluation.) | |
| 6357 By binding this temporarily to a large number, you can effectively | |
| 6358 prevent garbage collection during a part of the program. | |
| 6359 | |
| 6360 See also `consing-since-gc'. | |
| 6361 */ ); | |
| 6362 | |
| 428 | 6363 #ifdef DEBUG_XEMACS |
| 6364 DEFVAR_INT ("debug-allocation", &debug_allocation /* | |
| 6365 If non-zero, print out information to stderr about all objects allocated. | |
| 6366 See also `debug-allocation-backtrace-length'. | |
| 6367 */ ); | |
| 6368 debug_allocation = 0; | |
| 6369 | |
| 6370 DEFVAR_INT ("debug-allocation-backtrace-length", | |
| 6371 &debug_allocation_backtrace_length /* | |
| 6372 Length (in stack frames) of short backtrace printed out by `debug-allocation'. | |
| 6373 */ ); | |
| 6374 debug_allocation_backtrace_length = 2; | |
| 6375 #endif | |
| 6376 | |
| 6377 DEFVAR_BOOL ("purify-flag", &purify_flag /* | |
| 6378 Non-nil means loading Lisp code in order to dump an executable. | |
| 6379 This means that certain objects should be allocated in readonly space. | |
| 6380 */ ); | |
| 6381 | |
| 1154 | 6382 DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /* |
| 6383 Non-nil means display messages at start and end of garbage collection. | |
| 6384 */ ); | |
| 6385 garbage_collection_messages = 0; | |
| 6386 | |
| 428 | 6387 DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /* |
| 6388 Function or functions to be run just before each garbage collection. | |
| 6389 Interrupts, garbage collection, and errors are inhibited while this hook | |
| 6390 runs, so be extremely careful in what you add here. In particular, avoid | |
| 6391 consing, and do not interact with the user. | |
| 6392 */ ); | |
| 6393 Vpre_gc_hook = Qnil; | |
| 6394 | |
| 6395 DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /* | |
| 6396 Function or functions to be run just after each garbage collection. | |
| 6397 Interrupts, garbage collection, and errors are inhibited while this hook | |
| 887 | 6398 runs. Each hook is called with one argument which is an alist with |
| 6399 finalization data. | |
| 428 | 6400 */ ); |
| 6401 Vpost_gc_hook = Qnil; | |
| 6402 | |
| 6403 DEFVAR_LISP ("gc-message", &Vgc_message /* | |
| 6404 String to print to indicate that a garbage collection is in progress. | |
| 6405 This is printed in the echo area. If the selected frame is on a | |
| 6406 window system and `gc-pointer-glyph' specifies a value (i.e. a pointer | |
| 6407 image instance) in the domain of the selected frame, the mouse pointer | |
| 6408 will change instead of this message being printed. | |
| 6409 */ ); | |
| 6410 Vgc_message = build_string (gc_default_message); | |
| 6411 | |
| 6412 DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /* | |
| 6413 Pointer glyph used to indicate that a garbage collection is in progress. | |
| 6414 If the selected window is on a window system and this glyph specifies a | |
| 6415 value (i.e. a pointer image instance) in the domain of the selected | |
| 6416 window, the pointer will be changed as specified during garbage collection. | |
| 6417 Otherwise, a message will be printed in the echo area, as controlled | |
| 6418 by `gc-message'. | |
| 6419 */ ); | |
| 6420 } | |
| 6421 | |
| 6422 void | |
| 6423 complex_vars_of_alloc (void) | |
| 6424 { | |
| 6425 Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); | |
| 6426 } |