cgit.sxemacs.org Git - sxemacs/blob - src/mem/free-hook.c

   1 /*
   2 This file is part of SXEmacs
   3
   4 SXEmacs is free software: you can redistribute it and/or modify
   5 it under the terms of the GNU General Public License as published by
   6 the Free Software Foundation, either version 3 of the License, or
   7 (at your option) any later version.
   8
   9 SXEmacs is distributed in the hope that it will be useful,
  10 but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 GNU General Public License for more details.
  13
  14 You should have received a copy of the GNU General Public License
  15 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  16
  17
  18 /* Synched up with: Not in FSF. */
  19
  20 /* Debugging hooks for malloc. */
  21
  22 /* These hooks work with gmalloc to catch allocation errors.
  23    In particular, the following is trapped:
  24
  25    * Freeing the same pointer twice.
  26    * Trying to free a pointer not returned by malloc.
  27    * Trying to realloc a pointer not returned by malloc.
  28
  29    In addition, every word of every block freed is set to
  30    0xdeadbeef.  This causes many uses of freed storage to be
  31    trapped or recognized.
  32
  33    When you use this, the storage used by the last FREE_QUEUE_LIMIT
  34    calls to free() is not recycled.  When you call free for the Nth
  35    time, the (N - FREE_QUEUE_LIMIT)'th block is actually recycled.
  36
  37    For these last FREE_QUEUE_LIMIT calls to free() a backtrace is
  38    saved showing where it was called from.  The function
  39    find_backtrace() is provided here to be called from GDB with a
  40    pointer (such as would be passed to free()) as argument, e.g.
  41    (gdb) p/a *find_backtrace (0x234000).  If SAVE_ARGS is defined,
  42    the first three arguments to each function are saved as well as the
  43    return addresses.
  44
  45    If UNMAPPED_FREE is defined, instead of setting every word of freed
  46    storage to 0xdeadbeef, every call to malloc goes on its own page(s).
  47    When free() is called, the block is read and write protected.  This
  48    is very useful when debugging, since it usually generates a bus error
  49    when the deadbeef hack might only cause some garbage to be printed.
  50    However, this is too slow for everyday use, since it takes an enormous
  51    number of pages.
  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 check_free(void *ptr)
 119 {
 120         __free_hook = 0;
 121         __malloc_hook = 0;
 122         if (!pointer_table)
 123                 pointer_table = make_hash_table(max(100, FREE_QUEUE_LIMIT * 2));
 124         if (ptr != 0) {
 125                 long size;
 126 #ifdef UNMAPPED_FREE
 127                 unsigned long rounded_up_size;
 128 #endif
 129
 130                 EMACS_INT present =
 131                         (EMACS_INT)gethash(ptr, pointer_table,
 132                                            (const void **)((void*)&size));
 133
 134                 if (!present) {
 135                         /* This can only happen if you try to free something that didn't
 136                            come from malloc */
 137 #if !defined(__linux__)
 138                         /* I originally wrote:  "There's really no need to drop core."
 139                            I have seen the error of my ways. -slb */
 140                         if (strict_free_check)
 141                                 abort();
 142 #endif
 143                         printf("Freeing unmalloc'ed memory at %p\n", ptr);
 144                         __free_hook = check_free;
 145                         __malloc_hook = check_malloc;
 146                         goto end;
 147                 }
 148
 149                 if (size < 0) {
 150                         /* This happens when you free twice */
 151 #if !defined(__linux__)
 152                         /* See above comment. */
 153                         if (strict_free_check)
 154                                 abort();
 155 #endif
 156                         printf("Freeing %p twice\n", ptr);
 157                         __free_hook = check_free;
 158                         __malloc_hook = check_malloc;
 159                         goto end;
 160                 }
 161
 162                 puthash(ptr, (void *)-size, pointer_table);
 163 #ifdef UNMAPPED_FREE
 164                 /* Round up size to an even number of pages. */
 165                 rounded_up_size = ROUND_UP_TO_PAGE(size);
 166                 /* Protect the pages freed from all access */
 167                 if (strict_free_check)
 168                         mprotect(ptr, rounded_up_size, PROT_NONE);
 169 #else
 170                 /* Set every word in the block to 0xdeadbeef */
 171                 if (strict_free_check) {
 172                         unsigned long long_length = (size + (sizeof(long) - 1))
 173                             / sizeof(long);
 174                         unsigned long i;
 175
 176                         for (i = 0; i < long_length; i++)
 177                                 ((unsigned long *)ptr)[i] = 0xdeadbeef;
 178                 }
 179 #endif
 180                 free_queue[current_free].address = ptr;
 181                 free_queue[current_free].length = size;
 182
 183                 current_free++;
 184                 if (current_free >= FREE_QUEUE_LIMIT)
 185                         current_free = 0;
 186                 /* Really free this if there's something there */
 187                 {
 188                         void *old = free_queue[current_free].address;
 189
 190                         if (old) {
 191 #ifdef UNMAPPED_FREE
 192                                 unsigned long old_len =
 193                                     free_queue[current_free].length;
 194
 195                                 mprotect(old, old_len,
 196                                          PROT_READ | PROT_WRITE | PROT_EXEC);
 197 #endif
 198                                 free(old);
 199                                 remhash(old, pointer_table);
 200                         }
 201                 }
 202         }
 203         __free_hook = check_free;
 204         __malloc_hook = check_malloc;
 205
 206       end:
 207         return;
 208 }
 209
 210 static void *check_malloc(size_t size)
 211 {
 212         size_t rounded_up_size;
 213         void *result;
 214
 215         __free_hook = 0;
 216         __malloc_hook = 0;
 217         if (size == 0) {
 218                 result = 0;
 219                 goto end;
 220         }
 221 #ifdef UNMAPPED_FREE
 222         /* Round up to an even number of pages. */
 223         rounded_up_size = ROUND_UP_TO_PAGE(size);
 224 #else
 225         rounded_up_size = size;
 226 #endif
 227         result = malloc(rounded_up_size);
 228         if (!pointer_table)
 229                 pointer_table = make_hash_table(FREE_QUEUE_LIMIT * 2);
 230         puthash(result, (void *)size, pointer_table);
 231         __free_hook = check_free;
 232         __malloc_hook = check_malloc;
 233       end:
 234         return result;
 235 }
 236
 237 extern void *(*__realloc_hook) (void *, size_t);
 238
 239 #ifdef MIN
 240 #undef MIN
 241 #endif
 242 #define MIN(A, B) ((A) < (B) ? (A) : (B))
 243
 244 /* Don't optimize realloc */
 245
 246 static void *check_realloc(void *ptr, size_t size)
 247 {
 248         EMACS_INT present;
 249         size_t old_size;
 250         void *result = malloc(size);
 251
 252         if (!ptr)
 253                 return result;
 254         present =
 255                 (EMACS_INT)gethash(ptr, pointer_table,
 256                                    (const void **)((void*)&old_size));
 257         if (!present) {
 258                 /* This can only happen by reallocing a pointer that didn't
 259                    come from malloc. */
 260 #if !defined(__linux__)
 261                 /* see comment in check_free(). */
 262                 abort();
 263 #endif
 264                 printf("Realloc'ing unmalloc'ed pointer at %p\n", ptr);
 265         }
 266
 267         if (result == 0)
 268                 goto end;
 269         memcpy(result, ptr, MIN(size, old_size));
 270         free(ptr);
 271       end:
 272         return result;
 273 }
 274
 275 void enable_strict_free_check(void);
 276 void enable_strict_free_check(void)
 277 {
 278         strict_free_check = 1;
 279 }
 280
 281 void disable_strict_free_check(void);
 282 void disable_strict_free_check(void)
 283 {
 284         strict_free_check = 0;
 285 }
 286
 287 /* Note: All BLOCK_INPUT stuff removed from this file because it's
 288    completely gone in XEmacs */
 289
 290 static void *block_input_malloc(size_t size);
 291
 292 static void block_input_free(void *ptr)
 293 {
 294         __free_hook = 0;
 295         __malloc_hook = 0;
 296         free(ptr);
 297         __free_hook = block_input_free;
 298         __malloc_hook = block_input_malloc;
 299 }
 300
 301 static void *block_input_malloc(size_t size)
 302 {
 303         void *result;
 304         __free_hook = 0;
 305         __malloc_hook = 0;
 306         result = malloc(size);
 307         __free_hook = block_input_free;
 308         __malloc_hook = block_input_malloc;
 309         return result;
 310 }
 311
 312 static void *block_input_realloc(void *ptr, size_t size)
 313 {
 314         void *result;
 315         __free_hook = 0;
 316         __malloc_hook = 0;
 317         __realloc_hook = 0;
 318         result = realloc(ptr, size);
 319         __free_hook = block_input_free;
 320         __malloc_hook = block_input_malloc;
 321         __realloc_hook = block_input_realloc;
 322         return result;
 323 }
 324
 325 #ifdef emacs
 326
 327 void disable_free_hook(void);
 328 void disable_free_hook(void)
 329 {
 330         __free_hook = block_input_free;
 331         __malloc_hook = block_input_malloc;
 332         __realloc_hook = block_input_realloc;
 333 }
 334
 335 void init_free_hook(void)
 336 {
 337         __free_hook = check_free;
 338         __malloc_hook = check_malloc;
 339         __realloc_hook = check_realloc;
 340         current_free = 0;
 341         strict_free_check = 1;
 342 }
 343
 344 void really_free_one_entry(void *, int, int *);
 345
 346 DEFUN("really-free", Freally_free, 0, 1, "P",   /*
 347 Actually free the storage held by the free() debug hook.
 348 A no-op if the free hook is disabled.
 349 */
 350       (arg))
 351 {
 352         int count[2];
 353         Lisp_Object lisp_count[2];
 354
 355         if ((__free_hook != 0) && pointer_table) {
 356                 count[0] = 0;
 357                 count[1] = 0;
 358                 __free_hook = 0;
 359                 maphash((maphash_function) really_free_one_entry,
 360                         pointer_table, (void *)&count);
 361                 memset(free_queue, 0,
 362                        sizeof(free_queue_entry) * FREE_QUEUE_LIMIT);
 363                 current_free = 0;
 364                 __free_hook = check_free;
 365                 XSETINT(lisp_count[0], count[0]);
 366                 XSETINT(lisp_count[1], count[1]);
 367                 return Fcons(lisp_count[0], lisp_count[1]);
 368         } else
 369                 return Fcons(make_int(0), make_int(0));
 370 }
 371
 372 void really_free_one_entry(void *key, int contents, int *countp)
 373 {
 374         if (contents < 0) {
 375                 free(key);
 376 #ifdef UNMAPPED_FREE
 377                 mprotect(key, -contents, PROT_READ | PROT_WRITE | PROT_EXEC);
 378 #endif
 379                 remhash(key, pointer_table);
 380                 countp[0]++;
 381                 countp[1] += -contents;
 382         }
 383 }
 384
 385 void syms_of_free_hook(void)
 386 {
 387         DEFSUBR(Freally_free);
 388 }
 389
 390 #else
 391 void (*__free_hook) (void *) = check_free;
 392 void *(*__malloc_hook) (size_t) = check_malloc;
 393 void *(*__realloc_hook) (void *, size_t) = check_realloc;
 394 #endif
 395
 396 #endif                          /* !defined(HAVE_LIBMCHECK) */
 397
 398 #if defined(DEBUG_INPUT_BLOCKING) || defined (DEBUG_GCPRO)
 399
 400 /* Note: There is no more input blocking in XEmacs */
 401 typedef enum {
 402         block_type, unblock_type, totally_type,
 403         gcpro1_type, gcpro2_type, gcpro3_type, gcpro4_type, gcpro5_type,
 404         ungcpro_type
 405 } blocktype;
 406
 407 struct block_input_history_struct {
 408         char *file;
 409         int line;
 410         blocktype type;
 411         int value;
 412 };
 413
 414 typedef struct block_input_history_struct block_input_history;
 415
 416 #endif                          /* DEBUG_INPUT_BLOCKING || DEBUG_GCPRO */
 417
 418 #ifdef DEBUG_INPUT_BLOCKING
 419
 420 int blhistptr;
 421
 422 #define BLHISTLIMIT 1000
 423
 424 block_input_history blhist[BLHISTLIMIT];
 425
 426 note_block_input(char *file, int line)
 427 {
 428         note_block(file, line, block_type);
 429         if (interrupt_input_blocked > 2)
 430                 abort();
 431 }
 432
 433 note_unblock_input(char *file, int line)
 434 {
 435         note_block(file, line, unblock_type);
 436 }
 437
 438 note_totally_unblocked(char *file, int line)
 439 {
 440         note_block(file, line, totally_type);
 441 }
 442
 443 note_block(char *file, int line, blocktype type)
 444 {
 445         blhist[blhistptr].file = file;
 446         blhist[blhistptr].line = line;
 447         blhist[blhistptr].type = type;
 448         blhist[blhistptr].value = interrupt_input_blocked;
 449
 450         blhistptr++;
 451         if (blhistptr >= BLHISTLIMIT)
 452                 blhistptr = 0;
 453 }
 454
 455 #endif                          /* DEBUG_INPUT_BLOCKING */
 456 \f
 457 #ifdef DEBUG_GCPRO
 458
 459 int gcprohistptr;
 460 #define GCPROHISTLIMIT 1000
 461 block_input_history gcprohist[GCPROHISTLIMIT];
 462
 463 static void log_gcpro(char *file, int line, struct gcpro *value, blocktype type)
 464 {
 465         if (type == ungcpro_type) {
 466                 if (value == gcprolist)
 467                         goto OK;
 468                 if (!gcprolist)
 469                         abort();
 470                 if (value == gcprolist->next)
 471                         goto OK;
 472                 if (!gcprolist->next)
 473                         abort();
 474                 if (value == gcprolist->next->next)
 475                         goto OK;
 476                 if (!gcprolist->next->next)
 477                         abort();
 478                 if (value == gcprolist->next->next->next)
 479                         goto OK;
 480                 if (!gcprolist->next->next->next)
 481                         abort();
 482                 if (value == gcprolist->next->next->next->next)
 483                         goto OK;
 484                 abort();
 485               OK:;
 486         }
 487         gcprohist[gcprohistptr].file = file;
 488         gcprohist[gcprohistptr].line = line;
 489         gcprohist[gcprohistptr].type = type;
 490         gcprohist[gcprohistptr].value = (int)value;
 491         gcprohistptr++;
 492         if (gcprohistptr >= GCPROHISTLIMIT)
 493                 gcprohistptr = 0;
 494 }
 495
 496 void debug_gcpro1(char *file, int line, struct gcpro *gcpro1, Lisp_Object * var)
 497 {
 498         gcpro1->next = gcprolist;
 499         gcpro1->var = var;
 500         gcpro1->nvars = 1;
 501         gcprolist = gcpro1;
 502         log_gcpro(file, line, gcpro1, gcpro1_type);
 503 }
 504
 505 void
 506 debug_gcpro2(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 507              Lisp_Object * var1, Lisp_Object * var2)
 508 {
 509         gcpro1->next = gcprolist;
 510         gcpro1->var = var1;
 511         gcpro1->nvars = 1;
 512         gcpro2->next = gcpro1;
 513         gcpro2->var = var2;
 514         gcpro2->nvars = 1;
 515         gcprolist = gcpro2;
 516         log_gcpro(file, line, gcpro2, gcpro2_type);
 517 }
 518
 519 void
 520 debug_gcpro3(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 521              struct gcpro *gcpro3, Lisp_Object * var1, Lisp_Object * var2,
 522              Lisp_Object * var3)
 523 {
 524         gcpro1->next = gcprolist;
 525         gcpro1->var = var1;
 526         gcpro1->nvars = 1;
 527         gcpro2->next = gcpro1;
 528         gcpro2->var = var2;
 529         gcpro2->nvars = 1;
 530         gcpro3->next = gcpro2;
 531         gcpro3->var = var3;
 532         gcpro3->nvars = 1;
 533         gcprolist = gcpro3;
 534         log_gcpro(file, line, gcpro3, gcpro3_type);
 535 }
 536
 537 void
 538 debug_gcpro4(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 539              struct gcpro *gcpro3, struct gcpro *gcpro4, Lisp_Object * var1,
 540              Lisp_Object * var2, Lisp_Object * var3, Lisp_Object * var4)
 541 {
 542         log_gcpro(file, line, gcpro4, gcpro4_type);
 543         gcpro1->next = gcprolist;
 544         gcpro1->var = var1;
 545         gcpro1->nvars = 1;
 546         gcpro2->next = gcpro1;
 547         gcpro2->var = var2;
 548         gcpro2->nvars = 1;
 549         gcpro3->next = gcpro2;
 550         gcpro3->var = var3;
 551         gcpro3->nvars = 1;
 552         gcpro4->next = gcpro3;
 553         gcpro4->var = var4;
 554         gcpro4->nvars = 1;
 555         gcprolist = gcpro4;
 556 }
 557
 558 void
 559 debug_gcpro5(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 560              struct gcpro *gcpro3, struct gcpro *gcpro4, struct gcpro *gcpro5,
 561              Lisp_Object * var1, Lisp_Object * var2, Lisp_Object * var3,
 562              Lisp_Object * var4, Lisp_Object * var5)
 563 {
 564         log_gcpro(file, line, gcpro5, gcpro5_type);
 565         gcpro1->next = gcprolist;
 566         gcpro1->var = var1;
 567         gcpro1->nvars = 1;
 568         gcpro2->next = gcpro1;
 569         gcpro2->var = var2;
 570         gcpro2->nvars = 1;
 571         gcpro3->next = gcpro2;
 572         gcpro3->var = var3;
 573         gcpro3->nvars = 1;
 574         gcpro4->next = gcpro3;
 575         gcpro4->var = var4;
 576         gcpro4->nvars = 1;
 577         gcpro5->next = gcpro4;
 578         gcpro5->var = var5;
 579         gcpro5->nvars = 1;
 580         gcprolist = gcpro5;
 581 }
 582
 583 void
 584 debug_gcpro6(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 585              struct gcpro *gcpro3, struct gcpro *gcpro4, struct gcpro *gcpro5,
 586              struct gcpro *gcpro6,
 587              Lisp_Object * var1, Lisp_Object * var2, Lisp_Object * var3,
 588              Lisp_Object * var4, Lisp_Object * var5, Lisp_Object * var6)
 589 {
 590         log_gcpro(file, line, gcpro5, gcpro5_type);
 591         gcpro1->next = gcprolist;
 592         gcpro1->var = var1;
 593         gcpro1->nvars = 1;
 594         gcpro2->next = gcpro1;
 595         gcpro2->var = var2;
 596         gcpro2->nvars = 1;
 597         gcpro3->next = gcpro2;
 598         gcpro3->var = var3;
 599         gcpro3->nvars = 1;
 600         gcpro4->next = gcpro3;
 601         gcpro4->var = var4;
 602         gcpro4->nvars = 1;
 603         gcpro5->next = gcpro4;
 604         gcpro5->var = var5;
 605         gcpro5->nvars = 1;
 606         gcpro6->next = gcpro5;
 607         gcpro6->var = var5;
 608         gcpro6->nvars = 1;
 609         gcprolist = gcpro6;
 610 }
 611
 612 void
 613 debug_gcpro7(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 614              struct gcpro *gcpro3, struct gcpro *gcpro4, struct gcpro *gcpro5,
 615              struct gcpro *gcpro6, struct gcpro *gcpro7,
 616              Lisp_Object * var1, Lisp_Object * var2, Lisp_Object * var3,
 617              Lisp_Object * var4, Lisp_Object * var5, Lisp_Object * var6,
 618              Lisp_Object * var7)
 619 {
 620         log_gcpro(file, line, gcpro5, gcpro5_type);
 621         gcpro1->next = gcprolist;
 622         gcpro1->var = var1;
 623         gcpro1->nvars = 1;
 624         gcpro2->next = gcpro1;
 625         gcpro2->var = var2;
 626         gcpro2->nvars = 1;
 627         gcpro3->next = gcpro2;
 628         gcpro3->var = var3;
 629         gcpro3->nvars = 1;
 630         gcpro4->next = gcpro3;
 631         gcpro4->var = var4;
 632         gcpro4->nvars = 1;
 633         gcpro5->next = gcpro4;
 634         gcpro5->var = var5;
 635         gcpro5->nvars = 1;
 636         gcpro6->next = gcpro5;
 637         gcpro6->var = var5;
 638         gcpro6->nvars = 1;
 639         gcpro7->next = gcpro6;
 640         gcpro7->var = var5;
 641         gcpro7->nvars = 1;
 642         gcprolist = gcpro7;
 643 }
 644
 645 void
 646 debug_gcpro8(char *file, int line, struct gcpro *gcpro1, struct gcpro *gcpro2,
 647              struct gcpro *gcpro3, struct gcpro *gcpro4, struct gcpro *gcpro5,
 648              struct gcpro *gcpro6, struct gcpro *gcpro7, struct gcpro *gcpro8,
 649              Lisp_Object * var1, Lisp_Object * var2, Lisp_Object * var3,
 650              Lisp_Object * var4, Lisp_Object * var5, Lisp_Object * var6,
 651              Lisp_Object * var7, Lisp_Object * var8)
 652 {
 653         log_gcpro(file, line, gcpro5, gcpro5_type);
 654         gcpro1->next = gcprolist;
 655         gcpro1->var = var1;
 656         gcpro1->nvars = 1;
 657         gcpro2->next = gcpro1;
 658         gcpro2->var = var2;
 659         gcpro2->nvars = 1;
 660         gcpro3->next = gcpro2;
 661         gcpro3->var = var3;
 662         gcpro3->nvars = 1;
 663         gcpro4->next = gcpro3;
 664         gcpro4->var = var4;
 665         gcpro4->nvars = 1;
 666         gcpro5->next = gcpro4;
 667         gcpro5->var = var5;
 668         gcpro5->nvars = 1;
 669         gcpro6->next = gcpro5;
 670         gcpro6->var = var5;
 671         gcpro6->nvars = 1;
 672         gcpro7->next = gcpro6;
 673         gcpro7->var = var5;
 674         gcpro7->nvars = 1;
 675         gcpro8->next = gcpro7;
 676         gcpro8->var = var5;
 677         gcpro8->nvars = 1;
 678         gcprolist = gcpro8;
 679 }
 680
 681 void debug_ungcpro(char *file, int line, struct gcpro *gcpro1)
 682 {
 683         log_gcpro(file, line, gcpro1, ungcpro_type);
 684         gcprolist = gcpro1->next;
 685 }
 686
 687 /* To be called from the debugger */
 688 void show_gcprohist(void);
 689 void show_gcprohist(void)
 690 {
 691         int i, j;
 692         for (i = 0, j = gcprohistptr; i < GCPROHISTLIMIT; i++, j++) {
 693                 if (j >= GCPROHISTLIMIT)
 694                         j = 0;
 695                 printf("%3d  %s         %d      %s      0x%x\n",
 696                        j, gcprohist[j].file, gcprohist[j].line,
 697                        (gcprohist[j].type ==
 698                         gcpro1_type ? "GCPRO1" : gcprohist[j].
 699                         type ==
 700                         gcpro2_type ? "GCPRO2" : gcprohist[j].
 701                         type ==
 702                         gcpro3_type ? "GCPRO3" : gcprohist[j].
 703                         type ==
 704                         gcpro4_type ? "GCPRO4" : gcprohist[j].
 705                         type ==
 706                         gcpro5_type ? "GCPRO5" : gcprohist[j].
 707                         type ==
 708                         ungcpro_type ? "UNGCPRO" : "???"), gcprohist[j].value);
 709         }
 710         fflush(stdout);
 711 }
 712
 713 #endif                          /* DEBUG_GCPRO */