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