Mercurial > hg > xemacs-beta
annotate src/free-hook.c @ 5750:66d2f63df75f
Correct some spelling and formatting in behavior.el.
Mentioned in tracker issue 826, the third thing mentioned there (the file
name at the bottom of the file) had already been fixed.
lisp/ChangeLog addition:
2013-08-05 Aidan Kehoe <kehoea@parhasard.net>
* behavior.el:
(override-behavior):
Correct some spelling and formatting here, thank you Steven
Mitchell in tracker issue 826.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 05 Aug 2013 10:05:32 +0100 |
| parents | 56144c8593a8 |
| children |
| 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 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
4 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 5 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
6 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
7 option) any later version. |
| 428 | 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5146
diff
changeset
|
15 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 16 |
| 17 /* Synched up with: Not in FSF. */ | |
| 18 | |
| 19 /* Debugging hooks for malloc. */ | |
| 20 | |
| 21 /* These hooks work with gmalloc to catch allocation errors. | |
| 22 In particular, the following is trapped: | |
| 23 | |
| 24 * Freeing the same pointer twice. | |
| 25 * Trying to free a pointer not returned by malloc. | |
| 26 * Trying to realloc a pointer not returned by malloc. | |
| 27 | |
|
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
|
28 In addition, every word of every block freed is set to 0xDEADBEEF |
| 1204 | 29 (-559038737). This causes many uses of freed storage to be trapped or |
| 30 recognized. | |
| 428 | 31 |
| 32 When you use this, the storage used by the last FREE_QUEUE_LIMIT | |
| 33 calls to free() is not recycled. When you call free for the Nth | |
| 34 time, the (N - FREE_QUEUE_LIMIT)'th block is actually recycled. | |
| 35 | |
| 36 For these last FREE_QUEUE_LIMIT calls to free() a backtrace is | |
| 37 saved showing where it was called from. The function | |
| 38 find_backtrace() is provided here to be called from GDB with a | |
| 39 pointer (such as would be passed to free()) as argument, e.g. | |
| 40 (gdb) p/a *find_backtrace (0x234000). If SAVE_ARGS is defined, | |
| 41 the first three arguments to each function are saved as well as the | |
| 42 return addresses. | |
| 43 | |
| 44 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
|
45 storage to 0xDEADBEEF, every call to malloc goes on its own page(s). |
| 428 | 46 When free() is called, the block is read and write protected. This |
| 47 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
|
48 when the DEADBEEF hack might only cause some garbage to be printed. |
| 428 | 49 However, this is too slow for everyday use, since it takes an enormous |
| 50 number of pages. | |
| 51 | |
| 52 | |
| 53 Some other features that would be useful are: | |
| 54 | |
| 55 * Checking for storage leaks. | |
| 56 This could be done by a GC-like facility that would scan the data | |
| 57 segment looking for pointers to allocated storage and tell you | |
| 58 about those that are no longer referenced. This could be invoked | |
| 59 at any time. Another possibility is to report on what allocated | |
| 60 storage is still in use when the process is exited. Typically | |
| 61 there will be a large amount, so this might not be very useful. | |
| 62 */ | |
| 63 | |
| 64 #ifdef emacs | |
| 65 #include <config.h> | |
| 66 #include "lisp.h" | |
| 67 #else | |
| 68 void *malloc (size_t); | |
| 69 #endif | |
| 70 | |
| 71 #if !defined(HAVE_LIBMCHECK) | |
| 72 #include <stdio.h> | |
| 73 | |
| 74 #include "hash.h" | |
| 75 | |
| 76 #ifdef UNMAPPED_FREE | |
| 77 #include <sys/mman.h> | |
| 78 #include <sys/param.h> | |
| 79 #define ROUND_UP_TO_PAGE(i) (((i) + PAGEOFFSET) & PAGEMASK) | |
| 80 #endif | |
| 81 | |
| 82 #include <sys/types.h> | |
| 83 | |
| 84 /* System function prototypes don't belong in C source files */ | |
| 85 /* extern void free (void *); */ | |
| 86 | |
| 87 static struct hash_table *pointer_table; | |
| 88 | |
| 89 extern void (*__free_hook) (void *); | |
| 90 extern void *(*__malloc_hook) (size_t); | |
| 91 | |
| 92 static void *check_malloc (size_t); | |
| 93 | |
| 94 typedef void (*fun_ptr) (void); | |
| 95 | |
| 96 /* free_queue is not too useful without backtrace logging */ | |
| 97 #define FREE_QUEUE_LIMIT 1 | |
| 98 #define TRACE_LIMIT 20 | |
| 99 | |
| 100 typedef struct { | |
| 101 fun_ptr return_pc; | |
| 102 #ifdef SAVE_ARGS | |
| 103 void *arg[3]; | |
| 104 #endif | |
| 105 } fun_entry; | |
| 106 | |
| 107 typedef struct { | |
| 108 void *address; | |
| 109 unsigned long length; | |
| 110 } free_queue_entry; | |
| 111 | |
| 112 static free_queue_entry free_queue[FREE_QUEUE_LIMIT]; | |
| 113 | |
| 114 static int current_free; | |
| 115 | |
| 116 static int strict_free_check; | |
| 117 | |
| 118 static void | |
| 119 check_free (void *ptr) | |
| 120 { | |
| 121 __free_hook = 0; | |
| 122 __malloc_hook = 0; | |
| 123 if (!pointer_table) | |
| 124 pointer_table = make_hash_table (max (100, FREE_QUEUE_LIMIT * 2)); | |
| 125 if (ptr != 0) | |
| 126 { | |
| 127 long size; | |
| 128 #ifdef UNMAPPED_FREE | |
| 129 unsigned long rounded_up_size; | |
| 130 #endif | |
| 131 | |
| 132 EMACS_INT present = (EMACS_INT) gethash (ptr, pointer_table, | |
| 2519 | 133 (const void **) |
| 134 (void *) &size); | |
| 428 | 135 |
| 136 if (!present) | |
| 137 { | |
| 138 /* This can only happen if you try to free something that didn't | |
| 139 come from malloc */ | |
| 140 #if !defined(__linux__) | |
| 141 /* I originally wrote: "There's really no need to drop core." | |
| 142 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
|
143 assert (!strict_free_check); |
| 428 | 144 #endif |
| 145 printf("Freeing unmalloc'ed memory at %p\n", ptr); | |
| 146 __free_hook = check_free; | |
| 147 __malloc_hook = check_malloc; | |
| 148 goto end; | |
| 149 } | |
| 150 | |
| 151 if (size < 0) | |
| 152 { | |
| 153 /* This happens when you free twice */ | |
| 154 #if !defined(__linux__) | |
| 155 /* See above comment. */ | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
3988
diff
changeset
|
156 assert (!strict_free_check); |
| 428 | 157 #endif |
| 158 printf("Freeing %p twice\n", ptr); | |
| 159 __free_hook = check_free; | |
| 160 __malloc_hook = check_malloc; | |
| 161 goto end; | |
| 162 } | |
| 163 | |
| 164 puthash (ptr, (void *)-size, pointer_table); | |
| 165 #ifdef UNMAPPED_FREE | |
| 166 /* Round up size to an even number of pages. */ | |
| 167 rounded_up_size = ROUND_UP_TO_PAGE (size); | |
| 168 /* Protect the pages freed from all access */ | |
| 169 if (strict_free_check) | |
| 170 mprotect (ptr, rounded_up_size, PROT_NONE); | |
| 171 #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
|
172 /* Set every word in the block to 0xDEADBEEF */ |
| 428 | 173 if (strict_free_check) |
| 174 { | |
| 175 unsigned long long_length = (size + (sizeof (long) - 1)) | |
| 176 / sizeof (long); | |
| 177 unsigned long i; | |
| 178 | |
| 3988 | 179 /* Not using the DEADBEEF_CONSTANT #define, since we don't know |
| 180 * that allocation sizes will be multiples of eight. */ | |
| 428 | 181 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
|
182 ((unsigned long *) ptr)[i] = 0xDEADBEEF; |
| 428 | 183 } |
| 184 #endif | |
| 185 free_queue[current_free].address = ptr; | |
| 186 free_queue[current_free].length = size; | |
| 187 | |
| 188 current_free++; | |
| 189 if (current_free >= FREE_QUEUE_LIMIT) | |
| 190 current_free = 0; | |
| 191 /* Really free this if there's something there */ | |
| 192 { | |
| 193 void *old = free_queue[current_free].address; | |
| 194 | |
| 195 if (old) | |
| 196 { | |
| 197 #ifdef UNMAPPED_FREE | |
| 198 unsigned long old_len = free_queue[current_free].length; | |
| 199 | |
| 200 mprotect (old, old_len, PROT_READ | PROT_WRITE | PROT_EXEC); | |
| 201 #endif | |
| 202 free (old); | |
| 203 remhash (old, pointer_table); | |
| 204 } | |
| 205 } | |
| 206 } | |
| 207 __free_hook = check_free; | |
| 208 __malloc_hook = check_malloc; | |
| 209 | |
| 210 end: | |
| 211 return; | |
| 212 } | |
| 213 | |
| 214 static void * | |
| 215 check_malloc (size_t size) | |
| 216 { | |
| 217 size_t rounded_up_size; | |
| 218 void *result; | |
| 219 | |
| 220 __free_hook = 0; | |
| 221 __malloc_hook = 0; | |
| 222 if (size == 0) | |
| 223 { | |
| 224 result = 0; | |
| 225 goto end; | |
| 226 } | |
| 227 #ifdef UNMAPPED_FREE | |
| 228 /* Round up to an even number of pages. */ | |
| 229 rounded_up_size = ROUND_UP_TO_PAGE (size); | |
| 230 #else | |
| 231 rounded_up_size = size; | |
| 232 #endif | |
| 233 result = malloc (rounded_up_size); | |
| 234 if (!pointer_table) | |
| 235 pointer_table = make_hash_table (FREE_QUEUE_LIMIT * 2); | |
| 236 puthash (result, (void *)size, pointer_table); | |
| 237 __free_hook = check_free; | |
| 238 __malloc_hook = check_malloc; | |
| 239 end: | |
| 240 return result; | |
| 241 } | |
| 242 | |
| 243 extern void *(*__realloc_hook) (void *, size_t); | |
| 244 | |
| 245 #ifdef MIN | |
| 246 #undef MIN | |
| 247 #endif | |
| 248 #define MIN(A, B) ((A) < (B) ? (A) : (B)) | |
| 249 | |
| 250 /* Don't optimize realloc */ | |
| 251 | |
| 252 static void * | |
| 253 check_realloc (void * ptr, size_t size) | |
| 254 { | |
| 255 EMACS_INT present; | |
| 256 size_t old_size; | |
| 257 void *result = malloc (size); | |
| 258 | |
| 259 if (!ptr) return result; | |
| 442 | 260 present = (EMACS_INT) gethash (ptr, pointer_table, (const void **) &old_size); |
| 428 | 261 if (!present) |
| 262 { | |
| 263 /* This can only happen by reallocing a pointer that didn't | |
| 264 come from malloc. */ | |
| 265 #if !defined(__linux__) | |
| 266 /* see comment in check_free(). */ | |
| 2500 | 267 ABORT (); |
| 428 | 268 #endif |
| 269 printf("Realloc'ing unmalloc'ed pointer at %p\n", ptr); | |
| 270 } | |
| 271 | |
| 272 if (result == 0) | |
| 273 goto end; | |
| 274 memcpy (result, ptr, MIN (size, old_size)); | |
| 275 free (ptr); | |
| 276 end: | |
| 277 return result; | |
| 278 } | |
| 279 | |
| 280 void enable_strict_free_check (void); | |
| 281 void | |
| 282 enable_strict_free_check (void) | |
| 283 { | |
| 284 strict_free_check = 1; | |
| 285 } | |
| 286 | |
| 287 void disable_strict_free_check (void); | |
| 288 void | |
| 289 disable_strict_free_check (void) | |
| 290 { | |
| 291 strict_free_check = 0; | |
| 292 } | |
| 293 | |
| 294 /* Note: All BLOCK_INPUT stuff removed from this file because it's | |
| 295 completely gone in XEmacs */ | |
| 296 | |
| 297 static void * | |
| 298 block_input_malloc (size_t size); | |
| 299 | |
| 300 static void | |
| 301 block_input_free (void* ptr) | |
| 302 { | |
| 303 __free_hook = 0; | |
| 304 __malloc_hook = 0; | |
| 305 free (ptr); | |
| 306 __free_hook = block_input_free; | |
| 307 __malloc_hook = block_input_malloc; | |
| 308 } | |
| 309 | |
| 310 static void * | |
| 311 block_input_malloc (size_t size) | |
| 312 { | |
| 313 void* result; | |
| 314 __free_hook = 0; | |
| 315 __malloc_hook = 0; | |
| 316 result = malloc (size); | |
| 317 __free_hook = block_input_free; | |
| 318 __malloc_hook = block_input_malloc; | |
| 319 return result; | |
| 320 } | |
| 321 | |
| 322 | |
| 323 static void * | |
| 324 block_input_realloc (void* ptr, size_t size) | |
| 325 { | |
| 326 void* result; | |
| 327 __free_hook = 0; | |
| 328 __malloc_hook = 0; | |
| 329 __realloc_hook = 0; | |
| 330 result = realloc (ptr, size); | |
| 331 __free_hook = block_input_free; | |
| 332 __malloc_hook = block_input_malloc; | |
| 333 __realloc_hook = block_input_realloc; | |
| 334 return result; | |
| 335 } | |
| 336 | |
| 337 #ifdef emacs | |
| 338 | |
| 339 void disable_free_hook (void); | |
| 340 void | |
| 341 disable_free_hook (void) | |
| 342 { | |
| 343 __free_hook = block_input_free; | |
| 344 __malloc_hook = block_input_malloc; | |
| 345 __realloc_hook = block_input_realloc; | |
| 346 } | |
| 347 | |
| 348 void | |
| 349 init_free_hook (void) | |
| 350 { | |
| 351 __free_hook = check_free; | |
| 352 __malloc_hook = check_malloc; | |
| 353 __realloc_hook = check_realloc; | |
| 354 current_free = 0; | |
| 355 strict_free_check = 1; | |
| 356 } | |
| 357 | |
| 358 void really_free_one_entry (void *, int, int *); | |
| 359 | |
| 360 DEFUN ("really-free", Freally_free, 0, 1, "P", /* | |
| 361 Actually free the storage held by the free() debug hook. | |
| 362 A no-op if the free hook is disabled. | |
| 363 */ | |
| 2286 | 364 (UNUSED (arg))) |
| 428 | 365 { |
| 366 int count[2]; | |
| 367 Lisp_Object lisp_count[2]; | |
| 368 | |
| 369 if ((__free_hook != 0) && pointer_table) | |
| 370 { | |
| 371 count[0] = 0; | |
| 372 count[1] = 0; | |
| 373 __free_hook = 0; | |
| 374 maphash ((maphash_function)really_free_one_entry, | |
| 375 pointer_table, (void *)&count); | |
| 376 memset (free_queue, 0, sizeof (free_queue_entry) * FREE_QUEUE_LIMIT); | |
| 377 current_free = 0; | |
| 378 __free_hook = check_free; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
379 lisp_count[0] = make_fixnum (count[0]); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
380 lisp_count[1] = make_fixnum (count[1]); |
| 428 | 381 return Fcons (lisp_count[0], lisp_count[1]); |
| 382 } | |
| 383 else | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5402
diff
changeset
|
384 return Fcons (make_fixnum (0), make_fixnum (0)); |
| 428 | 385 } |
| 386 | |
| 387 void | |
| 388 really_free_one_entry (void *key, int contents, int *countp) | |
| 389 { | |
| 390 if (contents < 0) | |
| 391 { | |
| 392 free (key); | |
| 393 #ifdef UNMAPPED_FREE | |
| 394 mprotect (key, -contents, PROT_READ | PROT_WRITE | PROT_EXEC); | |
| 395 #endif | |
| 396 remhash (key, pointer_table); | |
| 397 countp[0]++; | |
| 398 countp[1] += -contents; | |
| 399 } | |
| 400 } | |
| 401 | |
| 402 void | |
| 403 syms_of_free_hook (void) | |
| 404 { | |
| 405 DEFSUBR (Freally_free); | |
| 406 } | |
| 407 | |
| 408 #else | |
| 409 void (*__free_hook)(void *) = check_free; | |
| 410 void *(*__malloc_hook)(size_t) = check_malloc; | |
| 411 void *(*__realloc_hook)(void *, size_t) = check_realloc; | |
| 412 #endif | |
| 413 | |
| 414 #endif /* !defined(HAVE_LIBMCHECK) */ | |
| 415 | |
| 416 #if defined(DEBUG_INPUT_BLOCKING) || defined (DEBUG_GCPRO) | |
| 417 | |
| 418 /* Note: There is no more input blocking in XEmacs */ | |
| 419 typedef enum { | |
| 420 block_type, unblock_type, totally_type, | |
| 421 gcpro1_type, gcpro2_type, gcpro3_type, gcpro4_type, gcpro5_type, | |
| 422 ungcpro_type | |
| 423 } blocktype; | |
| 424 | |
| 425 struct block_input_history_struct | |
| 426 { | |
| 427 char *file; | |
| 428 int line; | |
| 429 blocktype type; | |
| 430 int value; | |
| 431 }; | |
| 432 | |
| 433 typedef struct block_input_history_struct block_input_history; | |
| 434 | |
| 435 #endif /* DEBUG_INPUT_BLOCKING || DEBUG_GCPRO */ | |
| 436 | |
| 437 #ifdef DEBUG_INPUT_BLOCKING | |
| 438 | |
| 439 int blhistptr; | |
| 440 | |
| 441 #define BLHISTLIMIT 1000 | |
| 442 | |
| 443 block_input_history blhist[BLHISTLIMIT]; | |
| 444 | |
| 445 note_block_input (char *file, int line) | |
| 446 { | |
| 447 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
|
448 assert (interrupt_input_blocked <= 2); |
| 428 | 449 } |
| 450 | |
| 451 note_unblock_input (char* file, int line) | |
| 452 { | |
| 453 note_block (file, line, unblock_type); | |
| 454 } | |
| 455 | |
| 456 note_totally_unblocked (char* file, int line) | |
| 457 { | |
| 458 note_block (file, line, totally_type); | |
| 459 } | |
| 460 | |
| 461 note_block (char *file, int line, blocktype type) | |
| 462 { | |
| 463 blhist[blhistptr].file = file; | |
| 464 blhist[blhistptr].line = line; | |
| 465 blhist[blhistptr].type = type; | |
| 466 blhist[blhistptr].value = interrupt_input_blocked; | |
| 467 | |
| 468 blhistptr++; | |
| 469 if (blhistptr >= BLHISTLIMIT) | |
| 470 blhistptr = 0; | |
| 471 } | |
| 472 | |
| 473 #endif /* DEBUG_INPUT_BLOCKING */ | |
| 474 | |
| 475 | |
| 476 #ifdef DEBUG_GCPRO | |
| 477 | |
| 478 int gcprohistptr; | |
| 479 #define GCPROHISTLIMIT 1000 | |
| 480 block_input_history gcprohist[GCPROHISTLIMIT]; | |
| 481 | |
| 482 static void | |
| 483 log_gcpro (char *file, int line, struct gcpro *value, blocktype type) | |
| 484 { | |
| 485 if (type == ungcpro_type) | |
| 486 { | |
| 487 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
|
488 assert (gcprolist); |
| 428 | 489 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
|
490 assert (gcprolist->next); |
| 428 | 491 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
|
492 assert (gcprolist->next->next); |
| 428 | 493 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
|
494 assert (gcprolist->next->next->next); |
| 446 | 495 if (value == gcprolist->next->next->next->next) goto OK; |
| 2500 | 496 ABORT (); |
| 428 | 497 OK:; |
| 498 } | |
| 499 gcprohist[gcprohistptr].file = file; | |
| 500 gcprohist[gcprohistptr].line = line; | |
| 501 gcprohist[gcprohistptr].type = type; | |
| 502 gcprohist[gcprohistptr].value = (int) value; | |
| 503 gcprohistptr++; | |
| 504 if (gcprohistptr >= GCPROHISTLIMIT) | |
| 505 gcprohistptr = 0; | |
| 506 } | |
| 507 | |
| 508 void | |
| 509 debug_gcpro1 (char *file, int line, struct gcpro *gcpro1, Lisp_Object *var) | |
| 510 { | |
| 511 gcpro1->next = gcprolist; gcpro1->var = var; gcpro1->nvars = 1; | |
| 512 gcprolist = gcpro1; | |
| 513 log_gcpro (file, line, gcpro1, gcpro1_type); | |
| 514 } | |
| 515 | |
| 516 void | |
| 517 debug_gcpro2 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 518 Lisp_Object *var1, Lisp_Object *var2) | |
| 519 { | |
| 520 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 521 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 522 gcprolist = gcpro2; | |
| 523 log_gcpro (file, line, gcpro2, gcpro2_type); | |
| 524 } | |
| 525 | |
| 526 void | |
| 527 debug_gcpro3 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 528 struct gcpro *gcpro3, Lisp_Object *var1, Lisp_Object *var2, | |
| 529 Lisp_Object *var3) | |
| 530 { | |
| 531 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 532 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 533 gcpro3->next = gcpro2; gcpro3->var = var3; gcpro3->nvars = 1; | |
| 534 gcprolist = gcpro3; | |
| 535 log_gcpro (file, line, gcpro3, gcpro3_type); | |
| 536 } | |
| 537 | |
| 538 void | |
| 539 debug_gcpro4 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 540 struct gcpro *gcpro3, struct gcpro *gcpro4, Lisp_Object *var1, | |
| 541 Lisp_Object *var2, Lisp_Object *var3, Lisp_Object *var4) | |
| 542 { | |
| 543 log_gcpro (file, line, gcpro4, gcpro4_type); | |
| 544 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 545 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 546 gcpro3->next = gcpro2; gcpro3->var = var3; gcpro3->nvars = 1; | |
| 547 gcpro4->next = gcpro3; gcpro4->var = var4; gcpro4->nvars = 1; | |
| 548 gcprolist = gcpro4; | |
| 549 } | |
| 550 | |
| 551 void | |
| 552 debug_gcpro5 (char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2, | |
| 553 struct gcpro *gcpro3, struct gcpro *gcpro4, struct gcpro *gcpro5, | |
| 554 Lisp_Object *var1, Lisp_Object *var2, Lisp_Object *var3, | |
| 555 Lisp_Object *var4, Lisp_Object *var5) | |
| 556 { | |
| 557 log_gcpro (file, line, gcpro5, gcpro5_type); | |
| 558 gcpro1->next = gcprolist; gcpro1->var = var1; gcpro1->nvars = 1; | |
| 559 gcpro2->next = gcpro1; gcpro2->var = var2; gcpro2->nvars = 1; | |
| 560 gcpro3->next = gcpro2; gcpro3->var = var3; gcpro3->nvars = 1; | |
| 561 gcpro4->next = gcpro3; gcpro4->var = var4; gcpro4->nvars = 1; | |
| 562 gcpro5->next = gcpro4; gcpro5->var = var5; gcpro5->nvars = 1; | |
| 563 gcprolist = gcpro5; | |
| 564 } | |
| 565 | |
| 566 void | |
| 567 debug_ungcpro (char *file, int line, struct gcpro *gcpro1) | |
| 568 { | |
| 569 log_gcpro (file, line, gcpro1, ungcpro_type); | |
| 570 gcprolist = gcpro1->next; | |
| 571 } | |
| 572 | |
| 573 | |
| 574 /* To be called from the debugger */ | |
| 575 void show_gcprohist (void); | |
| 576 void | |
| 577 show_gcprohist (void) | |
| 578 { | |
| 579 int i, j; | |
| 580 for (i = 0, j = gcprohistptr; | |
| 581 i < GCPROHISTLIMIT; | |
| 582 i++, j++) | |
| 583 { | |
| 584 if (j >= GCPROHISTLIMIT) | |
| 585 j = 0; | |
| 586 printf ("%3d %s %d %s 0x%x\n", | |
| 587 j, gcprohist[j].file, gcprohist[j].line, | |
| 588 (gcprohist[j].type == gcpro1_type ? "GCPRO1" : | |
| 589 gcprohist[j].type == gcpro2_type ? "GCPRO2" : | |
| 590 gcprohist[j].type == gcpro3_type ? "GCPRO3" : | |
| 591 gcprohist[j].type == gcpro4_type ? "GCPRO4" : | |
| 446 | 592 gcprohist[j].type == gcpro5_type ? "GCPRO5" : |
| 428 | 593 gcprohist[j].type == ungcpro_type ? "UNGCPRO" : "???"), |
| 594 gcprohist[j].value); | |
| 595 } | |
| 596 fflush (stdout); | |
| 597 } | |
| 598 | |
| 599 #endif /* DEBUG_GCPRO */ |