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