Mercurial > hg > xemacs-beta
changeset 5142:f965e31a35f0
reduce lcrecord headers to 2 words, rename printing_unreadable_object
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Working with Lisp Objects):
* internals/internals.texi (Writing Macros):
* internals/internals.texi (lrecords):
More rewriting to correspond with changes from
*LRECORD* to *LISP_OBJECT*.
modules/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (print_pgconn):
* postgresql/postgresql.c (print_pgresult):
printing_unreadable_object -> printing_unreadable_object_fmt.
2010-03-13 Ben Wing <ben@xemacs.org>
* ldap/eldap.c (print_ldap):
printing_unreadable_object -> printing_unreadable_object_fmt.
src/ChangeLog addition:
2010-03-13 Ben Wing <ben@xemacs.org>
* alloc.c (alloc_sized_lrecord_1):
* alloc.c (alloc_sized_lrecord_array):
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (disksave_object_finalization_1):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (tick_lcrecord_stats):
* alloc.c (sweep_lcrecords_1):
* buffer.c (print_buffer):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* casetab.c:
* casetab.c (print_case_table):
* console.c (print_console):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* data.c (print_weak_list):
* data.c (print_weak_box):
* data.c (print_ephemeron):
* data.c (ephemeron_equal):
* database.c (print_database):
* database.c (finalize_database):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (print_devmode):
* device-msw.c (finalize_devmode):
* device.c:
* device.c (print_device):
* elhash.c:
* elhash.c (print_hash_table):
* eval.c (print_subr):
* eval.c (print_multiple_value):
* event-stream.c (event_stream_resignal_wakeup):
* events.c (clear_event_resource):
* events.c (zero_event):
* events.c (print_event):
* extents.c:
* extents.c (print_extent):
* file-coding.c (print_coding_system):
* font-mgr.c:
* font-mgr.c (Ffc_init):
* frame.c:
* frame.c (print_frame):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c (print_gui_item):
* gui.c (copy_gui_item):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lisp.h (struct Lisp_String):
* lisp.h (DEFUN):
* lisp.h (DEFUN_NORETURN):
* lrecord.h:
* lrecord.h (NORMAL_LISP_OBJECT_UID):
* lrecord.h (struct lrecord_header):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lrecord.h (struct free_lcrecord_header):
* marker.c (print_marker):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* print.c (print_cons):
* print.c (printing_unreadable_object_fmt):
* print.c (printing_unreadable_lisp_object):
* print.c (external_object_printer):
* print.c (internal_object_printer):
* print.c (debug_p4):
* print.c (ext_print_begin):
* process.c (print_process):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* scrollbar.c (free_scrollbar_instance):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c (guts_of_unbound_marker):
* symeval.h:
* symeval.h (DEFVAR_SYMVAL_FWD):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* ui-gtk.c (ffi_object_printer):
* ui-gtk.c (emacs_gtk_object_printer):
* ui-gtk.c (emacs_gtk_boxed_printer):
* window.c (print_window):
* window.c (free_window_mirror):
* window.c (debug_print_window):
* xemacs.def.in.in:
(1) printing_unreadable_object -> printing_unreadable_object_fmt.
(2) printing_unreadable_lcrecord -> printing_unreadable_lisp_object
and fix up so it no longer requires an lcrecord.
These previous changes eliminate most of the remaining places where
the terms `lcrecord' and `lrecord' occurred outside of specialized
code.
(3) Fairly major change: Reduce the number of words in an lcrecord
from 3 to 2. The third word consisted of a uid that duplicated the
lrecord uid, and a single free bit, which was moved into the lrecord
structure. This reduces the size of the `uid' slot from 21 bits to
20 bits. Arguably this isn't enough -- we could easily have more than
1,000,000 or so objects created in a session. The answer is
(a) It doesn't really matter if we overflow the uid field because
it's only used for debugging, to identify an object uniquely
(or pretty much so).
(b) If we cared about it overflowing and wanted to reduce this,
we could make it so that cons, string, float and certain other
frob-block types that never print out the uid simply don't
store a uid in them and don't increment the lrecord_uid_counter.
(4) In conjunction with (3), create new macro NORMAL_LISP_OBJECT_UID()
and use it to abstract out the differences between NEWGC and old-GC
in accessing the `uid' value from a "normal Lisp Object pointer".
(5) In events.c, use zero_nonsized_lisp_object() in place of custom-
written equivalent. In font-mgr.c use external_object_printer()
in place of custom-written equivalents.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Sat, 13 Mar 2010 05:38:08 -0600 |
| parents | 0dcd22290039 |
| children | 186aebf7f6c6 |
| files | man/ChangeLog man/internals/internals.texi modules/ChangeLog modules/ldap/eldap.c modules/postgresql/postgresql.c src/ChangeLog src/alloc.c src/buffer.c src/casetab.c src/console.c src/data.c src/database.c src/device-msw.c src/device.c src/elhash.c src/eval.c src/event-stream.c src/events.c src/extents.c src/file-coding.c src/font-mgr.c src/frame.c src/gc.c src/glyphs.c src/gui.c src/keymap.c src/lisp.h src/lrecord.h src/marker.c src/mule-charset.c src/objects.c src/print.c src/process.c src/rangetab.c src/scrollbar.c src/specifier.c src/symbols.c src/symeval.h src/tooltalk.c src/ui-gtk.c src/window.c src/xemacs.def.in.in |
| diffstat | 42 files changed, 281 insertions(+), 205 deletions(-) [+] |
line wrap: on
line diff
--- a/man/ChangeLog Sun Mar 07 19:26:04 2010 -0600 +++ b/man/ChangeLog Sat Mar 13 05:38:08 2010 -0600 @@ -1,3 +1,11 @@ +2010-03-13 Ben Wing <ben@xemacs.org> + + * internals/internals.texi (Working with Lisp Objects): + * internals/internals.texi (Writing Macros): + * internals/internals.texi (lrecords): + More rewriting to correspond with changes from + *LRECORD* to *LISP_OBJECT*. + 2010-03-05 Ben Wing <ben@xemacs.org> * internals/internals.texi (Introduction to Allocation):
--- a/man/internals/internals.texi Sun Mar 07 19:26:04 2010 -0600 +++ b/man/internals/internals.texi Sat Mar 13 05:38:08 2010 -0600 @@ -5275,8 +5275,8 @@ returned (created using @samp{wrap_<type>}, if necessary). @c #### declaration -@item DECLARE_LRECORD (<type>, Lisp_<Type>) -Declares an @samp{lrecord} for @samp{<Type>}, which is the unit of +@item DECLARE_LISP_OBJECT (<type>, Lisp_<Type>) +Declares a Lisp object for @samp{<Type>}, which is the unit of allocation. @item #define X<TYPE>(x) XRECORD (x, <type>, Lisp_<Type>) @@ -5342,24 +5342,24 @@ @enumerate @item -create @var{foo}.h -@item -create @var{foo}.c -@item -add definitions of @code{syms_of_@var{foo}}, etc. to @file{@var{foo}.c} -@item -add declarations of @code{syms_of_@var{foo}}, etc. to @file{symsinit.h} -@item -add calls to @code{syms_of_@var{foo}}, etc. to @file{emacs.c} -@item -add definitions of macros like @code{CHECK_@var{FOO}} and +Create @var{foo}.h +@item +Create @var{foo}.c +@item +Add definitions of @code{syms_of_@var{foo}}, etc. to @file{@var{foo}.c} +@item +Add declarations of @code{syms_of_@var{foo}}, etc. to @file{symsinit.h} +@item +Add calls to @code{syms_of_@var{foo}}, etc. to @file{emacs.c} +@item +Add definitions of macros like @code{CHECK_@var{FOO}} and @code{@var{FOO}P} to @file{@var{foo}.h} @item -add the new type index to @code{enum lrecord_type} -@item -add a DEFINE_LRECORD_IMPLEMENTATION call to @file{@var{foo}.c} -@item -add an INIT_LRECORD_IMPLEMENTATION call to @code{syms_of_@var{foo}.c} +Add the new type index to @code{enum lrecord_type} +@item +Add a @code{DEFINE_*_LISP_OBJECT()} to @file{@var{foo}.c} +@item +Add an @code{INIT_LISP_OBJECT} call to @code{syms_of_@var{foo}.c} @end enumerate @@ -5842,11 +5842,12 @@ @cindex inline functions, headers @cindex header files, inline functions Every header which contains inline functions, either directly by using -@code{DECLARE_INLINE_HEADER} or indirectly by using @code{DECLARE_LRECORD} must -be added to @file{inline.c}'s includes to make the optimization -described above work. (Optimization note: if all INLINE_HEADER -functions are in fact inlined in all translation units, then the linker -can just discard @code{inline.o}, since it contains only unreferenced code). +@code{DECLARE_INLINE_HEADER} or indirectly by using +@code{DECLARE_LISP_OBJECT} must be added to @file{inline.c}'s includes +to make the optimization described above work. (Optimization note: if +all INLINE_HEADER functions are in fact inlined in all translation +units, then the linker can just discard @code{inline.o}, since it +contains only unreferenced code). The three golden rules of macros: @@ -8551,10 +8552,7 @@ beginning. lcrecords, however, actually have a @code{struct old_lcrecord_header}. This, in turn, has a @code{struct lrecord_header} at its beginning, so sanity is preserved; but it also -has a pointer used to chain all lcrecords together, and a special ID -field used to distinguish one lcrecord from another. (This field is used -only for debugging and could be removed, but the space gain is not -significant.) +has a pointer used to chain all lcrecords together. @strong{lcrecords are now obsolete when using the write-barrier-based collector.}
--- a/modules/ChangeLog Sun Mar 07 19:26:04 2010 -0600 +++ b/modules/ChangeLog Sat Mar 13 05:38:08 2010 -0600 @@ -1,3 +1,14 @@ +2010-03-13 Ben Wing <ben@xemacs.org> + + * postgresql/postgresql.c (print_pgconn): + * postgresql/postgresql.c (print_pgresult): + printing_unreadable_object -> printing_unreadable_object_fmt. + +2010-03-13 Ben Wing <ben@xemacs.org> + + * ldap/eldap.c (print_ldap): + printing_unreadable_object -> printing_unreadable_object_fmt. + 2010-03-07 Ben Wing <ben@xemacs.org> * postgresql/postgresql.c (finalize_pgconn):
--- a/modules/ldap/eldap.c Sun Mar 07 19:26:04 2010 -0600 +++ b/modules/ldap/eldap.c Sat Mar 13 05:38:08 2010 -0600 @@ -130,7 +130,7 @@ Lisp_LDAP *ldap = XLDAP (obj); if (print_readably) - printing_unreadable_object ("#<ldap %s>", XSTRING_DATA (ldap->host)); + printing_unreadable_object_fmt ("#<ldap %s>", XSTRING_DATA (ldap->host)); write_fmt_string_lisp (printcharfun, "#<ldap %S", 1, ldap->host); if (!ldap->ld)
--- a/modules/postgresql/postgresql.c Sun Mar 07 19:26:04 2010 -0600 +++ b/modules/postgresql/postgresql.c Sat Mar 13 05:38:08 2010 -0600 @@ -253,7 +253,7 @@ strcpy (buf, "#<PGconn connecting>"); /* evil! */ if (print_readably) - printing_unreadable_object ("%s", buf); + printing_unreadable_object_fmt ("%s", buf); else write_cistring (printcharfun, buf); } @@ -401,7 +401,7 @@ strcpy (buf, "#<PGresult DEAD>"); /* evil! */ if (print_readably) - printing_unreadable_object ("%s", buf); + printing_unreadable_object_fmt ("%s", buf); else write_cistring (printcharfun, buf); }
--- a/src/ChangeLog Sun Mar 07 19:26:04 2010 -0600 +++ b/src/ChangeLog Sat Mar 13 05:38:08 2010 -0600 @@ -1,3 +1,126 @@ +2010-03-13 Ben Wing <ben@xemacs.org> + + * alloc.c (alloc_sized_lrecord_1): + * alloc.c (alloc_sized_lrecord_array): + * alloc.c (old_alloc_sized_lcrecord): + * alloc.c (disksave_object_finalization_1): + * alloc.c (mark_lcrecord_list): + * alloc.c (alloc_managed_lcrecord): + * alloc.c (free_managed_lcrecord): + * alloc.c (tick_lcrecord_stats): + * alloc.c (sweep_lcrecords_1): + * buffer.c (print_buffer): + * buffer.c (DEFVAR_BUFFER_LOCAL_1): + * casetab.c: + * casetab.c (print_case_table): + * console.c (print_console): + * console.c (DEFVAR_CONSOLE_LOCAL_1): + * data.c (print_weak_list): + * data.c (print_weak_box): + * data.c (print_ephemeron): + * data.c (ephemeron_equal): + * database.c (print_database): + * database.c (finalize_database): + * device-msw.c (sync_printer_with_devmode): + * device-msw.c (print_devmode): + * device-msw.c (finalize_devmode): + * device.c: + * device.c (print_device): + * elhash.c: + * elhash.c (print_hash_table): + * eval.c (print_subr): + * eval.c (print_multiple_value): + * event-stream.c (event_stream_resignal_wakeup): + * events.c (clear_event_resource): + * events.c (zero_event): + * events.c (print_event): + * extents.c: + * extents.c (print_extent): + * file-coding.c (print_coding_system): + * font-mgr.c: + * font-mgr.c (Ffc_init): + * frame.c: + * frame.c (print_frame): + * gc.c: + * gc.c (GC_CHECK_NOT_FREE): + * glyphs.c: + * glyphs.c (print_image_instance): + * glyphs.c (print_glyph): + * gui.c (print_gui_item): + * gui.c (copy_gui_item): + * keymap.c (print_keymap): + * keymap.c (MARKED_SLOT): + * lisp.h: + * lisp.h (struct Lisp_String): + * lisp.h (DEFUN): + * lisp.h (DEFUN_NORETURN): + * lrecord.h: + * lrecord.h (NORMAL_LISP_OBJECT_UID): + * lrecord.h (struct lrecord_header): + * lrecord.h (set_lheader_implementation): + * lrecord.h (struct old_lcrecord_header): + * lrecord.h (struct free_lcrecord_header): + * marker.c (print_marker): + * mule-charset.c: + * mule-charset.c (print_charset): + * objects.c (print_color_instance): + * objects.c (print_font_instance): + * objects.c (finalize_font_instance): + * print.c (print_cons): + * print.c (printing_unreadable_object_fmt): + * print.c (printing_unreadable_lisp_object): + * print.c (external_object_printer): + * print.c (internal_object_printer): + * print.c (debug_p4): + * print.c (ext_print_begin): + * process.c (print_process): + * rangetab.c (print_range_table): + * rangetab.c (range_table_equal): + * scrollbar.c (free_scrollbar_instance): + * specifier.c (print_specifier): + * specifier.c (finalize_specifier): + * symbols.c (guts_of_unbound_marker): + * symeval.h: + * symeval.h (DEFVAR_SYMVAL_FWD): + * tooltalk.c: + * tooltalk.c (print_tooltalk_message): + * tooltalk.c (print_tooltalk_pattern): + * ui-gtk.c (ffi_object_printer): + * ui-gtk.c (emacs_gtk_object_printer): + * ui-gtk.c (emacs_gtk_boxed_printer): + * window.c (print_window): + * window.c (free_window_mirror): + * window.c (debug_print_window): + * xemacs.def.in.in: + (1) printing_unreadable_object -> printing_unreadable_object_fmt. + (2) printing_unreadable_lcrecord -> printing_unreadable_lisp_object + and fix up so it no longer requires an lcrecord. + + These previous changes eliminate most of the remaining places where + the terms `lcrecord' and `lrecord' occurred outside of specialized + code. + + (3) Fairly major change: Reduce the number of words in an lcrecord + from 3 to 2. The third word consisted of a uid that duplicated the + lrecord uid, and a single free bit, which was moved into the lrecord + structure. This reduces the size of the `uid' slot from 21 bits to + 20 bits. Arguably this isn't enough -- we could easily have more than + 1,000,000 or so objects created in a session. The answer is + (a) It doesn't really matter if we overflow the uid field because + it's only used for debugging, to identify an object uniquely + (or pretty much so). + (b) If we cared about it overflowing and wanted to reduce this, + we could make it so that cons, string, float and certain other + frob-block types that never print out the uid simply don't + store a uid in them and don't increment the lrecord_uid_counter. + + (4) In conjunction with (3), create new macro NORMAL_LISP_OBJECT_UID() + and use it to abstract out the differences between NEWGC and old-GC + in accessing the `uid' value from a "normal Lisp Object pointer". + + (5) In events.c, use zero_nonsized_lisp_object() in place of custom- + written equivalent. In font-mgr.c use external_object_printer() + in place of custom-written equivalents. 2010-03-07 Ben Wing <ben@xemacs.org> * number.c (bignum_finalize):
--- a/src/alloc.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/alloc.c Sat Mar 13 05:38:08 2010 -0600 @@ -590,7 +590,6 @@ lheader = (struct lrecord_header *) mc_alloc (size); gc_checking_assert (LRECORD_FREE_P (lheader)); set_lheader_implementation (lheader, implementation); - lheader->uid = lrecord_uid_counter++; #ifdef ALLOC_TYPE_STATS inc_lrecord_stats (size, lheader); #endif /* ALLOC_TYPE_STATS */ @@ -651,7 +650,6 @@ { struct lrecord_header *lh = (struct lrecord_header *) start; set_lheader_implementation (lh, implementation); - lh->uid = lrecord_uid_counter++; #ifdef ALLOC_TYPE_STATS inc_lrecord_stats (size, lh); #endif /* not ALLOC_TYPE_STATS */ @@ -693,12 +691,6 @@ lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size); set_lheader_implementation (&lcheader->lheader, implementation); lcheader->next = all_lcrecords; -#if 1 /* mly prefers to see small ID numbers */ - lcheader->uid = lrecord_uid_counter++; -#else /* jwz prefers to see real addrs */ - lcheader->uid = (int) &lcheader; -#endif - lcheader->free = 0; all_lcrecords = lcheader; INCREMENT_CONS_COUNTER (size, implementation->name); return wrap_pointer_1 (lcheader); @@ -765,13 +757,13 @@ struct lrecord_header *objh = &header->lheader; const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (objh); #if 0 /* possibly useful for debugging */ - if (!RECORD_DUMPABLE (objh) && !header->free) + if (!RECORD_DUMPABLE (objh) && !objh->free) { stderr_out ("Disksaving a non-dumpable object: "); debug_print (wrap_pointer_1 (header)); } #endif - if (imp->disksaver && !header->free) + if (imp->disksaver && !objh->free) (imp->disksaver) (wrap_pointer_1 (header)); } #endif /* not NEW_GC */ @@ -3175,7 +3167,7 @@ ! list->implementation->frob_block_p && /* Only free lcrecords should be here. */ - free_header->lcheader.free + lheader->free && /* The type of the lcrecord must be right. */ lheader->type == lrecord_type_free @@ -3228,7 +3220,7 @@ /* There should be no other pointers to the free list. */ assert (! MARKED_RECORD_HEADER_P (lheader)); /* Only free lcrecords should be here. */ - assert (free_header->lcheader.free); + assert (lheader->free); assert (lheader->type == lrecord_type_free); /* Only lcrecords should be here. */ assert (! (list->implementation->frob_block_p)); @@ -3243,7 +3235,7 @@ #endif /* ERROR_CHECK_GC */ list->free = free_header->chain; - free_header->lcheader.free = 0; + lheader->free = 0; /* Put back the correct type, as we set it to lrecord_type_free. */ lheader->type = list->implementation->lrecord_type_index; zero_sized_lisp_object (val, list->size); @@ -3297,7 +3289,7 @@ putting a window configuration on the wrong free list. */ gc_checking_assert (lisp_object_size (lcrecord) == list->size); /* Make sure the object isn't already freed. */ - gc_checking_assert (!free_header->lcheader.free); + gc_checking_assert (!lheader->free); /* Freeing stuff in dumped memory is bad. If you trip this, you may need to check for this before freeing. */ gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); @@ -3311,7 +3303,7 @@ around an lrecord of apparently correct type but bogus junk in it. */ MARK_LRECORD_AS_FREE (lheader); free_header->chain = list->free; - free_header->lcheader.free = 1; + lheader->free = 1; list->free = lcrecord; } @@ -3630,7 +3622,7 @@ inline static void tick_lcrecord_stats (const struct lrecord_header *h, int free_p) { - if (((struct old_lcrecord_header *) h)->free) + if (h->free) { gc_checking_assert (!free_p); tick_lrecord_stats (h, ALLOC_ON_FREE_LIST); @@ -3666,7 +3658,7 @@ GC_CHECK_LHEADER_INVARIANTS (h); - if (! MARKED_RECORD_HEADER_P (h) && ! header->free) + if (! MARKED_RECORD_HEADER_P (h) && !h->free) { if (LHEADER_IMPLEMENTATION (h)->finalizer) LHEADER_IMPLEMENTATION (h)->finalizer (wrap_pointer_1 (h));
--- a/src/buffer.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/buffer.c Sat Mar 13 05:38:08 2010 -0600 @@ -302,9 +302,9 @@ if (print_readably) { if (!BUFFER_LIVE_P (b)) - printing_unreadable_object ("#<killed buffer>"); + printing_unreadable_object_fmt ("#<killed buffer>"); else - printing_unreadable_object ("#<buffer %s>", XSTRING_DATA (b->name)); + printing_unreadable_object_fmt ("#<buffer %s>", XSTRING_DATA (b->name)); } else if (!BUFFER_LIVE_P (b)) write_ascstring (printcharfun, "#<killed buffer>"); @@ -2175,8 +2175,6 @@ 1 /* lisp_readonly bit */ \ }, \ 0, /* next */ \ - 0, /* uid */ \ - 0 /* free */ \ }, \ &(buffer_local_flags.field_name), \ forward_type \
--- a/src/casetab.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/casetab.c Sat Mar 13 05:38:08 2010 -0600 @@ -105,12 +105,12 @@ { Lisp_Case_Table *ct = XCASE_TABLE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<case-table downcase=%s upcase=%s canon=%s eqv=%s ", 4, CASE_TABLE_DOWNCASE (ct), CASE_TABLE_UPCASE (ct), CASE_TABLE_CANON (ct), CASE_TABLE_EQV (ct)); - write_fmt_string (printcharfun, "0x%x>", ct->header.uid); + write_fmt_string (printcharfun, "0x%x>", NORMAL_LISP_OBJECT_UID (ct)); } static const struct memory_description case_table_description [] = {
--- a/src/console.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/console.c Sat Mar 13 05:38:08 2010 -0600 @@ -163,14 +163,14 @@ struct console *con = XCONSOLE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (con->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (con->name)); write_fmt_string (printcharfun, "#<%s-console", !CONSOLE_LIVE_P (con) ? "dead" : CONSOLE_TYPE_NAME (con)); if (CONSOLE_LIVE_P (con) && !NILP (CONSOLE_CONNECTION (con))) write_fmt_string_lisp (printcharfun, " on %S", 1, CONSOLE_CONNECTION (con)); - write_fmt_string (printcharfun, " 0x%x>", con->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (con)); } DEFINE_NODUMP_LISP_OBJECT ("console", console, mark_console, @@ -1351,8 +1351,6 @@ 1 /* lisp_readonly bit */ \ }, \ 0, /* next */ \ - 0, /* uid */ \ - 0 /* free */ \ }, \ &(console_local_flags.field_name), \ forward_type \
--- a/src/data.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/data.c Sat Mar 13 05:38:08 2010 -0600 @@ -2614,7 +2614,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2, encode_weak_list_type (XWEAK_LIST (obj)->type), @@ -3090,7 +3090,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<weak-box>"); /* #### fix */ } @@ -3312,7 +3312,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<ephemeron>"); /* #### fix */ }
--- a/src/database.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/database.c Sat Mar 13 05:38:08 2010 -0600 @@ -217,7 +217,7 @@ Lisp_Database *db = XDATABASE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/", 3, db->fname, db->funcs->get_type (db), @@ -232,7 +232,7 @@ XSYMBOL_NAME (XCODING_SYSTEM_NAME (db->coding_system))); - write_fmt_string (printcharfun, "0x%x>", db->header.uid); + write_fmt_string (printcharfun, "0x%x>", NORMAL_LISP_OBJECT_UID (db)); } static void
--- a/src/device-msw.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/device-msw.c Sat Mar 13 05:38:08 2010 -0600 @@ -665,7 +665,7 @@ suffix. */ Ibyte new_connext[20]; - qxesprintf (new_connext, ":%X", d->header.uid); + qxesprintf (new_connext, ":%X", NORMAL_LISP_OBJECT_UID (d)); new_connection = concat2 (devname, build_istring (new_connext)); } DEVICE_CONNECTION (d) = new_connection; @@ -1148,13 +1148,13 @@ { Lisp_Devmode *dm = XDEVMODE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<msprinter-settings"); if (!NILP (dm->printer_name)) write_fmt_string_lisp (printcharfun, " for %S", 1, dm->printer_name); if (!NILP (dm->device)) write_fmt_string_lisp (printcharfun, " (currently on %s)", 1, dm->device); - write_fmt_string (printcharfun, " 0x%x>", dm->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (dm)); } static void
--- a/src/device.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/device.c Sat Mar 13 05:38:08 2010 -0600 @@ -160,13 +160,13 @@ struct device *d = XDEVICE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (d->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (d->name)); write_fmt_string (printcharfun, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" : DEVICE_TYPE_NAME (d)); if (DEVICE_LIVE_P (d) && !NILP (DEVICE_CONNECTION (d))) write_fmt_string_lisp (printcharfun, " on %S", 1, DEVICE_CONNECTION (d)); - write_fmt_string (printcharfun, " 0x%x>", d->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (d)); } DEFINE_NODUMP_LISP_OBJECT ("device", device,
--- a/src/elhash.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/elhash.c Sat Mar 13 05:38:08 2010 -0600 @@ -395,7 +395,7 @@ if (print_readably) write_ascstring (printcharfun, ")"); else - write_fmt_string (printcharfun, " 0x%x>", ht->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (ht)); } #ifndef NEW_GC
--- a/src/eval.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/eval.c Sat Mar 13 05:38:08 2010 -0600 @@ -455,7 +455,7 @@ const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; if (print_readably) - printing_unreadable_object ("%s%s%s", header, name, trailer); + printing_unreadable_object_fmt ("%s%s%s", header, name, trailer); write_ascstring (printcharfun, header); write_ascstring (printcharfun, name); @@ -4605,7 +4605,7 @@ if (print_readably) { - printing_unreadable_object ("multiple values"); + printing_unreadable_object_fmt ("multiple values"); } write_fmt_string (printcharfun,
--- a/src/event-stream.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/event-stream.c Sat Mar 13 05:38:08 2010 -0600 @@ -1119,7 +1119,7 @@ op = XCAR (rest); timeout = XTIMEOUT (op); /* We make sure to snarf the data out of the timeout object before - we free it with free_managed_lcrecord(). */ + we free it with free_normal_lisp_object(). */ id = timeout->id; *function = timeout->function; *object = timeout->object;
--- a/src/events.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/events.c Sat Mar 13 05:38:08 2010 -0600 @@ -62,7 +62,7 @@ /* definition of event object */ /************************************************************************/ -/* #### Ad-hoc hack. Should be part of define_lrecord_implementation */ +/* #### Ad-hoc hack. Should be part of DEFINE_*_GENERAL_LISP_OBJECT. */ void clear_event_resource (void) { @@ -91,12 +91,7 @@ void zero_event (Lisp_Event *e) { - /* Preserve the old UID for this event, for tracking it */ - unsigned int old_uid = e->lheader.uid; - - xzero (*e); - set_lheader_implementation (&e->lheader, &lrecord_event); - e->lheader.uid = old_uid; + zero_nonsized_lisp_object (wrap_event (e)); set_event_type (e, empty_event); SET_EVENT_CHANNEL (e, Qnil); SET_EVENT_NEXT (e, Qnil); @@ -313,7 +308,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_object ("#<event>"); + printing_unreadable_object_fmt ("#<event>"); switch (XEVENT (obj)->event_type) {
--- a/src/extents.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/extents.c Sat Mar 13 05:38:08 2010 -0600 @@ -3231,7 +3231,7 @@ /* These are the basic helper functions for handling the allocation of extent objects. They are similar to the functions for other - lrecord objects. allocate_extent() is in alloc.c, not here. */ + frob-block objects. allocate_extent() is in alloc.c, not here. */ static Lisp_Object mark_extent (Lisp_Object obj) @@ -3333,9 +3333,9 @@ if (print_readably) { if (!EXTENT_LIVE_P (XEXTENT (obj))) - printing_unreadable_object ("#<destroyed extent>"); + printing_unreadable_object_fmt ("#<destroyed extent>"); else - printing_unreadable_object ("#<extent 0x%lx>", + printing_unreadable_object_fmt ("#<extent 0x%lx>", (long) XEXTENT (obj)); } @@ -3353,7 +3353,7 @@ else { if (print_readably) - printing_unreadable_object ("#<extent>"); + printing_unreadable_object_fmt ("#<extent>"); write_ascstring (printcharfun, "#<extent"); } write_ascstring (printcharfun, ">");
--- a/src/file-coding.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/file-coding.c Sat Mar 13 05:38:08 2010 -0600 @@ -297,7 +297,7 @@ { Lisp_Coding_System *c = XCODING_SYSTEM (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<coding-system %s ", 1, c->name); print_coding_system_properties (obj, printcharfun);
--- a/src/font-mgr.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/font-mgr.c Sat Mar 13 05:38:08 2010 -0600 @@ -104,16 +104,6 @@ } } -static void -print_fc_pattern (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED(escapeflag)) -{ - struct fc_pattern *c = XFC_PATTERN (obj); - if (print_readably) - printing_unreadable_object ("#<fc-pattern 0x%x>", c->header.uid); - write_fmt_string (printcharfun, "#<fc-pattern 0x%x>", c->header.uid); -} - /* #### We really need an equal method and a hash method (required if you have an equal method). For the equal method, we can probably use one or both of @@ -144,7 +134,7 @@ }; DEFINE_NODUMP_LISP_OBJECT ("fc-pattern", fc_pattern, - 0, print_fc_pattern, finalize_fc_pattern, + 0, external_object_printer, finalize_fc_pattern, 0, 0, fcpattern_description, struct fc_pattern); @@ -1106,24 +1096,14 @@ p->fccfgPtr = 0; } -static void -print_fc_config (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED(escapeflag)) -{ - struct fc_config *c = XFC_CONFIG (obj); - if (print_readably) - printing_unreadable_object ("#<fc-config 0x%x>", c->header.uid); - write_fmt_string (printcharfun, "#<fc-config 0x%x>", c->header.uid); -} - static const struct memory_description fcconfig_description [] = { /* #### nothing here, is this right?? */ { XD_END } }; DEFINE_NODUMP_LISP_OBJECT ("fc-config", fc_config, - 0, print_fc_config, finalize_fc_config, 0, 0, - fcconfig_description, + 0, external_object_printer, finalize_fc_config, + 0, 0, fcconfig_description, struct fc_config); DEFUN("fc-init", Ffc_init, 0, 0, 0, /*
--- a/src/frame.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/frame.c Sat Mar 13 05:38:08 2010 -0600 @@ -637,12 +637,12 @@ struct frame *frm = XFRAME (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (frm->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (frm->name)); write_fmt_string (printcharfun, "#<%s-frame ", !FRAME_LIVE_P (frm) ? "dead" : FRAME_TYPE_NAME (frm)); print_internal (frm->name, printcharfun, 1); - write_fmt_string (printcharfun, " 0x%x>", frm->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (frm)); } DEFINE_NODUMP_LISP_OBJECT ("frame", frame,
--- a/src/gc.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/gc.c Sat Mar 13 05:38:08 2010 -0600 @@ -589,8 +589,8 @@ #else /* not NEW_GC */ #define GC_CHECK_NOT_FREE(lheader) \ gc_checking_assert (! LRECORD_FREE_P (lheader)); \ - gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->frob_block_p || \ - ! ((struct old_lcrecord_header *) lheader)->free) + gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->frob_block_p || \ + ! (lheader)->free) #endif /* not NEW_GC */ #ifdef USE_KKCC
--- a/src/glyphs.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/glyphs.c Sat Mar 13 05:38:08 2010 -0600 @@ -992,7 +992,7 @@ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<image-instance (%s) ", 1, Fimage_instance_type (obj)); if (!NILP (ii->name)) @@ -1108,7 +1108,7 @@ MAYBE_DEVMETH (DOMAIN_XDEVICE (ii->domain), print_image_instance, (ii, printcharfun, escapeflag)); - write_fmt_string (printcharfun, " 0x%x>", ii->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (ii)); } static void @@ -3707,11 +3707,11 @@ Lisp_Glyph *glyph = XGLYPH (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<glyph (%s", 1, Fglyph_type (obj)); write_fmt_string_lisp (printcharfun, ") %S", 1, glyph->image); - write_fmt_string (printcharfun, "0x%x>", glyph->header.uid); + write_fmt_string (printcharfun, "0x%x>", NORMAL_LISP_OBJECT_UID (glyph)); } /* Glyphs are equal if all of their display attributes are equal. We
--- a/src/gui.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/gui.c Sat Mar 13 05:38:08 2010 -0600 @@ -693,9 +693,9 @@ Lisp_Gui_Item *g = XGUI_ITEM (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); - write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid); + write_fmt_string (printcharfun, "#<gui-item 0x%x>", NORMAL_LISP_OBJECT_UID (g)); } Lisp_Object
--- a/src/keymap.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/keymap.c Sat Mar 13 05:38:08 2010 -0600 @@ -284,14 +284,14 @@ /* This function can GC */ Lisp_Keymap *keymap = XKEYMAP (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<keymap "); if (!NILP (keymap->name)) { write_fmt_string_lisp (printcharfun, "%S ", 1, keymap->name); } write_fmt_string (printcharfun, "size %ld 0x%x>", - (long) XINT (Fkeymap_fullness (obj)), keymap->header.uid); + (long) XINT (Fkeymap_fullness (obj)), NORMAL_LISP_OBJECT_UID (keymap)); } static const struct memory_description keymap_description[] = {
--- a/src/lisp.h Sun Mar 07 19:26:04 2010 -0600 +++ b/src/lisp.h Sat Mar 13 05:38:08 2010 -0600 @@ -3088,7 +3088,9 @@ struct { /* WARNING: Everything before ascii_begin must agree exactly with - struct lrecord_header */ + struct lrecord_header. (Actually, the `free' field in old-GC + overlaps with ascii_begin there; we can get away with this + because in old-GC the `free' field is used only for lcrecords. */ unsigned int type :8; #ifdef NEW_GC unsigned int lisp_readonly :1; @@ -3938,7 +3940,6 @@ 1, /* mark bit */ \ 1, /* c_readonly bit */ \ 1, /* lisp_readonly bit */ \ - 0 /* unused */ \ }, \ min_args, \ max_args, \ @@ -3958,7 +3959,6 @@ 1, /* mark bit */ \ 1, /* c_readonly bit */ \ 1, /* lisp_readonly bit */ \ - 0 /* unused */ \ }, \ min_args, \ max_args, \ @@ -5876,10 +5876,10 @@ int UNUSED (escapeflag)); void external_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)); -MODULE_API DECLARE_DOESNT_RETURN (printing_unreadable_object (const CIbyte *, +MODULE_API DECLARE_DOESNT_RETURN (printing_unreadable_object_fmt (const CIbyte *, ...)) PRINTF_ARGS (1, 2); -DECLARE_DOESNT_RETURN (printing_unreadable_lcrecord (Lisp_Object obj, +DECLARE_DOESNT_RETURN (printing_unreadable_lisp_object (Lisp_Object obj, const Ibyte *name)); /* Defined in rangetab.c */
--- a/src/lrecord.h Sun Mar 07 19:26:04 2010 -0600 +++ b/src/lrecord.h Sat Mar 13 05:38:08 2010 -0600 @@ -57,17 +57,13 @@ Under NEW_GC, NORMAL_LISP_OBJECT_HEADER also resolves to `struct lrecord_header'. Under old-GC, however, NORMAL_LISP_OBJECT_HEADER resolves to a `struct old_lcrecord_header' (note the `c'), which is a - larger structure -- on 32-bit machines it occupies 3 machine words + larger structure -- on 32-bit machines it occupies 2 machine words instead of 1. Such an object is known internally as an "lcrecord". The first word of `struct old_lcrecord_header' is an embedded `struct lrecord_header' with the same information as for frob-block objects; that way, all objects can be cast to a `struct lrecord_header' to - determine their type or other info. The other words consist of a - pointer, used to thread all lcrecords together in one big linked list, - and a 32-bit structure that contains another UID field (#### which - should be deleted, as it is redundant; it dates back to the days when - the lrecord_header consisted of a pointer to an object's implementation - structure rather than an index). + determine their type or other info. The other word is a pointer, used + to thread all lcrecords together in one big linked list. Under old-GC, normal objects (i.e. lcrecords) are allocated in individual chunks using the underlying allocator (i.e. xmalloc(), which @@ -191,6 +187,7 @@ #define NORMAL_LISP_OBJECT_HEADER struct lrecord_header #define FROB_BLOCK_LISP_OBJECT_HEADER struct lrecord_header #define LISP_OBJECT_FROB_BLOCK_P(obj) 0 +#define NORMAL_LISP_OBJECT_UID(obj) ((obj)->header.uid) #else /* not NEW_GC */ #define ALLOC_NORMAL_LISP_OBJECT(type) alloc_automanaged_lcrecord (&lrecord_##type) #define ALLOC_SIZED_LISP_OBJECT(size, type) \ @@ -198,6 +195,7 @@ #define NORMAL_LISP_OBJECT_HEADER struct old_lcrecord_header #define FROB_BLOCK_LISP_OBJECT_HEADER struct lrecord_header #define LISP_OBJECT_FROB_BLOCK_P(obj) (XRECORD_LHEADER_IMPLEMENTATION(obj)->frob_block_p) +#define NORMAL_LISP_OBJECT_UID(obj) ((obj)->header.lheader.uid) #endif /* not NEW_GC */ BEGIN_C_DECLS @@ -238,10 +236,20 @@ /* 1 if the object is readonly from lisp */ unsigned int lisp_readonly :1; + /* The `free' field is currently used only for lcrecords under old-GC. + It is a flag that indicates whether this lcrecord is on a "free list". + Free lists are used to minimize the number of calls to malloc() when + we're repeatedly allocating and freeing a number of the same sort of + lcrecord. Lcrecords on a free list always get marked in a different + fashion, so we can use this flag as a sanity check to make sure that + free lists only have freed lcrecords and there are no freed lcrecords + elsewhere. */ + unsigned int free :1; + /* The `uid' field is just for debugging/printing convenience. Having this slot doesn't hurt us spacewise, since the bits are unused anyway. (The bits are used for strings, though.) */ - unsigned int uid :21; + unsigned int uid :20; #endif /* not NEW_GC */ }; @@ -265,6 +273,7 @@ SLI_header->mark = 0; \ SLI_header->c_readonly = 0; \ SLI_header->lisp_readonly = 0; \ + SLI_header->free = 0; \ SLI_header->uid = lrecord_uid_counter++; \ } while (0) #endif /* not NEW_GC */ @@ -285,20 +294,6 @@ out of memory chunks, and are able to find all unmarked members by sweeping through the elements of the list of chunks. */ struct old_lcrecord_header *next; - - /* The `uid' field is just for debugging/printing convenience. - Having this slot doesn't hurt us much spacewise, since an - lcrecord already has the above slots plus malloc overhead. */ - unsigned int uid :31; - - /* The `free' field is a flag that indicates whether this lcrecord - is on a "free list". Free lists are used to minimize the number - of calls to malloc() when we're repeatedly allocating and freeing - a number of the same sort of lcrecord. Lcrecords on a free list - always get marked in a different fashion, so we can use this flag - as a sanity check to make sure that free lists only have freed - lcrecords and there are no freed lcrecords elsewhere. */ - unsigned int free :1; }; /* Used for lcrecords in an lcrecord-list. */
--- a/src/marker.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/marker.c Sat Mar 13 05:38:08 2010 -0600 @@ -60,7 +60,7 @@ Lisp_Marker *marker = XMARKER (obj); if (print_readably) - printing_unreadable_object ("#<marker 0x%lx>", (long) marker); + printing_unreadable_object_fmt ("#<marker 0x%lx>", (long) marker); write_ascstring (printcharfun, GETTEXT ("#<marker ")); if (!marker->buffer)
--- a/src/mule-charset.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/mule-charset.c Sat Mar 13 05:38:08 2010 -0600 @@ -141,7 +141,7 @@ Lisp_Charset *cs = XCHARSET (obj); if (print_readably) - printing_unreadable_lcrecord + printing_unreadable_lisp_object (obj, XSTRING_DATA (XSYMBOL (XCHARSET_NAME (obj))->name)); write_fmt_string_lisp (printcharfun, "#<charset %s %S %S %S", 4, @@ -158,7 +158,7 @@ CHARSET_GRAPHIC (cs), CHARSET_FINAL (cs)); print_internal (CHARSET_REGISTRIES (cs), printcharfun, 0); - write_fmt_string (printcharfun, " 0x%x>", cs->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (cs)); } static const struct memory_description charset_description[] = {
--- a/src/objects.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/objects.c Sat Mar 13 05:38:08 2010 -0600 @@ -104,13 +104,13 @@ { Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name); write_fmt_string_lisp (printcharfun, " on %s", 1, c->device); if (!NILP (c->device)) /* Vthe_null_color_instance */ MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, (c, printcharfun, escapeflag)); - write_fmt_string (printcharfun, " 0x%x>", c->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (c)); } static void @@ -319,7 +319,7 @@ { Lisp_Font_Instance *f = XFONT_INSTANCE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name); write_fmt_string_lisp (printcharfun, " on %s", 1, f->device); if (!NILP (f->device)) @@ -328,7 +328,7 @@ (f, printcharfun, escapeflag)); } - write_fmt_string (printcharfun, " 0x%x>", f->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (f)); } static void
--- a/src/print.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/print.c Sat Mar 13 05:38:08 2010 -0600 @@ -1415,7 +1415,7 @@ if (EQ (obj, tortoise) && len > 0) { if (print_readably) - printing_unreadable_object ("circular list"); + printing_unreadable_object_fmt ("circular list"); else write_ascstring (printcharfun, "... <circular list>"); break; @@ -1523,7 +1523,7 @@ } DOESNT_RETURN -printing_unreadable_object (const Ascbyte *fmt, ...) +printing_unreadable_object_fmt (const Ascbyte *fmt, ...) { Lisp_Object obj; va_list args; @@ -1537,38 +1537,28 @@ } DOESNT_RETURN -printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name) +printing_unreadable_lisp_object (Lisp_Object obj, const Ibyte *name) { - NORMAL_LISP_OBJECT_HEADER *header = (NORMAL_LISP_OBJECT_HEADER *) XPNTR (obj); + struct lrecord_header *header = (struct lrecord_header *) XPNTR (obj); const struct lrecord_implementation *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); -#ifndef NEW_GC - /* This must be a real lcrecord */ - assert (!imp->frob_block_p); -#endif - if (name) - printing_unreadable_object ("#<%s %s 0x%x>", imp->name, name, header->uid); + printing_unreadable_object_fmt ("#<%s %s 0x%x>", imp->name, name, header->uid); else - printing_unreadable_object ("#<%s 0x%x>", imp->name, header->uid); + printing_unreadable_object_fmt ("#<%s 0x%x>", imp->name, header->uid); } void external_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) { - NORMAL_LISP_OBJECT_HEADER *header = (NORMAL_LISP_OBJECT_HEADER *) XPNTR (obj); + struct lrecord_header *header = (struct lrecord_header *) XPNTR (obj); const struct lrecord_implementation *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); -#ifndef NEW_GC - /* This must be a real lcrecord */ - assert (!imp->frob_block_p); -#endif - if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<%s 0x%x>", imp->name, header->uid); } @@ -1578,7 +1568,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_object + printing_unreadable_object_fmt ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", XRECORD_LHEADER_IMPLEMENTATION (obj)->name, (unsigned long) XPNTR (obj)); @@ -2428,19 +2418,10 @@ debug_out ("<< bad object type=%d 0x%lx>>", header->type, (EMACS_INT) header); else -#ifdef NEW_GC debug_out ("#<%s addr=0x%lx uid=0x%lx>", LHEADER_IMPLEMENTATION (header)->name, (EMACS_INT) header, (EMACS_INT) ((struct lrecord_header *) header)->uid); -#else /* not NEW_GC */ - debug_out ("#<%s addr=0x%lx uid=0x%lx>", - LHEADER_IMPLEMENTATION (header)->name, - (EMACS_INT) header, - (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->frob_block_p ? - ((struct lrecord_header *) header)->uid : - ((struct old_lcrecord_header *) header)->uid)); -#endif /* not NEW_GC */ } }
--- a/src/process.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/process.c Sat Mar 13 05:38:08 2010 -0600 @@ -150,7 +150,7 @@ Lisp_Process *process = XPROCESS (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (process->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (process->name)); if (!escapeflag) {
--- a/src/rangetab.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/rangetab.c Sat Mar 13 05:38:08 2010 -0600 @@ -133,7 +133,7 @@ if (print_readably) write_ascstring (printcharfun, "))"); else - write_fmt_string (printcharfun, " 0x%x>", rt->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (rt)); } static int
--- a/src/scrollbar.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/scrollbar.c Sat Mar 13 05:38:08 2010 -0600 @@ -112,7 +112,7 @@ struct device *d = XDEVICE (frame->device); MAYBE_DEVMETH (d, free_scrollbar_instance, (instance)); - /* not worth calling free_managed_lcrecord() -- scrollbar instances + /* not worth calling free_normal_lisp_object() -- scrollbar instances are not created that frequently and it's dangerous. */ } }
--- a/src/specifier.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/specifier.c Sat Mar 13 05:38:08 2010 -0600 @@ -280,8 +280,8 @@ Lisp_Object the_specs; if (print_readably) - printing_unreadable_object ("#<%s-specifier 0x%x>", - sp->methods->name, sp->header.uid); + printing_unreadable_object_fmt ("#<%s-specifier 0x%x>", + sp->methods->name, NORMAL_LISP_OBJECT_UID (sp)); write_fmt_string (printcharfun, "#<%s-specifier global=", sp->methods->name); #if 0 @@ -302,7 +302,7 @@ write_fmt_string_lisp (printcharfun, " fallback=%S", 1, sp->fallback); } unbind_to (count); - write_fmt_string (printcharfun, " 0x%x>", sp->header.uid); + write_fmt_string (printcharfun, " 0x%x>", NORMAL_LISP_OBJECT_UID (sp)); } #ifndef NEW_GC
--- a/src/symbols.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/symbols.c Sat Mar 13 05:38:08 2010 -0600 @@ -3521,8 +3521,6 @@ 1, /* lisp_readonly bit */ }, 0, /* next */ - 0, /* uid */ - 0, /* free */ }, 0, /* value */ SYMVAL_UNBOUND_MARKER
--- a/src/symeval.h Sun Mar 07 19:26:04 2010 -0600 +++ b/src/symeval.h Sat Mar 13 05:38:08 2010 -0600 @@ -1,6 +1,6 @@ /* Definitions of symbol-value forwarding for XEmacs Lisp interpreter. Copyright (C) 1985, 1986, 1987, 1992, 1993 Free Software Foundation, Inc. - Copyright (C) 2000, 2001, 2002 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -425,11 +425,8 @@ 1, /* mark bit */ \ 1, /* c_readonly bit */ \ 1, /* lisp_readonly bit */ \ - 0 /* unused */ \ }, \ 0, /* next */ \ - 0, /* uid */ \ - 0 /* free */ \ }, \ c_location, \ forward_type \
--- a/src/tooltalk.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/tooltalk.c Sat Mar 13 05:38:08 2010 -0600 @@ -172,10 +172,10 @@ Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<tooltalk-message id:0x%lx 0x%x>", - (long) (p->m), p->header.uid); + (long) (p->m), NORMAL_LISP_OBJECT_UID (p)); } DEFINE_NODUMP_LISP_OBJECT ("tooltalk-message", tooltalk_message, @@ -247,10 +247,10 @@ Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<tooltalk-pattern id:0x%lx 0x%x>", - (long) (p->p), p->header.uid); + (long) (p->p), NORMAL_LISP_OBJECT_UID (p)); } DEFINE_NODUMP_LISP_OBJECT ("tooltalk-pattern", tooltalk_pattern,
--- a/src/ui-gtk.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/ui-gtk.c Sat Mar 13 05:38:08 2010 -0600 @@ -327,7 +327,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<ffi %S", 1, XFFI (obj)->function_name); if (XFFI (obj)->n_args) @@ -796,7 +796,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<GtkObject ("); if (XGTK_OBJECT (obj)->alive_p) @@ -1104,7 +1104,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<GtkBoxed ("); write_cistring (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type));
--- a/src/window.c Sun Mar 07 19:26:04 2010 -0600 +++ b/src/window.c Sat Mar 13 05:38:08 2010 -0600 @@ -309,7 +309,7 @@ Lisp_Object buf; if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<window"); buf = XWINDOW_BUFFER (obj); @@ -321,7 +321,8 @@ Lisp_Object name = XBUFFER (buf)->name; write_fmt_string_lisp (printcharfun, " on %S", 1, name); } - write_fmt_string (printcharfun, " 0x%x>", XWINDOW (obj)->header.uid); + write_fmt_string (printcharfun, " 0x%x>", + NORMAL_LISP_OBJECT_UID (XWINDOW (obj))); } static void @@ -678,7 +679,7 @@ #endif free_display_structs (mir); mir = mir->next; - /* not worth calling free_managed_lcrecord() -- window mirrors + /* not worth calling free_normal_lisp_object() -- window mirrors are not created that frequently and it's dangerous. we don't know for sure that there aren't other pointers around -- e.g. in a scrollbar instance. */ @@ -5406,7 +5407,7 @@ if (!NILP (buffer) && BUFFERP (buffer)) stderr_out (" on %s", XSTRING_DATA (XBUFFER (buffer)->name)); } - stderr_out (" 0x%x>", XWINDOW (window)->header.uid); + stderr_out (" 0x%x>", NORMAL_LISP_OBJECT_UID (XWINDOW (window))); while (!NILP (child)) {
--- a/src/xemacs.def.in.in Sun Mar 07 19:26:04 2010 -0600 +++ b/src/xemacs.def.in.in Sat Mar 13 05:38:08 2010 -0600 @@ -164,7 +164,8 @@ non_ascii_valid_ichar_p /* valid_ichar_p */ #endif out_of_memory /* The postgresql module uses this */ -printing_unreadable_object +printing_unreadable_lisp_object +printing_unreadable_object_fmt #ifdef XEMACS_DEFS_NEEDS_INLINE_DECLS qxestrdup qxestrlen