dbg_mlc.c

   1 /*
   2  * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers
   3  * Copyright (c) 1991-1995 by Xerox Corporation.  All rights reserved.
   4  * Copyright (c) 1997 by Silicon Graphics.  All rights reserved.
   5  * Copyright (c) 1999-2000 by Hewlett-Packard Company.  All rights reserved.
   6  *
   7  * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
   8  * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
   9  *
  10  * Permission is hereby granted to use or copy this program
  11  * for any purpose,  provided the above notices are retained on all copies.
  12  * Permission to modify the code and to distribute modified code is granted,
  13  * provided the above notices are retained, and a notice that the code was
  14  * modified is included with the above copyright notice.
  15  */
  16
  17 #include "private/dbg_mlc.h"
  18
  19 void GC_default_print_heap_obj_proc();
  20 GC_API void GC_register_finalizer_no_order
  21         GC_PROTO((GC_PTR obj, GC_finalization_proc fn, GC_PTR cd,
  22                   GC_finalization_proc *ofn, GC_PTR *ocd));
  23
  24
  25 #ifndef SHORT_DBG_HDRS
  26 /* Check whether object with base pointer p has debugging info  */
  27 /* p is assumed to point to a legitimate object in our part     */
  28 /* of the heap.                                                 */
  29 /* This excludes the check as to whether the back pointer is    */
  30 /* odd, which is added by the GC_HAS_DEBUG_INFO macro.          */
  31 /* Note that if DBG_HDRS_ALL is set, uncollectable objects      */
  32 /* on free lists may not have debug information set.  Thus it's */
  33 /* not always safe to return TRUE, even if the client does      */
  34 /* its part.                                                    */
  35 GC_bool GC_has_other_debug_info(p)
  36 ptr_t p;
  37 {
  38     register oh * ohdr = (oh *)p;
  39     register ptr_t body = (ptr_t)(ohdr + 1);
  40     register word sz = GC_size((ptr_t) ohdr);
  41
  42     if (HBLKPTR((ptr_t)ohdr) != HBLKPTR((ptr_t)body)
  43         || sz < DEBUG_BYTES + EXTRA_BYTES) {
  44         return(FALSE);
  45     }
  46     if (ohdr -> oh_sz == sz) {
  47         /* Object may have had debug info, but has been deallocated     */
  48         return(FALSE);
  49     }
  50     if (ohdr -> oh_sf == (START_FLAG ^ (word)body)) return(TRUE);
  51     if (((word *)ohdr)[BYTES_TO_WORDS(sz)-1] == (END_FLAG ^ (word)body)) {
  52         return(TRUE);
  53     }
  54     return(FALSE);
  55 }
  56 #endif
  57
  58 #ifdef KEEP_BACK_PTRS
  59
  60 # include <stdlib.h>
  61
  62 # if defined(LINUX) || defined(SUNOS4) || defined(SUNOS5) \
  63      || defined(HPUX) || defined(IRIX) || defined(OSF1)
  64 #   define RANDOM() random()
  65 # else
  66 #   define RANDOM() (long)rand()
  67 # endif
  68
  69   /* Store back pointer to source in dest, if that appears to be possible. */
  70   /* This is not completely safe, since we may mistakenly conclude that    */
  71   /* dest has a debugging wrapper.  But the error probability is very      */
  72   /* small, and this shouldn't be used in production code.                 */
  73   /* We assume that dest is the real base pointer.  Source will usually    */
  74   /* be a pointer to the interior of an object.                            */
  75   void GC_store_back_pointer(ptr_t source, ptr_t dest)
  76   {
  77     if (GC_HAS_DEBUG_INFO(dest)) {
  78       ((oh *)dest) -> oh_back_ptr = HIDE_BACK_PTR(source);
  79     }
  80   }
  81
  82   void GC_marked_for_finalization(ptr_t dest) {
  83     GC_store_back_pointer(MARKED_FOR_FINALIZATION, dest);
  84   }
  85
  86   /* Store information about the object referencing dest in *base_p     */
  87   /* and *offset_p.                                                     */
  88   /*   source is root ==> *base_p = address, *offset_p = 0              */
  89   /*   source is heap object ==> *base_p != 0, *offset_p = offset       */
  90   /*   Returns 1 on success, 0 if source couldn't be determined.        */
  91   /* Dest can be any address within a heap object.                      */
  92   GC_ref_kind GC_get_back_ptr_info(void *dest, void **base_p, size_t *offset_p)
  93   {
  94     oh * hdr = (oh *)GC_base(dest);
  95     ptr_t bp;
  96     ptr_t bp_base;
  97     if (!GC_HAS_DEBUG_INFO((ptr_t) hdr)) return GC_NO_SPACE;
  98     bp = REVEAL_POINTER(hdr -> oh_back_ptr);
  99     if (MARKED_FOR_FINALIZATION == bp) return GC_FINALIZER_REFD;
 100     if (MARKED_FROM_REGISTER == bp) return GC_REFD_FROM_REG;
 101     if (NOT_MARKED == bp) return GC_UNREFERENCED;
 102 #   if ALIGNMENT == 1
 103       /* Heuristically try to fix off by 1 errors we introduced by      */
 104       /* insisting on even addresses.                                   */
 105       {
 106         ptr_t alternate_ptr = bp + 1;
 107         ptr_t target = *(ptr_t *)bp;
 108         ptr_t alternate_target = *(ptr_t *)alternate_ptr;
 109
 110         if (alternate_target >= GC_least_plausible_heap_addr
 111             && alternate_target <= GC_greatest_plausible_heap_addr
 112             && (target < GC_least_plausible_heap_addr
 113                 || target > GC_greatest_plausible_heap_addr)) {
 114             bp = alternate_ptr;
 115         }
 116       }
 117 #   endif
 118     bp_base = GC_base(bp);
 119     if (0 == bp_base) {
 120       *base_p = bp;
 121       *offset_p = 0;
 122       return GC_REFD_FROM_ROOT;
 123     } else {
 124       if (GC_HAS_DEBUG_INFO(bp_base)) bp_base += sizeof(oh);
 125       *base_p = bp_base;
 126       *offset_p = bp - bp_base;
 127       return GC_REFD_FROM_HEAP;
 128     }
 129   }
 130
 131   /* Generate a random heap address.            */
 132   /* The resulting address is in the heap, but  */
 133   /* not necessarily inside a valid object.     */
 134   void *GC_generate_random_heap_address(void)
 135   {
 136     int i;
 137     long heap_offset = RANDOM();
 138     if (GC_heapsize > RAND_MAX) {
 139         heap_offset *= RAND_MAX;
 140         heap_offset += RANDOM();
 141     }
 142     heap_offset %= GC_heapsize;
 143         /* This doesn't yield a uniform distribution, especially if     */
 144         /* e.g. RAND_MAX = 1.5* GC_heapsize.  But for typical cases,    */
 145         /* it's not too bad.                                            */
 146     for (i = 0; i < GC_n_heap_sects; ++ i) {
 147         int size = GC_heap_sects[i].hs_bytes;
 148         if (heap_offset < size) {
 149             return GC_heap_sects[i].hs_start + heap_offset;
 150         } else {
 151             heap_offset -= size;
 152         }
 153     }
 154     ABORT("GC_generate_random_heap_address: size inconsistency");
 155     /*NOTREACHED*/
 156     return 0;
 157   }
 158
 159   /* Generate a random address inside a valid marked heap object. */
 160   void *GC_generate_random_valid_address(void)
 161   {
 162     ptr_t result;
 163     ptr_t base;
 164     for (;;) {
 165         result = GC_generate_random_heap_address();
 166         base = GC_base(result);
 167         if (0 == base) continue;
 168         if (!GC_is_marked(base)) continue;
 169         return result;
 170     }
 171   }
 172
 173   /* Print back trace for p */
 174   void GC_print_backtrace(void *p)
 175   {
 176     void *current = p;
 177     int i;
 178     GC_ref_kind source;
 179     size_t offset;
 180     void *base;
 181
 182     GC_print_heap_obj(GC_base(current));
 183     GC_err_printf0("\n");
 184     for (i = 0; ; ++i) {
 185       source = GC_get_back_ptr_info(current, &base, &offset);
 186       if (GC_UNREFERENCED == source) {
 187         GC_err_printf0("Reference could not be found\n");
 188         goto out;
 189       }
 190       if (GC_NO_SPACE == source) {
 191         GC_err_printf0("No debug info in object: Can't find reference\n");
 192         goto out;
 193       }
 194       GC_err_printf1("Reachable via %d levels of pointers from ",
 195                  (unsigned long)i);
 196       switch(source) {
 197         case GC_REFD_FROM_ROOT:
 198           GC_err_printf1("root at 0x%lx\n", (unsigned long)base);
 199           goto out;
 200         case GC_REFD_FROM_REG:
 201           GC_err_printf0("root in register\n");
 202           goto out;
 203         case GC_FINALIZER_REFD:
 204           GC_err_printf0("list of finalizable objects\n");
 205           goto out;
 206         case GC_REFD_FROM_HEAP:
 207           GC_err_printf1("offset %ld in object:\n", (unsigned long)offset);
 208           /* Take GC_base(base) to get real base, i.e. header. */
 209           GC_print_heap_obj(GC_base(base));
 210           GC_err_printf0("\n");
 211           break;
 212       }
 213       current = base;
 214     }
 215     out:;
 216   }
 217
 218   /* Force a garbage collection and generate a backtrace from a */
 219   /* random heap address.                                       */
 220   void GC_generate_random_backtrace(void)
 221   {
 222     void * current;
 223     GC_gcollect();
 224     current = GC_generate_random_valid_address();
 225     GC_printf1("Chose address 0x%lx in object\n", (unsigned long)current);
 226     GC_print_backtrace(current);
 227   }
 228
 229 #endif /* KEEP_BACK_PTRS */
 230
 231 /* Store debugging info into p.  Return displaced pointer. */
 232 /* Assumes we don't hold allocation lock.                  */
 233 ptr_t GC_store_debug_info(p, sz, string, integer)
 234 register ptr_t p;       /* base pointer */
 235 word sz;        /* bytes */
 236 GC_CONST char * string;
 237 word integer;
 238 {
 239     register word * result = (word *)((oh *)p + 1);
 240     DCL_LOCK_STATE;
 241
 242     /* There is some argument that we should dissble signals here.      */
 243     /* But that's expensive.  And this way things should only appear    */
 244     /* inconsistent while we're in the handler.                         */
 245     LOCK();
 246 #   ifdef KEEP_BACK_PTRS
 247       ((oh *)p) -> oh_back_ptr = HIDE_BACK_PTR(NOT_MARKED);
 248 #   endif
 249     ((oh *)p) -> oh_string = string;
 250     ((oh *)p) -> oh_int = integer;
 251 #   ifndef SHORT_DBG_HDRS
 252       ((oh *)p) -> oh_sz = sz;
 253       ((oh *)p) -> oh_sf = START_FLAG ^ (word)result;
 254       ((word *)p)[BYTES_TO_WORDS(GC_size(p))-1] =
 255          result[SIMPLE_ROUNDED_UP_WORDS(sz)] = END_FLAG ^ (word)result;
 256 #   endif
 257     UNLOCK();
 258     return((ptr_t)result);
 259 }
 260
 261 #ifdef DBG_HDRS_ALL
 262 /* Store debugging info into p.  Return displaced pointer.         */
 263 /* This version assumes we do hold the allocation lock.            */
 264 ptr_t GC_store_debug_info_inner(p, sz, string, integer)
 265 register ptr_t p;       /* base pointer */
 266 word sz;        /* bytes */
 267 char * string;
 268 word integer;
 269 {
 270     register word * result = (word *)((oh *)p + 1);
 271
 272     /* There is some argument that we should disable signals here.      */
 273     /* But that's expensive.  And this way things should only appear    */
 274     /* inconsistent while we're in the handler.                         */
 275 #   ifdef KEEP_BACK_PTRS
 276       ((oh *)p) -> oh_back_ptr = HIDE_BACK_PTR(NOT_MARKED);
 277 #   endif
 278     ((oh *)p) -> oh_string = string;
 279     ((oh *)p) -> oh_int = integer;
 280 #   ifndef SHORT_DBG_HDRS
 281       ((oh *)p) -> oh_sz = sz;
 282       ((oh *)p) -> oh_sf = START_FLAG ^ (word)result;
 283       ((word *)p)[BYTES_TO_WORDS(GC_size(p))-1] =
 284          result[SIMPLE_ROUNDED_UP_WORDS(sz)] = END_FLAG ^ (word)result;
 285 #   endif
 286     return((ptr_t)result);
 287 }
 288 #endif
 289
 290 #ifndef SHORT_DBG_HDRS
 291 /* Check the object with debugging info at ohdr         */
 292 /* return NIL if it's OK.  Else return clobbered        */
 293 /* address.                                             */
 294 ptr_t GC_check_annotated_obj(ohdr)
 295 register oh * ohdr;
 296 {
 297     register ptr_t body = (ptr_t)(ohdr + 1);
 298     register word gc_sz = GC_size((ptr_t)ohdr);
 299     if (ohdr -> oh_sz + DEBUG_BYTES > gc_sz) {
 300         return((ptr_t)(&(ohdr -> oh_sz)));
 301     }
 302     if (ohdr -> oh_sf != (START_FLAG ^ (word)body)) {
 303         return((ptr_t)(&(ohdr -> oh_sf)));
 304     }
 305     if (((word *)ohdr)[BYTES_TO_WORDS(gc_sz)-1] != (END_FLAG ^ (word)body)) {
 306         return((ptr_t)((word *)ohdr + BYTES_TO_WORDS(gc_sz)-1));
 307     }
 308     if (((word *)body)[SIMPLE_ROUNDED_UP_WORDS(ohdr -> oh_sz)]
 309         != (END_FLAG ^ (word)body)) {
 310         return((ptr_t)((word *)body + SIMPLE_ROUNDED_UP_WORDS(ohdr -> oh_sz)));
 311     }
 312     return(0);
 313 }
 314 #endif /* !SHORT_DBG_HDRS */
 315
 316 void GC_print_obj(p)
 317 ptr_t p;
 318 {
 319     register oh * ohdr = (oh *)GC_base(p);
 320
 321     GC_err_printf1("0x%lx (", ((unsigned long)ohdr + sizeof(oh)));
 322     GC_err_puts(ohdr -> oh_string);
 323 #   ifdef SHORT_DBG_HDRS
 324       GC_err_printf1(":%ld, sz=%ld)\n", (unsigned long)(ohdr -> oh_int));
 325 #   else
 326       GC_err_printf2(":%ld, sz=%ld)\n", (unsigned long)(ohdr -> oh_int),
 327                                         (unsigned long)(ohdr -> oh_sz));
 328 #   endif
 329     PRINT_CALL_CHAIN(ohdr);
 330 }
 331
 332 # if defined(__STDC__) || defined(__cplusplus)
 333     void GC_debug_print_heap_obj_proc(ptr_t p)
 334 # else
 335     void GC_debug_print_heap_obj_proc(p)
 336     ptr_t p;
 337 # endif
 338 {
 339     if (GC_HAS_DEBUG_INFO(p)) {
 340         GC_print_obj(p);
 341     } else {
 342         GC_default_print_heap_obj_proc(p);
 343     }
 344 }
 345
 346 #ifndef SHORT_DBG_HDRS
 347 void GC_print_smashed_obj(p, clobbered_addr)
 348 ptr_t p, clobbered_addr;
 349 {
 350     register oh * ohdr = (oh *)GC_base(p);
 351
 352     GC_err_printf2("0x%lx in object at 0x%lx(", (unsigned long)clobbered_addr,
 353                                                 (unsigned long)p);
 354     if (clobbered_addr <= (ptr_t)(&(ohdr -> oh_sz))
 355         || ohdr -> oh_string == 0) {
 356         GC_err_printf1("<smashed>, appr. sz = %ld)\n",
 357                        (GC_size((ptr_t)ohdr) - DEBUG_BYTES));
 358     } else {
 359         if (ohdr -> oh_string[0] == '\0') {
 360             GC_err_puts("EMPTY(smashed?)");
 361         } else {
 362             GC_err_puts(ohdr -> oh_string);
 363         }
 364         GC_err_printf2(":%ld, sz=%ld)\n", (unsigned long)(ohdr -> oh_int),
 365                                           (unsigned long)(ohdr -> oh_sz));
 366         PRINT_CALL_CHAIN(ohdr);
 367     }
 368 }
 369 #endif
 370
 371 void GC_check_heap_proc GC_PROTO((void));
 372
 373 void GC_do_nothing() {}
 374
 375 void GC_start_debugging()
 376 {
 377 #   ifndef SHORT_DBG_HDRS
 378       GC_check_heap = GC_check_heap_proc;
 379 #   else
 380       GC_check_heap = GC_do_nothing;
 381 #   endif
 382     GC_print_heap_obj = GC_debug_print_heap_obj_proc;
 383     GC_debugging_started = TRUE;
 384     GC_register_displacement((word)sizeof(oh));
 385 }
 386
 387 # if defined(__STDC__) || defined(__cplusplus)
 388     void GC_debug_register_displacement(GC_word offset)
 389 # else
 390     void GC_debug_register_displacement(offset)
 391     GC_word offset;
 392 # endif
 393 {
 394     GC_register_displacement(offset);
 395     GC_register_displacement((word)sizeof(oh) + offset);
 396 }
 397
 398 # ifdef __STDC__
 399     GC_PTR GC_debug_malloc(size_t lb, GC_EXTRA_PARAMS)
 400 # else
 401     GC_PTR GC_debug_malloc(lb, s, i)
 402     size_t lb;
 403     char * s;
 404     int i;
 405 #   ifdef GC_ADD_CALLER
 406         --> GC_ADD_CALLER not implemented for K&R C
 407 #   endif
 408 # endif
 409 {
 410     GC_PTR result = GC_malloc(lb + DEBUG_BYTES);
 411
 412     if (result == 0) {
 413         GC_err_printf1("GC_debug_malloc(%ld) returning NIL (",
 414                        (unsigned long) lb);
 415         GC_err_puts(s);
 416         GC_err_printf1(":%ld)\n", (unsigned long)i);
 417         return(0);
 418     }
 419     if (!GC_debugging_started) {
 420         GC_start_debugging();
 421     }
 422     ADD_CALL_CHAIN(result, ra);
 423     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 424 }
 425
 426 # ifdef DBG_HDRS_ALL
 427 /*
 428  * An allocation function for internal use.
 429  * Normally internally allocated objects do not have debug information.
 430  * But in this case, we need to make sure that all objects have debug
 431  * headers.
 432  * We assume debugging was started in collector initialization,
 433  * and we already hold the GC lock.
 434  */
 435   GC_PTR GC_debug_generic_malloc_inner(size_t lb, int k)
 436   {
 437     GC_PTR result = GC_generic_malloc_inner(lb + DEBUG_BYTES, k);
 438
 439     if (result == 0) {
 440         GC_err_printf1("GC internal allocation (%ld bytes) returning NIL\n",
 441                        (unsigned long) lb);
 442         return(0);
 443     }
 444     ADD_CALL_CHAIN(result, ra);
 445     return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", (word)0));
 446   }
 447
 448   GC_PTR GC_debug_generic_malloc_inner_ignore_off_page(size_t lb, int k)
 449   {
 450     GC_PTR result = GC_generic_malloc_inner_ignore_off_page(
 451                                                 lb + DEBUG_BYTES, k);
 452
 453     if (result == 0) {
 454         GC_err_printf1("GC internal allocation (%ld bytes) returning NIL\n",
 455                        (unsigned long) lb);
 456         return(0);
 457     }
 458     ADD_CALL_CHAIN(result, ra);
 459     return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", (word)0));
 460   }
 461 # endif
 462
 463 #ifdef STUBBORN_ALLOC
 464 # ifdef __STDC__
 465     GC_PTR GC_debug_malloc_stubborn(size_t lb, GC_EXTRA_PARAMS)
 466 # else
 467     GC_PTR GC_debug_malloc_stubborn(lb, s, i)
 468     size_t lb;
 469     char * s;
 470     int i;
 471 # endif
 472 {
 473     GC_PTR result = GC_malloc_stubborn(lb + DEBUG_BYTES);
 474
 475     if (result == 0) {
 476         GC_err_printf1("GC_debug_malloc(%ld) returning NIL (",
 477                        (unsigned long) lb);
 478         GC_err_puts(s);
 479         GC_err_printf1(":%ld)\n", (unsigned long)i);
 480         return(0);
 481     }
 482     if (!GC_debugging_started) {
 483         GC_start_debugging();
 484     }
 485     ADD_CALL_CHAIN(result, ra);
 486     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 487 }
 488
 489 void GC_debug_change_stubborn(p)
 490 GC_PTR p;
 491 {
 492     register GC_PTR q = GC_base(p);
 493     register hdr * hhdr;
 494
 495     if (q == 0) {
 496         GC_err_printf1("Bad argument: 0x%lx to GC_debug_change_stubborn\n",
 497                        (unsigned long) p);
 498         ABORT("GC_debug_change_stubborn: bad arg");
 499     }
 500     hhdr = HDR(q);
 501     if (hhdr -> hb_obj_kind != STUBBORN) {
 502         GC_err_printf1("GC_debug_change_stubborn arg not stubborn: 0x%lx\n",
 503                        (unsigned long) p);
 504         ABORT("GC_debug_change_stubborn: arg not stubborn");
 505     }
 506     GC_change_stubborn(q);
 507 }
 508
 509 void GC_debug_end_stubborn_change(p)
 510 GC_PTR p;
 511 {
 512     register GC_PTR q = GC_base(p);
 513     register hdr * hhdr;
 514
 515     if (q == 0) {
 516         GC_err_printf1("Bad argument: 0x%lx to GC_debug_end_stubborn_change\n",
 517                        (unsigned long) p);
 518         ABORT("GC_debug_end_stubborn_change: bad arg");
 519     }
 520     hhdr = HDR(q);
 521     if (hhdr -> hb_obj_kind != STUBBORN) {
 522         GC_err_printf1("debug_end_stubborn_change arg not stubborn: 0x%lx\n",
 523                        (unsigned long) p);
 524         ABORT("GC_debug_end_stubborn_change: arg not stubborn");
 525     }
 526     GC_end_stubborn_change(q);
 527 }
 528
 529 #else /* !STUBBORN_ALLOC */
 530
 531 # ifdef __STDC__
 532     GC_PTR GC_debug_malloc_stubborn(size_t lb, GC_EXTRA_PARAMS)
 533 # else
 534     GC_PTR GC_debug_malloc_stubborn(lb, s, i)
 535     size_t lb;
 536     char * s;
 537     int i;
 538 # endif
 539 {
 540     return GC_debug_malloc(lb, OPT_RA s, i);
 541 }
 542
 543 void GC_debug_change_stubborn(p)
 544 GC_PTR p;
 545 {
 546 }
 547
 548 void GC_debug_end_stubborn_change(p)
 549 GC_PTR p;
 550 {
 551 }
 552
 553 #endif /* !STUBBORN_ALLOC */
 554
 555 # ifdef __STDC__
 556     GC_PTR GC_debug_malloc_atomic(size_t lb, GC_EXTRA_PARAMS)
 557 # else
 558     GC_PTR GC_debug_malloc_atomic(lb, s, i)
 559     size_t lb;
 560     char * s;
 561     int i;
 562 # endif
 563 {
 564     GC_PTR result = GC_malloc_atomic(lb + DEBUG_BYTES);
 565
 566     if (result == 0) {
 567         GC_err_printf1("GC_debug_malloc_atomic(%ld) returning NIL (",
 568                       (unsigned long) lb);
 569         GC_err_puts(s);
 570         GC_err_printf1(":%ld)\n", (unsigned long)i);
 571         return(0);
 572     }
 573     if (!GC_debugging_started) {
 574         GC_start_debugging();
 575     }
 576     ADD_CALL_CHAIN(result, ra);
 577     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 578 }
 579
 580 # ifdef __STDC__
 581     GC_PTR GC_debug_malloc_uncollectable(size_t lb, GC_EXTRA_PARAMS)
 582 # else
 583     GC_PTR GC_debug_malloc_uncollectable(lb, s, i)
 584     size_t lb;
 585     char * s;
 586     int i;
 587 # endif
 588 {
 589     GC_PTR result = GC_malloc_uncollectable(lb + DEBUG_BYTES);
 590
 591     if (result == 0) {
 592         GC_err_printf1("GC_debug_malloc_uncollectable(%ld) returning NIL (",
 593                       (unsigned long) lb);
 594         GC_err_puts(s);
 595         GC_err_printf1(":%ld)\n", (unsigned long)i);
 596         return(0);
 597     }
 598     if (!GC_debugging_started) {
 599         GC_start_debugging();
 600     }
 601     ADD_CALL_CHAIN(result, ra);
 602     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 603 }
 604
 605 #ifdef ATOMIC_UNCOLLECTABLE
 606 # ifdef __STDC__
 607     GC_PTR GC_debug_malloc_atomic_uncollectable(size_t lb, GC_EXTRA_PARAMS)
 608 # else
 609     GC_PTR GC_debug_malloc_atomic_uncollectable(lb, s, i)
 610     size_t lb;
 611     char * s;
 612     int i;
 613 # endif
 614 {
 615     GC_PTR result = GC_malloc_atomic_uncollectable(lb + DEBUG_BYTES);
 616
 617     if (result == 0) {
 618         GC_err_printf1(
 619                 "GC_debug_malloc_atomic_uncollectable(%ld) returning NIL (",
 620                 (unsigned long) lb);
 621         GC_err_puts(s);
 622         GC_err_printf1(":%ld)\n", (unsigned long)i);
 623         return(0);
 624     }
 625     if (!GC_debugging_started) {
 626         GC_start_debugging();
 627     }
 628     ADD_CALL_CHAIN(result, ra);
 629     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 630 }
 631 #endif /* ATOMIC_UNCOLLECTABLE */
 632
 633 # ifdef __STDC__
 634     void GC_debug_free(GC_PTR p)
 635 # else
 636     void GC_debug_free(p)
 637     GC_PTR p;
 638 # endif
 639 {
 640     register GC_PTR base;
 641     register ptr_t clobbered;
 642
 643     if (0 == p) return;
 644     base = GC_base(p);
 645     if (base == 0) {
 646         GC_err_printf1("Attempt to free invalid pointer %lx\n",
 647                        (unsigned long)p);
 648         ABORT("free(invalid pointer)");
 649     }
 650     if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
 651         GC_err_printf1(
 652                   "GC_debug_free called on pointer %lx wo debugging info\n",
 653                   (unsigned long)p);
 654     } else {
 655 #     ifndef SHORT_DBG_HDRS
 656         clobbered = GC_check_annotated_obj((oh *)base);
 657         if (clobbered != 0) {
 658           if (((oh *)base) -> oh_sz == GC_size(base)) {
 659             GC_err_printf0(
 660                   "GC_debug_free: found previously deallocated (?) object at ");
 661           } else {
 662             GC_err_printf0("GC_debug_free: found smashed location at ");
 663           }
 664           GC_print_smashed_obj(p, clobbered);
 665         }
 666         /* Invalidate size */
 667         ((oh *)base) -> oh_sz = GC_size(base);
 668 #     endif /* SHORT_DBG_HDRS */
 669     }
 670     if (GC_find_leak) {
 671         GC_free(base);
 672     } else {
 673         register hdr * hhdr = HDR(p);
 674         GC_bool uncollectable = FALSE;
 675
 676         if (hhdr ->  hb_obj_kind == UNCOLLECTABLE) {
 677             uncollectable = TRUE;
 678         }
 679 #       ifdef ATOMIC_UNCOLLECTABLE
 680             if (hhdr ->  hb_obj_kind == AUNCOLLECTABLE) {
 681                     uncollectable = TRUE;
 682             }
 683 #       endif
 684         if (uncollectable) GC_free(base);
 685     } /* !GC_find_leak */
 686 }
 687
 688 #ifdef THREADS
 689
 690 extern void GC_free_inner(GC_PTR p);
 691
 692 /* Used internally; we assume it's called correctly.    */
 693 void GC_debug_free_inner(GC_PTR p)
 694 {
 695     GC_free_inner(GC_base(p));
 696 }
 697 #endif
 698
 699 # ifdef __STDC__
 700     GC_PTR GC_debug_realloc(GC_PTR p, size_t lb, GC_EXTRA_PARAMS)
 701 # else
 702     GC_PTR GC_debug_realloc(p, lb, s, i)
 703     GC_PTR p;
 704     size_t lb;
 705     char *s;
 706     int i;
 707 # endif
 708 {
 709     register GC_PTR base = GC_base(p);
 710     register ptr_t clobbered;
 711     register GC_PTR result;
 712     register size_t copy_sz = lb;
 713     register size_t old_sz;
 714     register hdr * hhdr;
 715
 716     if (p == 0) return(GC_debug_malloc(lb, OPT_RA s, i));
 717     if (base == 0) {
 718         GC_err_printf1(
 719               "Attempt to reallocate invalid pointer %lx\n", (unsigned long)p);
 720         ABORT("realloc(invalid pointer)");
 721     }
 722     if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
 723         GC_err_printf1(
 724                 "GC_debug_realloc called on pointer %lx wo debugging info\n",
 725                 (unsigned long)p);
 726         return(GC_realloc(p, lb));
 727     }
 728     hhdr = HDR(base);
 729     switch (hhdr -> hb_obj_kind) {
 730 #    ifdef STUBBORN_ALLOC
 731       case STUBBORN:
 732         result = GC_debug_malloc_stubborn(lb, OPT_RA s, i);
 733         break;
 734 #    endif
 735       case NORMAL:
 736         result = GC_debug_malloc(lb, OPT_RA s, i);
 737         break;
 738       case PTRFREE:
 739         result = GC_debug_malloc_atomic(lb, OPT_RA s, i);
 740         break;
 741       case UNCOLLECTABLE:
 742         result = GC_debug_malloc_uncollectable(lb, OPT_RA s, i);
 743         break;
 744 #    ifdef ATOMIC_UNCOLLECTABLE
 745       case AUNCOLLECTABLE:
 746         result = GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i);
 747         break;
 748 #    endif
 749       default:
 750         GC_err_printf0("GC_debug_realloc: encountered bad kind\n");
 751         ABORT("bad kind");
 752     }
 753 #   ifdef SHORT_DBG_HDRS
 754       old_sz = GC_size(base) - sizeof(oh);
 755 #   else
 756       clobbered = GC_check_annotated_obj((oh *)base);
 757       if (clobbered != 0) {
 758         GC_err_printf0("GC_debug_realloc: found smashed location at ");
 759         GC_print_smashed_obj(p, clobbered);
 760       }
 761       old_sz = ((oh *)base) -> oh_sz;
 762 #   endif
 763     if (old_sz < copy_sz) copy_sz = old_sz;
 764     if (result == 0) return(0);
 765     BCOPY(p, result,  copy_sz);
 766     GC_debug_free(p);
 767     return(result);
 768 }
 769
 770 #ifndef SHORT_DBG_HDRS
 771 /* Check all marked objects in the given block for validity */
 772 /*ARGSUSED*/
 773 # if defined(__STDC__) || defined(__cplusplus)
 774     void GC_check_heap_block(register struct hblk *hbp, word dummy)
 775 # else
 776     void GC_check_heap_block(hbp, dummy)
 777     register struct hblk *hbp;  /* ptr to current heap block            */
 778     word dummy;
 779 # endif
 780 {
 781     register struct hblkhdr * hhdr = HDR(hbp);
 782     register word sz = hhdr -> hb_sz;
 783     register int word_no;
 784     register word *p, *plim;
 785
 786     p = (word *)(hbp->hb_body);
 787     word_no = 0;
 788     if (sz > MAXOBJSZ) {
 789         plim = p;
 790     } else {
 791         plim = (word *)((((word)hbp) + HBLKSIZE) - WORDS_TO_BYTES(sz));
 792     }
 793     /* go through all words in block */
 794         while( p <= plim ) {
 795             if( mark_bit_from_hdr(hhdr, word_no)
 796                 && GC_HAS_DEBUG_INFO((ptr_t)p)) {
 797                 ptr_t clobbered = GC_check_annotated_obj((oh *)p);
 798
 799                 if (clobbered != 0) {
 800                     GC_err_printf0(
 801                         "GC_check_heap_block: found smashed location at ");
 802                     GC_print_smashed_obj((ptr_t)p, clobbered);
 803                 }
 804             }
 805             word_no += sz;
 806             p += sz;
 807         }
 808 }
 809
 810
 811 /* This assumes that all accessible objects are marked, and that        */
 812 /* I hold the allocation lock.  Normally called by collector.           */
 813 void GC_check_heap_proc()
 814 {
 815 #   ifndef SMALL_CONFIG
 816         if (sizeof(oh) & (2 * sizeof(word) - 1) != 0) {
 817             ABORT("Alignment problem: object header has inappropriate size\n");
 818         }
 819 #   endif
 820     GC_apply_to_all_blocks(GC_check_heap_block, (word)0);
 821 }
 822
 823 #endif /* !SHORT_DBG_HDRS */
 824
 825 struct closure {
 826     GC_finalization_proc cl_fn;
 827     GC_PTR cl_data;
 828 };
 829
 830 # ifdef __STDC__
 831     void * GC_make_closure(GC_finalization_proc fn, void * data)
 832 # else
 833     GC_PTR GC_make_closure(fn, data)
 834     GC_finalization_proc fn;
 835     GC_PTR data;
 836 # endif
 837 {
 838     struct closure * result =
 839 #               ifdef DBG_HDRS_ALL
 840                   (struct closure *) GC_debug_malloc(sizeof (struct closure),
 841                                                      GC_EXTRAS);
 842 #               else
 843                   (struct closure *) GC_malloc(sizeof (struct closure));
 844 #               endif
 845
 846     result -> cl_fn = fn;
 847     result -> cl_data = data;
 848     return((GC_PTR)result);
 849 }
 850
 851 # ifdef __STDC__
 852     void GC_debug_invoke_finalizer(void * obj, void * data)
 853 # else
 854     void GC_debug_invoke_finalizer(obj, data)
 855     char * obj;
 856     char * data;
 857 # endif
 858 {
 859     register struct closure * cl = (struct closure *) data;
 860
 861     (*(cl -> cl_fn))((GC_PTR)((char *)obj + sizeof(oh)), cl -> cl_data);
 862 }
 863
 864 /* Set ofn and ocd to reflect the values we got back.   */
 865 static void store_old (obj, my_old_fn, my_old_cd, ofn, ocd)
 866 GC_PTR obj;
 867 GC_finalization_proc my_old_fn;
 868 struct closure * my_old_cd;
 869 GC_finalization_proc *ofn;
 870 GC_PTR *ocd;
 871 {
 872     if (0 != my_old_fn) {
 873       if (my_old_fn != GC_debug_invoke_finalizer) {
 874         GC_err_printf1("Debuggable object at 0x%lx had non-debug finalizer.\n",
 875                        obj);
 876         /* This should probably be fatal. */
 877       } else {
 878         if (ofn) *ofn = my_old_cd -> cl_fn;
 879         if (ocd) *ocd = my_old_cd -> cl_data;
 880       }
 881     } else {
 882       if (ofn) *ofn = 0;
 883       if (ocd) *ocd = 0;
 884     }
 885 }
 886
 887 # ifdef __STDC__
 888     void GC_debug_register_finalizer(GC_PTR obj, GC_finalization_proc fn,
 889                                      GC_PTR cd, GC_finalization_proc *ofn,
 890                                      GC_PTR *ocd)
 891 # else
 892     void GC_debug_register_finalizer(obj, fn, cd, ofn, ocd)
 893     GC_PTR obj;
 894     GC_finalization_proc fn;
 895     GC_PTR cd;
 896     GC_finalization_proc *ofn;
 897     GC_PTR *ocd;
 898 # endif
 899 {
 900     GC_finalization_proc my_old_fn;
 901     GC_PTR my_old_cd;
 902     ptr_t base = GC_base(obj);
 903     if (0 == base || (ptr_t)obj - base != sizeof(oh)) {
 904         GC_err_printf1(
 905             "GC_register_finalizer called with non-base-pointer 0x%lx\n",
 906             obj);
 907     }
 908     if (0 == fn) {
 909       GC_register_finalizer(base, 0, 0, &my_old_fn, &my_old_cd);
 910     } else {
 911       GC_register_finalizer(base, GC_debug_invoke_finalizer,
 912                             GC_make_closure(fn,cd), &my_old_fn, &my_old_cd);
 913     }
 914     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
 915 }
 916
 917 # ifdef __STDC__
 918     void GC_debug_register_finalizer_no_order
 919                                     (GC_PTR obj, GC_finalization_proc fn,
 920                                      GC_PTR cd, GC_finalization_proc *ofn,
 921                                      GC_PTR *ocd)
 922 # else
 923     void GC_debug_register_finalizer_no_order
 924                                     (obj, fn, cd, ofn, ocd)
 925     GC_PTR obj;
 926     GC_finalization_proc fn;
 927     GC_PTR cd;
 928     GC_finalization_proc *ofn;
 929     GC_PTR *ocd;
 930 # endif
 931 {
 932     GC_finalization_proc my_old_fn;
 933     GC_PTR my_old_cd;
 934     ptr_t base = GC_base(obj);
 935     if (0 == base || (ptr_t)obj - base != sizeof(oh)) {
 936         GC_err_printf1(
 937           "GC_register_finalizer_no_order called with non-base-pointer 0x%lx\n",
 938           obj);
 939     }
 940     if (0 == fn) {
 941       GC_register_finalizer_no_order(base, 0, 0, &my_old_fn, &my_old_cd);
 942     } else {
 943       GC_register_finalizer_no_order(base, GC_debug_invoke_finalizer,
 944                                      GC_make_closure(fn,cd), &my_old_fn,
 945                                      &my_old_cd);
 946     }
 947     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
 948  }
 949
 950 # ifdef __STDC__
 951     void GC_debug_register_finalizer_ignore_self
 952                                     (GC_PTR obj, GC_finalization_proc fn,
 953                                      GC_PTR cd, GC_finalization_proc *ofn,
 954                                      GC_PTR *ocd)
 955 # else
 956     void GC_debug_register_finalizer_ignore_self
 957                                     (obj, fn, cd, ofn, ocd)
 958     GC_PTR obj;
 959     GC_finalization_proc fn;
 960     GC_PTR cd;
 961     GC_finalization_proc *ofn;
 962     GC_PTR *ocd;
 963 # endif
 964 {
 965     GC_finalization_proc my_old_fn;
 966     GC_PTR my_old_cd;
 967     ptr_t base = GC_base(obj);
 968     if (0 == base || (ptr_t)obj - base != sizeof(oh)) {
 969         GC_err_printf1(
 970             "GC_register_finalizer_ignore_self called with non-base-pointer 0x%lx\n",
 971             obj);
 972     }
 973     if (0 == fn) {
 974       GC_register_finalizer_ignore_self(base, 0, 0, &my_old_fn, &my_old_cd);
 975     } else {
 976       GC_register_finalizer_ignore_self(base, GC_debug_invoke_finalizer,
 977                                      GC_make_closure(fn,cd), &my_old_fn,
 978                                      &my_old_cd);
 979     }
 980     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
 981 }
 982
 983 #ifdef GC_ADD_CALLER
 984 # define RA GC_RETURN_ADDR,
 985 #else
 986 # define RA
 987 #endif
 988
 989 GC_PTR GC_debug_malloc_replacement(lb)
 990 size_t lb;
 991 {
 992     return GC_debug_malloc(lb, RA "unknown", 0);
 993 }
 994
 995 GC_PTR GC_debug_realloc_replacement(p, lb)
 996 GC_PTR p;
 997 size_t lb;
 998 {
 999     return GC_debug_realloc(p, lb, RA "unknown", 0);
1000 }