Mercurial > hg > xemacs-beta
annotate src/free-hook.c @ 5146:88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-03-15 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (c_readonly):
* alloc.c (deadbeef_memory):
* alloc.c (make_compiled_function):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (noseeum_make_marker):
* alloc.c (ADDITIONAL_FREE_string):
* alloc.c (common_init_alloc_early):
* alloc.c (init_alloc_once_early):
* bytecode.c (print_compiled_function):
* bytecode.c (mark_compiled_function):
* casetab.c:
* casetab.c (print_case_table):
* console.c:
* console.c (print_console):
* 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_multiple_value):
* eval.c (mark_multiple_value):
* events.c (deinitialize_event):
* events.c (print_event):
* events.c (event_equal):
* extents.c:
* extents.c (soe_dump):
* extents.c (soe_insert):
* extents.c (soe_delete):
* extents.c (soe_move):
* extents.c (extent_fragment_update):
* extents.c (print_extent_1):
* extents.c (print_extent):
* extents.c (vars_of_extents):
* frame.c:
* frame.c (print_frame):
* free-hook.c:
* free-hook.c (check_free):
* glyphs.c:
* glyphs.c (print_image_instance):
* glyphs.c (print_glyph):
* gui.c:
* gui.c (copy_gui_item):
* hash.c:
* hash.c (NULL_ENTRY):
* hash.c (KEYS_DIFFER_P):
* keymap.c (print_keymap):
* keymap.c (MARKED_SLOT):
* lisp.h:
* lrecord.h:
* lrecord.h (LISP_OBJECT_UID):
* lrecord.h (set_lheader_implementation):
* lrecord.h (struct old_lcrecord_header):
* lstream.c (print_lstream):
* lstream.c (finalize_lstream):
* marker.c (print_marker):
* marker.c (marker_equal):
* mc-alloc.c (visit_all_used_page_headers):
* mule-charset.c:
* mule-charset.c (print_charset):
* objects.c (print_color_instance):
* objects.c (print_font_instance):
* objects.c (finalize_font_instance):
* opaque.c (print_opaque):
* opaque.c (print_opaque_ptr):
* opaque.c (equal_opaque_ptr):
* print.c (internal_object_printer):
* print.c (enum printing_badness):
* rangetab.c (print_range_table):
* rangetab.c (range_table_equal):
* specifier.c (print_specifier):
* specifier.c (finalize_specifier):
* symbols.c:
* symbols.c (print_symbol_value_magic):
* tooltalk.c:
* tooltalk.c (print_tooltalk_message):
* tooltalk.c (print_tooltalk_pattern):
* window.c (print_window):
* window.c (debug_print_window):
(1) Make lrecord UID's have a separate UID space for each object.
Otherwise, with 20-bit UID's, we rapidly wrap around, especially
when common objects like conses and strings increment the UID value
for every object created. (Originally I tried making two UID spaces,
one for objects that always print readably and hence don't display
the UID, and one for other objects. But certain objects like markers
for which a UID is displayed are still generated rapidly enough that
UID overflow is a serious issue.) This also has the advantage of
making UID values smaller, hence easier to remember -- their main
purpose is to make it easier to keep track of different objects of
the same type when debugging code. Make sure we dump lrecord UID's
so that we don't have problems with pdumped and non-dumped objects
having the same UID.
(2) Display UID's consistently whenever an object (a) doesn't
consistently print readably (objects like cons and string, which
always print readably, can't display a UID), and (b) doesn't
otherwise have a unique property that makes objects of a
particular type distinguishable. (E.g. buffers didn't and still
don't print an ID, but the buffer name uniquely identifies the
buffer.) Some types, such as event, extent, compiled-function,
didn't always (or didn't ever) display an ID; others (such as
marker, extent, lstream, opaque, opaque-ptr, any object using
internal_object_printer()) used to display the actual machine
pointer instead.
(3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work
over all Lisp objects and take a Lisp object, not a struct pointer.
(4) Some misc cleanups in alloc.c, elhash.c.
(5) Change code in events.c that "deinitializes" an event so that
it doesn't increment the event UID counter in the process. Also
use deadbeef_memory() to overwrite memory instead of doing the same
with custom code. In the process, make deadbeef_memory() in
alloc.c always available, and delete extraneous copy in mc-alloc.c.
Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c
call deadbeef_memory().
(6) Resurrect "debug SOE" code in extents.c. Make it conditional
on DEBUG_XEMACS and on a `debug-soe' variable, rather than on
SOE_DEBUG. Make it output to stderr, not stdout.
(7) Delete some custom print methods that were identical to
external_object_printer().
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 15 Mar 2010 16:35:38 -0500 |
| parents | 6f2158fa75ed |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
1 /* Copyright (C) 2010 Ben Wing. |
|
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
2 This file is part of XEmacs. |
| 428 | 3 |
| 4 XEmacs is free software; you can redistribute it and/or modify it | |
| 5 under the terms of the GNU General Public License as published by the | |
| 6 Free Software Foundation; either version 2, or (at your option) any | |
| 7 later version. | |
| 8 | |
| 9 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 10 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 11 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 12 for more details. | |
| 13 | |
| 14 You should have received a copy of the GNU General Public License | |
| 15 along with XEmacs; see the file COPYING. If not, write to | |
| 16 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 17 Boston, MA 02111-1307, USA. */ | |
| 18 | |
| 19 /* Synched up with: Not in FSF. */ | |
| 20 | |
| 21 /* Debugging hooks for malloc. */ | |
| 22 | |
| 23 /* These hooks work with gmalloc to catch allocation errors. | |
| 24 In particular, the following is trapped: | |
| 25 | |
| 26 * Freeing the same pointer twice. | |
| 27 * Trying to free a pointer not returned by malloc. | |
| 28 * Trying to realloc a pointer not returned by malloc. | |
| 29 | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
30 In addition, every word of every block freed is set to 0xDEADBEEF |
| 1204 | 31 (-559038737). This causes many uses of freed storage to be trapped or |
| 32 recognized. | |
| 428 | 33 |
| 34 When you use this, the storage used by the last FREE_QUEUE_LIMIT | |
| 35 calls to free() is not recycled. When you call free for the Nth | |
| 36 time, the (N - FREE_QUEUE_LIMIT)'th block is actually recycled. | |
| 37 | |
| 38 For these last FREE_QUEUE_LIMIT calls to free() a backtrace is | |
| 39 saved showing where it was called from. The function | |
| 40 find_backtrace() is provided here to be called from GDB with a | |
| 41 pointer (such as would be passed to free()) as argument, e.g. | |
| 42 (gdb) p/a *find_backtrace (0x234000). If SAVE_ARGS is defined, | |
| 43 the first three arguments to each function are saved as well as the | |
| 44 return addresses. | |
| 45 | |
| 46 If UNMAPPED_FREE is defined, instead of setting every word of freed | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
47 storage to 0xDEADBEEF, every call to malloc goes on its own page(s). |
| 428 | 48 When free() is called, the block is read and write protected. This |
| 49 is very useful when debugging, since it usually generates a bus error | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
50 when the DEADBEEF hack might only cause some garbage to be printed. |
| 428 | 51 However, this is too slow for everyday use, since it takes an enormous |
| 52 number of pages. | |
| 53 | |
| 54 | |
| 55 Some other features that would be useful are: | |
| 56 | |
| 57 * Checking for storage leaks. | |
| 58 This could be done by a GC-like facility that would scan the data | |
| 59 segment looking for pointers to allocated storage and tell you | |
| 60 about those that are no longer referenced. This could be invoked | |
| 61 at any time. Another possibility is to report on what allocated | |
| 62 storage is still in use when the process is exited. Typically | |
| 63 there will be a large amount, so this might not be very useful. | |
| 64 */ | |
| 65 | |
| 66 #ifdef emacs | |
| 67 #include <config.h> | |
| 68 #include "lisp.h" | |
| 69 #else | |
| 70 void *malloc (size_t); | |
| 71 #endif | |
| 72 | |
| 73 #if !defined(HAVE_LIBMCHECK) | |
| 74 #include <stdio.h> | |
| 75 | |
| 76 #include "hash.h" | |
| 77 | |
| 78 #ifdef UNMAPPED_FREE | |
| 79 #include <sys/mman.h> | |
| 80 #include <sys/param.h> | |
| 81 #define ROUND_UP_TO_PAGE(i) (((i) + PAGEOFFSET) & PAGEMASK) | |
| 82 #endif | |
| 83 | |
| 84 #include <sys/types.h> | |
| 85 | |
| 86 /* System function prototypes don't belong in C source files */ | |
| 87 /* extern void free (void *); */ | |
| 88 | |
| 89 static struct hash_table *pointer_table; | |
| 90 | |
| 91 extern void (*__free_hook) (void *); | |
| 92 extern void *(*__malloc_hook) (size_t); | |
| 93 | |
| 94 static void *check_malloc (size_t); | |
| 95 | |
| 96 typedef void (*fun_ptr) (void); | |
| 97 | |
| 98 /* free_queue is not too useful without backtrace logging */ | |
| 99 #define FREE_QUEUE_LIMIT 1 | |
| 100 #define TRACE_LIMIT 20 | |
| 101 | |
| 102 typedef struct { | |
| 103 fun_ptr return_pc; | |
| 104 #ifdef SAVE_ARGS | |
| 105 void *arg[3]; | |
| 106 #endif | |
| 107 } fun_entry; | |
| 108 | |
| 109 typedef struct { | |
| 110 void *address; | |
| 111 unsigned long length; | |
| 112 } free_queue_entry; | |
| 113 | |
| 114 static free_queue_entry free_queue[FREE_QUEUE_LIMIT]; | |
| 115 | |
| 116 static int current_free; | |
| 117 | |
| 118 static int strict_free_check; | |
| 119 | |
| 120 static void | |
| 121 check_free (void *ptr) | |
| 122 { | |
| 123 __free_hook = 0; | |
| 124 __malloc_hook = 0; | |
| 125 if (!pointer_table) | |
| 126 pointer_table = make_hash_table (max (100, FREE_QUEUE_LIMIT * 2)); | |
| 127 if (ptr != 0) | |
| 128 { | |
| 129 long size; | |
| 130 #ifdef UNMAPPED_FREE | |
| 131 unsigned long rounded_up_size; | |
| 132 #endif | |
| 133 | |
| 134 EMACS_INT present = (EMACS_INT) gethash (ptr, pointer_table, | |
| 2519 | 135 (const void **) |
| 136 (void *) &size); | |
| 428 | 137 |
| 138 if (!present) | |
| 139 { | |
| 140 /* This can only happen if you try to free something that didn't | |
| 141 come from malloc */ | |
| 142 #if !defined(__linux__) | |
| 143 /* I originally wrote: "There's really no need to drop core." | |
| 144 I have seen the error of my ways. -slb */ | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
145 assert (!strict_free_check); |
| 428 | 146 #endif |
| 147 printf("Freeing unmalloc'ed memory at %p\n", ptr); | |
| 148 __free_hook = check_free; | |
| 149 __malloc_hook = check_malloc; | |
| 150 goto end; | |
| 151 } | |
| 152 | |
| 153 if (size < 0) | |
| 154 { | |
| 155 /* This happens when you free twice */ | |
| 156 #if !defined(__linux__) | |
| 157 /* See above comment. */ | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
158 assert (!strict_free_check); |
| 428 | 159 #endif |
| 160 printf("Freeing %p twice\n", ptr); | |
| 161 __free_hook = check_free; | |
| 162 __malloc_hook = check_malloc; | |
| 163 goto end; | |
| 164 } | |
| 165 | |
| 166 puthash (ptr, (void *)-size, pointer_table); | |
| 167 #ifdef UNMAPPED_FREE | |
| 168 /* Round up size to an even number of pages. */ | |
| 169 rounded_up_size = ROUND_UP_TO_PAGE (size); | |
| 170 /* Protect the pages freed from all access */ | |
| 171 if (strict_free_check) | |
| 172 mprotect (ptr, rounded_up_size, PROT_NONE); | |
| 173 #else | |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
174 /* Set every word in the block to 0xDEADBEEF */ |
| 428 | 175 if (strict_free_check) |
| 176 { | |
| 177 unsigned long long_length = (size + (sizeof (long) - 1)) | |
| 178 / sizeof (long); | |
| 179 unsigned long i; | |
| 180 | |
| 3988 | 181 /* Not using the DEADBEEF_CONSTANT #define, since we don't know |
| 182 * that allocation sizes will be multiples of eight. */ | |
| 428 | 183 for (i = 0; i < long_length; i++) |
|
5146
88bd4f3ef8e4
make lrecord UID's have a separate UID space for each object, resurrect debug SOE code in extents.c
Ben Wing <ben@xemacs.org>
parents:
5050
diff
changeset
|
184 ((unsigned long *) ptr)[i] = 0xDEADBEEF; |
| 428 | 185 } |
| 186 #endif | |
| 187 free_queue[current_free].address = ptr; | |
| 188 free_queue[current_free].length = size; | |
| 189 | |
| 190 current_free++; | |
| 191 if (current_free >= FREE_QUEUE_LIMIT) | |
| 192 current_free = 0; | |
| 193 /* Really free this if there's something there */ | |
| 194 { | |
| 195 void *old = free_queue[current_free].address; | |
| 196 | |
| 197 if (old) | |
| 198 { | |
| 199 #ifdef UNMAPPED_FREE | |
| 200 unsigned long old_len = free_queue[current_free].length; | |
| 201 | |
| 202 mprotect (old, old_len, PROT_READ | PROT_WRITE | PROT_EXEC); | |
| 203 #endif | |
| 204 free (old); | |
| 205 remhash (old, pointer_table); | |
| 206 } | |
| 207 } | |
| 208 } | |
| 209 __free_hook = check_free; | |
| 210 __malloc_hook = check_malloc; | |
| 211 | |
| 212 end: | |
| 213 return; | |
| 214 } | |
| 215 | |
| 216 static void * | |
| 217 check_malloc (size_t size) | |
| 218 { | |
| 219 size_t rounded_up_size; | |
| 220 void *result; | |
| 221 | |
| 222 __free_hook = 0; | |
| 223 __malloc_hook = 0; | |
| 224 if (size == 0) | |
| 225 { | |
| 226 result = 0; | |
| 227 goto end; | |
| 228 } | |
| 229 #ifdef UNMAPPED_FREE | |
| 230 /* Round up to an even number of pages. */ | |
| 231 rounded_up_size = ROUND_UP_TO_PAGE (size); | |
| 232 #else | |
| 233 rounded_up_size = size; | |
| 234 #endif | |
| 235 result = malloc (rounded_up_size); | |
| 236 if (!pointer_table) | |
| 237 pointer_table = make_hash_table (FREE_QUEUE_LIMIT * 2); | |
| 238 puthash (result, (void *)size, pointer_table); | |
| 239 __free_hook = check_free; | |
| 240 __malloc_hook = check_malloc; | |
| 241 end: | |
| 242 return result; | |
| 243 } | |
| 244 | |
| 245 extern void *(*__realloc_hook) (void *, size_t); | |
| 246 | |
| 247 #ifdef MIN | |
| 248 #undef MIN | |
| 249 #endif | |
| 250 #define MIN(A, B) ((A) < (B) ? (A) : (B)) | |
| 251 | |
| 252 /* Don't optimize realloc */ | |
| 253 | |
| 254 static void * | |
| 255 check_realloc (void * ptr, size_t size) | |
| 256 { | |
| 257 EMACS_INT present; | |
| 258 size_t old_size; | |
| 259 void *result = malloc (size); | |
| 260 | |
| 261 if (!ptr) return result; | |
| 442 | 262 present = (EMACS_INT) gethash (ptr, pointer_table, (const void **) &old_size); |
| 428 | 263 if (!present) |
| 264 { | |
| 265 /* This can only happen by reallocing a pointer that didn't | |
| 266 come from malloc. */ | |
| 267 #if !defined(__linux__) | |
| 268 /* see comment in check_free(). */ | |
| 2500 | 269 ABORT (); |
| 428 | 270 #endif |
| 271 printf("Realloc'ing unmalloc'ed pointer at %p\n", ptr); | |
| 272 } | |
| 273 | |
| 274 if (result == 0) | |
| 275 goto end; | |
| 276 memcpy (result, ptr, MIN (size, old_size)); | |
| 277 free (ptr); | |
| 278 end: | |
| 279 return result; | |
| 280 } | |
| 281 | |
| 282 void enable_strict_free_check (void); | |
| 283 void | |
| 284 enable_strict_free_check (void) | |
| 285 { | |
| 286 strict_free_check = 1; | |
| 287 } | |
| 288 | |
| 289 void disable_strict_free_check (void); | |
| 290 void | |
| 291 disable_strict_free_check (void) | |
| 292 { | |
| 293 strict_free_check = 0; | |
| 294 } | |
| 295 | |
| 296 /* Note: All BLOCK_INPUT stuff removed from this file because it's | |
| 297 completely gone in XEmacs */ | |
| 298 | |
| 299 static void * | |
| 300 block_input_malloc (size_t size); | |
| 301 | |
| 302 static void | |
| 303 block_input_free (void* ptr) | |
| 304 { | |
| 305 __free_hook = 0; | |
| 306 __malloc_hook = 0; | |
| 307 free (ptr); | |
| 308 __free_hook = block_input_free; | |
| 309 __malloc_hook = block_input_malloc; | |
| 310 } | |
| 311 | |
| 312 static void * | |
| 313 block_input_malloc (size_t size) | |
| 314 { | |
| 315 void* result; | |
| 316 __free_hook = 0; | |
| 317 __malloc_hook = 0; | |
| 318 result = malloc (size); | |
| 319 __free_hook = block_input_free; | |
| 320 __malloc_hook = block_input_malloc; | |
| 321 return result; | |
| 322 } | |
| 323 | |
| 324 | |
| 325 static void * | |
| 326 block_input_realloc (void* ptr, size_t size) | |
| 327 { | |
| 328 void* result; | |
| 329 __free_hook = 0; | |
| 330 __malloc_hook = 0; | |
| 331 __realloc_hook = 0; | |
| 332 result = realloc (ptr, size); | |
| 333 __free_hook = block_input_free; | |
| 334 __malloc_hook = block_input_malloc; | |
| 335 __realloc_hook = block_input_realloc; | |
| 336 return result; | |
| 337 } | |
| 338 | |
| 339 #ifdef emacs | |
| 340 | |
| 341 void disable_free_hook (void); | |
| 342 void | |
| 343 disable_free_hook (void) | |
| 344 { | |
| 345 __free_hook = block_input_free; | |
| 346 __malloc_hook = block_input_malloc; | |
| 347 __realloc_hook = block_input_realloc; | |
| 348 } | |
| 349 | |
| 350 void | |
| 351 init_free_hook (void) | |
| 352 { | |
| 353 __free_hook = check_free; | |
| 354 __malloc_hook = check_malloc; | |
| 355 __realloc_hook = check_realloc; | |
| 356 current_free = 0; | |
| 357 strict_free_check = 1; | |
| 358 } | |
| 359 | |
| 360 void really_free_one_entry (void *, int, int *); | |
| 361 | |
| 362 DEFUN ("really-free", Freally_free, 0, 1, "P", /* | |
| 363 Actually free the storage held by the free() debug hook. | |
| 364 A no-op if the free hook is disabled. | |
| 365 */ | |
| 2286 | 366 (UNUSED (arg))) |
| 428 | 367 { |
| 368 int count[2]; | |
| 369 Lisp_Object lisp_count[2]; | |
| 370 | |
| 371 if ((__free_hook != 0) && pointer_table) | |
| 372 { | |
| 373 count[0] = 0; | |
| 374 count[1] = 0; | |
| 375 __free_hook = 0; | |
| 376 maphash ((maphash_function)really_free_one_entry, | |
| 377 pointer_table, (void *)&count); | |
| 378 memset (free_queue, 0, sizeof (free_queue_entry) * FREE_QUEUE_LIMIT); | |
| 379 current_free = 0; | |
| 380 __free_hook = check_free; | |
| 793 | 381 lisp_count[0] = make_int (count[0]); |
| 382 lisp_count[1] = make_int (count[1]); | |
| 428 | 383 return Fcons (lisp_count[0], lisp_count[1]); |
| 384 } | |
| 385 else | |
| 386 return Fcons (make_int (0), make_int (0)); | |
| 387 } | |
| 388 | |
| 389 void | |
| 390 really_free_one_entry (void *key, int contents, int *countp) | |
| 391 { | |
| 392 if (contents < 0) | |
| 393 { | |
| 394 free (key); | |
| 395 #ifdef UNMAPPED_FREE | |
| 396 mprotect (key, -contents, PROT_READ | PROT_WRITE | PROT_EXEC); | |
| 397 #endif | |
| 398 remhash (key, pointer_table); | |
| 399 countp[0]++; | |
| 400 countp[1] += -contents; | |
| 401 } | |
| 402 } | |
| 403 | |
| 404 void | |
| 405 syms_of_free_hook (void) | |
| 406 { | |
| 407 DEFSUBR (Freally_free); | |
| 408 } | |
| 409 | |
| 410 #else | |
| 411 void (*__free_hook)(void *) = check_free; | |
| 412 void *(*__malloc_hook)(size_t) = check_malloc; | |
| 413 void *(*__realloc_hook)(void *, size_t) = check_realloc; | |
| 414 #endif | |
| 415 | |
| 416 #endif /* !defined(HAVE_LIBMCHECK) */ | |
| 417 | |
| 418 #if defined(DEBUG_INPUT_BLOCKING) || defined (DEBUG_GCPRO) | |
| 419 | |
| 420 /* Note: There is no more input blocking in XEmacs */ | |
| 421 typedef enum { | |
| 422 block_type, unblock_type, totally_type, | |
| 423 gcpro1_type, gcpro2_type, gcpro3_type, gcpro4_type, gcpro5_type, | |
| 424 ungcpro_type | |
| 425 } blocktype; | |
| 426 | |
| 427 struct block_input_history_struct | |
| 428 { | |
| 429 char *file; | |
| 430 int line; | |
| 431 blocktype type; | |
| 432 int value; | |
| 433 }; | |
| 434 | |
| 435 typedef struct block_input_history_struct block_input_history; | |
| 436 | |
| 437 #endif /* DEBUG_INPUT_BLOCKING || DEBUG_GCPRO */ | |
| 438 | |
| 439 #ifdef DEBUG_INPUT_BLOCKING | |
| 440 | |
| 441 int blhistptr; | |
| 442 | |
| 443 #define BLHISTLIMIT 1000 | |
| 444 | |
| 445 block_input_history blhist[BLHISTLIMIT]; | |
| 446 | |
| 447 note_block_input (char *file, int line) | |
| 448 { | |
| 449 note_block (file, line, block_type); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
450 assert (interrupt_input_blocked <= 2); |
| 428 | 451 } |
| 452 | |
| 453 note_unblock_input (char* file, int line) | |
| 454 { | |
| 455 note_block (file, line, unblock_type); | |
| 456 } | |
| 457 | |
| 458 note_totally_unblocked (char* file, int line) | |
| 459 { | |
| 460 note_block (file, line, totally_type); | |
| 461 } | |
| 462 | |
| 463 note_block (char *file, int line, blocktype type) | |
| 464 { | |
| 465 blhist[blhistptr].file = file; | |
| 466 blhist[blhistptr].line = line; | |
| 467 blhist[blhistptr].type = type; | |
| 468 blhist[blhistptr].value = interrupt_input_blocked; | |
| 469 | |
| 470 blhistptr++; | |
| 471 if (blhistptr >= BLHISTLIMIT) | |
| 472 blhistptr = 0; | |
| 473 } | |
| 474 | |
| 475 #endif /* DEBUG_INPUT_BLOCKING */ | |
| 476 | |
| 477 | |
| 478 #ifdef DEBUG_GCPRO | |
| 479 | |
| 480 int gcprohistptr; | |
| 481 #define GCPROHISTLIMIT 1000 | |
| 482 block_input_history gcprohist[GCPROHISTLIMIT]; | |
| 483 | |
| 484 static void | |
| 485 log_gcpro (char *file, int line, struct gcpro *value, blocktype type) | |
| 486 { | |
| 487 if (type == ungcpro_type) | |
| 488 { | |
| 489 if (value == gcprolist) goto OK; | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
490 assert (gcprolist); |
| 428 | 491 if (value == gcprolist->next) goto OK; |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
492 assert (gcprolist->next); |
| 428 | 493 if (value == gcprolist->next->next) goto OK; |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
494 assert (gcprolist->next->next); |
| 428 | 495 if (value == gcprolist->next->next->next) goto OK; |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
496 assert (gcprolist->next->next->next); |
| 446 | 497 if (value == gcprolist->next->next->next->next) goto OK; |
| 2500 | 498 ABORT (); |
| 428 | 499 OK:; |
| 500 } | |
| 501 gcprohist[gcprohistptr].file = file; | |
| 502 gcprohist[gcprohistptr].line = line; | |
| 503 gcprohist[gcprohistptr].type = type; | |
| 504 gcprohist[gcprohistptr].value = (int) value; | |
| 505 gcprohistptr++; | |
| 506 if (gcprohistptr >= GCPROHISTLIMIT) | |
| 507 gcprohistptr = 0; | |
| 508 } | |
| 509 | |
| 510 void | |
| 511 debug_gcpro1 (char *file, int line, struct gcpro *gcpro1, Lisp_Object *var) | |
| 512 { | |
| 513 gcpro1->next = gcprolist; gcpro1->var = var; gcpro1->nvars = 1; | |
| 514 gcprolist = gcpro1; | |
| 515 log_gcpro (file, line, gcpro1, gcpro1_type); | |
| 516 } | |
| 517 | |
| 518 void | |
| 519 debug_gcpro2 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 520 Lisp_Object *var1, Lisp_Object *var2) | |
| 521 { | |
| 522 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 523 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 524 gcprolist = gcpro2; | |
| 525 log_gcpro (file, line, gcpro2, gcpro2_type); | |
| 526 } | |
| 527 | |
| 528 void | |
| 529 debug_gcpro3 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 530 struct gcpro *gcpro3, Lisp_Object *var1, Lisp_Object *var2, | |
| 531 Lisp_Object *var3) | |
| 532 { | |
| 533 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 534 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 535 gcpro3->next = gcpro2; gcpro3->var = var3; gcpro3->nvars = 1; | |
| 536 gcprolist = gcpro3; | |
| 537 log_gcpro (file, line, gcpro3, gcpro3_type); | |
| 538 } | |
| 539 | |
| 540 void | |
| 541 debug_gcpro4 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 542 struct gcpro *gcpro3, struct gcpro *gcpro4, Lisp_Object *var1, | |
| 543 Lisp_Object *var2, Lisp_Object *var3, Lisp_Object *var4) | |
| 544 { | |
| 545 log_gcpro (file, line, gcpro4, gcpro4_type); | |
| 546 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 547 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 548 gcpro3->next = gcpro2; gcpro3->var = var3; gcpro3->nvars = 1; | |
| 549 gcpro4->next = gcpro3; gcpro4->var = var4; gcpro4->nvars = 1; | |
| 550 gcprolist = gcpro4; | |
| 551 } | |
| 552 | |
| 553 void | |
| 554 debug_gcpro5 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 555 struct gcpro *gcpro3, struct gcpro *gcpro4, struct gcpro *gcpro5, | |
| 556 Lisp_Object *var1, Lisp_Object *var2, Lisp_Object *var3, | |
| 557 Lisp_Object *var4, Lisp_Object *var5) | |
| 558 { | |
| 559 log_gcpro (file, line, gcpro5, gcpro5_type); | |
| 560 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 561 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 562 gcpro3->next = gcpro2; gcpro3->var = var3; gcpro3->nvars = 1; | |
| 563 gcpro4->next = gcpro3; gcpro4->var = var4; gcpro4->nvars = 1; | |
| 564 gcpro5->next = gcpro4; gcpro5->var = var5; gcpro5->nvars = 1; | |
| 565 gcprolist = gcpro5; | |
| 566 } | |
| 567 | |
| 568 void | |
| 569 debug_ungcpro (char *file, int line, struct gcpro *gcpro1) | |
| 570 { | |
| 571 log_gcpro (file, line, gcpro1, ungcpro_type); | |
| 572 gcprolist = gcpro1->next; | |
| 573 } | |
| 574 | |
| 575 | |
| 576 /* To be called from the debugger */ | |
| 577 void show_gcprohist (void); | |
| 578 void | |
| 579 show_gcprohist (void) | |
| 580 { | |
| 581 int i, j; | |
| 582 for (i = 0, j = gcprohistptr; | |
| 583 i < GCPROHISTLIMIT; | |
| 584 i++, j++) | |
| 585 { | |
| 586 if (j >= GCPROHISTLIMIT) | |
| 587 j = 0; | |
| 588 printf ("%3d %s %d %s 0x%x\n", | |
| 589 j, gcprohist[j].file, gcprohist[j].line, | |
| 590 (gcprohist[j].type == gcpro1_type ? "GCPRO1" : | |
| 591 gcprohist[j].type == gcpro2_type ? "GCPRO2" : | |
| 592 gcprohist[j].type == gcpro3_type ? "GCPRO3" : | |
| 593 gcprohist[j].type == gcpro4_type ? "GCPRO4" : | |
| 446 | 594 gcprohist[j].type == gcpro5_type ? "GCPRO5" : |
| 428 | 595 gcprohist[j].type == ungcpro_type ? "UNGCPRO" : "???"), |
| 596 gcprohist[j].value); | |
| 597 } | |
| 598 fflush (stdout); | |
| 599 } | |
| 600 | |
| 601 #endif /* DEBUG_GCPRO */ |