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(LINUX) || 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 void GC_print_smashed_obj(ptr_t p, ptr_t clobbered_addr)
 408 {
 409     register oh * ohdr = (oh *)GC_base(p);
 410
 411     GC_ASSERT(I_DONT_HOLD_LOCK());
 412     GC_err_printf("%p in object at %p(", clobbered_addr, p);
 413     if (clobbered_addr <= (ptr_t)(&(ohdr -> oh_sz))
 414         || ohdr -> oh_string == 0) {
 415         GC_err_printf("<smashed>, appr. sz = %ld)\n",
 416                        (GC_size((ptr_t)ohdr) - DEBUG_BYTES));
 417     } else {
 418         if (ohdr -> oh_string[0] == '\0') {
 419             GC_err_puts("EMPTY(smashed?)");
 420         } else {
 421             GC_err_puts(ohdr -> oh_string);
 422         }
 423         GC_err_printf(":%ld, sz=%ld)\n", (unsigned long)(ohdr -> oh_int),
 424                                           (unsigned long)(ohdr -> oh_sz));
 425         PRINT_CALL_CHAIN(ohdr);
 426     }
 427 }
 428 #endif
 429
 430 void GC_check_heap_proc (void);
 431
 432 void GC_print_all_smashed_proc (void);
 433
 434 void GC_do_nothing(void) {}
 435
 436 void GC_start_debugging(void)
 437 {
 438 #   ifndef SHORT_DBG_HDRS
 439       GC_check_heap = GC_check_heap_proc;
 440       GC_print_all_smashed = GC_print_all_smashed_proc;
 441 #   else
 442       GC_check_heap = GC_do_nothing;
 443       GC_print_all_smashed = GC_do_nothing;
 444 #   endif
 445     GC_print_heap_obj = GC_debug_print_heap_obj_proc;
 446     GC_debugging_started = TRUE;
 447     GC_register_displacement((word)sizeof(oh));
 448 }
 449
 450 size_t GC_debug_header_size = sizeof(oh);
 451
 452 void GC_debug_register_displacement(size_t offset)
 453 {
 454     GC_register_displacement(offset);
 455     GC_register_displacement((word)sizeof(oh) + offset);
 456 }
 457
 458 void * GC_debug_malloc(size_t lb, GC_EXTRA_PARAMS)
 459 {
 460     void * result = GC_malloc(lb + DEBUG_BYTES);
 461
 462     if (result == 0) {
 463         GC_err_printf("GC_debug_malloc(%lu) returning NIL (",
 464                       (unsigned long) lb);
 465         GC_err_puts(s);
 466         GC_err_printf(":%ld)\n", (unsigned long)i);
 467         return(0);
 468     }
 469     if (!GC_debugging_started) {
 470         GC_start_debugging();
 471     }
 472     ADD_CALL_CHAIN(result, ra);
 473     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 474 }
 475
 476 void * GC_debug_malloc_ignore_off_page(size_t lb, GC_EXTRA_PARAMS)
 477 {
 478     void * result = GC_malloc_ignore_off_page(lb + DEBUG_BYTES);
 479
 480     if (result == 0) {
 481         GC_err_printf("GC_debug_malloc_ignore_off_page(%lu) returning NIL (",
 482                        (unsigned long) lb);
 483         GC_err_puts(s);
 484         GC_err_printf(":%lu)\n", (unsigned long)i);
 485         return(0);
 486     }
 487     if (!GC_debugging_started) {
 488         GC_start_debugging();
 489     }
 490     ADD_CALL_CHAIN(result, ra);
 491     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 492 }
 493
 494 void * GC_debug_malloc_atomic_ignore_off_page(size_t lb, GC_EXTRA_PARAMS)
 495 {
 496     void * result = GC_malloc_atomic_ignore_off_page(lb + DEBUG_BYTES);
 497
 498     if (result == 0) {
 499         GC_err_printf("GC_debug_malloc_atomic_ignore_off_page(%lu)"
 500                        " returning NIL (", (unsigned long) lb);
 501         GC_err_puts(s);
 502         GC_err_printf(":%lu)\n", (unsigned long)i);
 503         return(0);
 504     }
 505     if (!GC_debugging_started) {
 506         GC_start_debugging();
 507     }
 508     ADD_CALL_CHAIN(result, ra);
 509     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 510 }
 511
 512 # ifdef DBG_HDRS_ALL
 513 /*
 514  * An allocation function for internal use.
 515  * Normally internally allocated objects do not have debug information.
 516  * But in this case, we need to make sure that all objects have debug
 517  * headers.
 518  * We assume debugging was started in collector initialization,
 519  * and we already hold the GC lock.
 520  */
 521   void * GC_debug_generic_malloc_inner(size_t lb, int k)
 522   {
 523     void * result = GC_generic_malloc_inner(lb + DEBUG_BYTES, k);
 524
 525     if (result == 0) {
 526         GC_err_printf("GC internal allocation (%lu bytes) returning NIL\n",
 527                        (unsigned long) lb);
 528         return(0);
 529     }
 530     ADD_CALL_CHAIN(result, GC_RETURN_ADDR);
 531     return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", (word)0));
 532   }
 533
 534   void * GC_debug_generic_malloc_inner_ignore_off_page(size_t lb, int k)
 535   {
 536     void * result = GC_generic_malloc_inner_ignore_off_page(
 537                                                 lb + DEBUG_BYTES, k);
 538
 539     if (result == 0) {
 540         GC_err_printf("GC internal allocation (%lu bytes) returning NIL\n",
 541                        (unsigned long) lb);
 542         return(0);
 543     }
 544     ADD_CALL_CHAIN(result, GC_RETURN_ADDR);
 545     return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", (word)0));
 546   }
 547 # endif
 548
 549 #ifdef STUBBORN_ALLOC
 550 void * GC_debug_malloc_stubborn(size_t lb, GC_EXTRA_PARAMS)
 551 {
 552     void * result = GC_malloc_stubborn(lb + DEBUG_BYTES);
 553
 554     if (result == 0) {
 555         GC_err_printf("GC_debug_malloc(%lu) returning NIL (",
 556                       (unsigned long) lb);
 557         GC_err_puts(s);
 558         GC_err_printf(":%lu)\n", (unsigned long)i);
 559         return(0);
 560     }
 561     if (!GC_debugging_started) {
 562         GC_start_debugging();
 563     }
 564     ADD_CALL_CHAIN(result, ra);
 565     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 566 }
 567
 568 void GC_debug_change_stubborn(void *p)
 569 {
 570     void * q = GC_base(p);
 571     hdr * hhdr;
 572
 573     if (q == 0) {
 574         GC_err_printf("Bad argument: %p to GC_debug_change_stubborn\n", p);
 575         ABORT("GC_debug_change_stubborn: bad arg");
 576     }
 577     hhdr = HDR(q);
 578     if (hhdr -> hb_obj_kind != STUBBORN) {
 579         GC_err_printf("GC_debug_change_stubborn arg not stubborn: %p\n", p);
 580         ABORT("GC_debug_change_stubborn: arg not stubborn");
 581     }
 582     GC_change_stubborn(q);
 583 }
 584
 585 void GC_debug_end_stubborn_change(void *p)
 586 {
 587     register void * q = GC_base(p);
 588     register hdr * hhdr;
 589
 590     if (q == 0) {
 591         GC_err_printf("Bad argument: %p to GC_debug_end_stubborn_change\n", p);
 592         ABORT("GC_debug_end_stubborn_change: bad arg");
 593     }
 594     hhdr = HDR(q);
 595     if (hhdr -> hb_obj_kind != STUBBORN) {
 596         GC_err_printf("debug_end_stubborn_change arg not stubborn: %p\n", p);
 597         ABORT("GC_debug_end_stubborn_change: arg not stubborn");
 598     }
 599     GC_end_stubborn_change(q);
 600 }
 601
 602 #else /* !STUBBORN_ALLOC */
 603
 604 void * GC_debug_malloc_stubborn(size_t lb, GC_EXTRA_PARAMS)
 605 {
 606     return GC_debug_malloc(lb, OPT_RA s, i);
 607 }
 608
 609 void GC_debug_change_stubborn(void *p)
 610 {
 611 }
 612
 613 void GC_debug_end_stubborn_change(void *p)
 614 {
 615 }
 616
 617 #endif /* !STUBBORN_ALLOC */
 618
 619 void * GC_debug_malloc_atomic(size_t lb, GC_EXTRA_PARAMS)
 620 {
 621     void * result = GC_malloc_atomic(lb + DEBUG_BYTES);
 622
 623     if (result == 0) {
 624         GC_err_printf("GC_debug_malloc_atomic(%lu) returning NIL (",
 625                       (unsigned long) lb);
 626         GC_err_puts(s);
 627         GC_err_printf(":%lu)\n", (unsigned long)i);
 628         return(0);
 629     }
 630     if (!GC_debugging_started) {
 631         GC_start_debugging();
 632     }
 633     ADD_CALL_CHAIN(result, ra);
 634     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 635 }
 636
 637 char *GC_debug_strdup(const char *str, GC_EXTRA_PARAMS)
 638 {
 639     char *copy;
 640     if (str == NULL) return NULL;
 641     copy = GC_debug_malloc_atomic(strlen(str) + 1, OPT_RA s, i);
 642     if (copy == NULL) {
 643       errno = ENOMEM;
 644       return NULL;
 645     }
 646     strcpy(copy, str);
 647     return copy;
 648 }
 649
 650 void * GC_debug_malloc_uncollectable(size_t lb, GC_EXTRA_PARAMS)
 651 {
 652     void * result = GC_malloc_uncollectable(lb + UNCOLLECTABLE_DEBUG_BYTES);
 653
 654     if (result == 0) {
 655         GC_err_printf("GC_debug_malloc_uncollectable(%lu) returning NIL (",
 656                       (unsigned long) lb);
 657         GC_err_puts(s);
 658         GC_err_printf(":%lu)\n", (unsigned long)i);
 659         return(0);
 660     }
 661     if (!GC_debugging_started) {
 662         GC_start_debugging();
 663     }
 664     ADD_CALL_CHAIN(result, ra);
 665     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 666 }
 667
 668 #ifdef ATOMIC_UNCOLLECTABLE
 669 void * GC_debug_malloc_atomic_uncollectable(size_t lb, GC_EXTRA_PARAMS)
 670 {
 671     void * result =
 672         GC_malloc_atomic_uncollectable(lb + UNCOLLECTABLE_DEBUG_BYTES);
 673
 674     if (result == 0) {
 675         GC_err_printf(
 676                 "GC_debug_malloc_atomic_uncollectable(%lu) returning NIL (",
 677                 (unsigned long) lb);
 678         GC_err_puts(s);
 679         GC_err_printf(":%lu)\n", (unsigned long)i);
 680         return(0);
 681     }
 682     if (!GC_debugging_started) {
 683         GC_start_debugging();
 684     }
 685     ADD_CALL_CHAIN(result, ra);
 686     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 687 }
 688 #endif /* ATOMIC_UNCOLLECTABLE */
 689
 690 void GC_debug_free(void * p)
 691 {
 692     ptr_t base;
 693     ptr_t clobbered;
 694
 695     if (0 == p) return;
 696     base = GC_base(p);
 697     if (base == 0) {
 698         GC_err_printf("Attempt to free invalid pointer %p\n", p);
 699         ABORT("free(invalid pointer)");
 700     }
 701     if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
 702         GC_err_printf(
 703                   "GC_debug_free called on pointer %p wo debugging info\n", p);
 704     } else {
 705 #     ifndef SHORT_DBG_HDRS
 706         clobbered = GC_check_annotated_obj((oh *)base);
 707         if (clobbered != 0) {
 708           if (((oh *)base) -> oh_sz == GC_size(base)) {
 709             GC_err_printf(
 710                   "GC_debug_free: found previously deallocated (?) object at ");
 711           } else {
 712             GC_err_printf("GC_debug_free: found smashed location at ");
 713           }
 714           GC_print_smashed_obj(p, clobbered);
 715         }
 716         /* Invalidate size */
 717         ((oh *)base) -> oh_sz = GC_size(base);
 718 #     endif /* SHORT_DBG_HDRS */
 719     }
 720     if (GC_find_leak) {
 721         GC_free(base);
 722     } else {
 723         hdr * hhdr = HDR(p);
 724         GC_bool uncollectable = FALSE;
 725
 726         if (hhdr ->  hb_obj_kind == UNCOLLECTABLE) {
 727             uncollectable = TRUE;
 728         }
 729 #       ifdef ATOMIC_UNCOLLECTABLE
 730             if (hhdr ->  hb_obj_kind == AUNCOLLECTABLE) {
 731                     uncollectable = TRUE;
 732             }
 733 #       endif
 734         if (uncollectable) {
 735             GC_free(base);
 736         } else {
 737             size_t i;
 738             size_t obj_sz = BYTES_TO_WORDS(hhdr -> hb_sz - sizeof(oh));
 739
 740             for (i = 0; i < obj_sz; ++i) ((word *)p)[i] = 0xdeadbeef;
 741             GC_ASSERT((word *)p + i == (word *)(base + hhdr -> hb_sz));
 742         }
 743     } /* !GC_find_leak */
 744 }
 745
 746 #ifdef THREADS
 747
 748 extern void GC_free_inner(void * p);
 749
 750 /* Used internally; we assume it's called correctly.    */
 751 void GC_debug_free_inner(void * p)
 752 {
 753     GC_free_inner(GC_base(p));
 754 }
 755 #endif
 756
 757 void * GC_debug_realloc(void * p, size_t lb, GC_EXTRA_PARAMS)
 758 {
 759     void * base = GC_base(p);
 760     ptr_t clobbered;
 761     void * result;
 762     size_t copy_sz = lb;
 763     size_t old_sz;
 764     hdr * hhdr;
 765
 766     if (p == 0) return(GC_debug_malloc(lb, OPT_RA s, i));
 767     if (base == 0) {
 768         GC_err_printf("Attempt to reallocate invalid pointer %p\n", p);
 769         ABORT("realloc(invalid pointer)");
 770     }
 771     if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
 772         GC_err_printf(
 773                 "GC_debug_realloc called on pointer %p wo debugging info\n", p);
 774         return(GC_realloc(p, lb));
 775     }
 776     hhdr = HDR(base);
 777     switch (hhdr -> hb_obj_kind) {
 778 #    ifdef STUBBORN_ALLOC
 779       case STUBBORN:
 780         result = GC_debug_malloc_stubborn(lb, OPT_RA s, i);
 781         break;
 782 #    endif
 783       case NORMAL:
 784         result = GC_debug_malloc(lb, OPT_RA s, i);
 785         break;
 786       case PTRFREE:
 787         result = GC_debug_malloc_atomic(lb, OPT_RA s, i);
 788         break;
 789       case UNCOLLECTABLE:
 790         result = GC_debug_malloc_uncollectable(lb, OPT_RA s, i);
 791         break;
 792 #    ifdef ATOMIC_UNCOLLECTABLE
 793       case AUNCOLLECTABLE:
 794         result = GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i);
 795         break;
 796 #    endif
 797       default:
 798         GC_err_printf("GC_debug_realloc: encountered bad kind\n");
 799         ABORT("bad kind");
 800     }
 801 #   ifdef SHORT_DBG_HDRS
 802       old_sz = GC_size(base) - sizeof(oh);
 803 #   else
 804       clobbered = GC_check_annotated_obj((oh *)base);
 805       if (clobbered != 0) {
 806         GC_err_printf("GC_debug_realloc: found smashed location at ");
 807         GC_print_smashed_obj(p, clobbered);
 808       }
 809       old_sz = ((oh *)base) -> oh_sz;
 810 #   endif
 811     if (old_sz < copy_sz) copy_sz = old_sz;
 812     if (result == 0) return(0);
 813     BCOPY(p, result,  copy_sz);
 814     GC_debug_free(p);
 815     return(result);
 816 }
 817
 818 #ifndef SHORT_DBG_HDRS
 819
 820 /* List of smashed objects.  We defer printing these, since we can't    */
 821 /* always print them nicely with the allocation lock held.              */
 822 /* We put them here instead of in GC_arrays, since it may be useful to  */
 823 /* be able to look at them with the debugger.                           */
 824 #define MAX_SMASHED 20
 825 ptr_t GC_smashed[MAX_SMASHED];
 826 unsigned GC_n_smashed = 0;
 827
 828 void GC_add_smashed(ptr_t smashed)
 829 {
 830     GC_ASSERT(GC_is_marked(GC_base(smashed)));
 831     GC_smashed[GC_n_smashed] = smashed;
 832     if (GC_n_smashed < MAX_SMASHED - 1) ++GC_n_smashed;
 833       /* In case of overflow, we keep the first MAX_SMASHED-1   */
 834       /* entries plus the last one.                             */
 835     GC_have_errors = TRUE;
 836 }
 837
 838 /* Print all objects on the list.  Clear the list.      */
 839 void GC_print_all_smashed_proc(void)
 840 {
 841     unsigned i;
 842
 843     GC_ASSERT(I_DONT_HOLD_LOCK());
 844     if (GC_n_smashed == 0) return;
 845     GC_err_printf("GC_check_heap_block: found smashed heap objects:\n");
 846     for (i = 0; i < GC_n_smashed; ++i) {
 847         GC_print_smashed_obj(GC_base(GC_smashed[i]), GC_smashed[i]);
 848         GC_smashed[i] = 0;
 849     }
 850     GC_n_smashed = 0;
 851 }
 852
 853 /* Check all marked objects in the given block for validity     */
 854 /* Avoid GC_apply_to_each_object for performance reasons.       */
 855 /*ARGSUSED*/
 856 void GC_check_heap_block(struct hblk *hbp, word dummy)
 857 {
 858     struct hblkhdr * hhdr = HDR(hbp);
 859     size_t sz = hhdr -> hb_sz;
 860     size_t bit_no;
 861     char *p, *plim;
 862
 863     p = hbp->hb_body;
 864     bit_no = 0;
 865     if (sz > MAXOBJBYTES) {
 866         plim = p;
 867     } else {
 868         plim = hbp->hb_body + HBLKSIZE - sz;
 869     }
 870     /* go through all words in block */
 871         while( p <= plim ) {
 872             if( mark_bit_from_hdr(hhdr, bit_no)
 873                 && GC_HAS_DEBUG_INFO((ptr_t)p)) {
 874                 ptr_t clobbered = GC_check_annotated_obj((oh *)p);
 875
 876                 if (clobbered != 0) GC_add_smashed(clobbered);
 877             }
 878             bit_no += MARK_BIT_OFFSET(sz);
 879             p += sz;
 880         }
 881 }
 882
 883
 884 /* This assumes that all accessible objects are marked, and that        */
 885 /* I hold the allocation lock.  Normally called by collector.           */
 886 void GC_check_heap_proc(void)
 887 {
 888 #   ifndef SMALL_CONFIG
 889       /* Ignore gcc no effect warning on the following.         */
 890       GC_STATIC_ASSERT((sizeof(oh) & (GRANULE_BYTES - 1)) == 0);
 891       /* FIXME: Should we check for twice that alignment?       */
 892 #   endif
 893     GC_apply_to_all_blocks(GC_check_heap_block, (word)0);
 894 }
 895
 896 #endif /* !SHORT_DBG_HDRS */
 897
 898 struct closure {
 899     GC_finalization_proc cl_fn;
 900     void * cl_data;
 901 };
 902
 903 void * GC_make_closure(GC_finalization_proc fn, void * data)
 904 {
 905     struct closure * result =
 906 #   ifdef DBG_HDRS_ALL
 907       (struct closure *) GC_debug_malloc(sizeof (struct closure),
 908                                          GC_EXTRAS);
 909 #   else
 910       (struct closure *) GC_malloc(sizeof (struct closure));
 911 #   endif
 912
 913     result -> cl_fn = fn;
 914     result -> cl_data = data;
 915     return((void *)result);
 916 }
 917
 918 void GC_debug_invoke_finalizer(void * obj, void * data)
 919 {
 920     register struct closure * cl = (struct closure *) data;
 921
 922     (*(cl -> cl_fn))((void *)((char *)obj + sizeof(oh)), cl -> cl_data);
 923 }
 924
 925 /* Set ofn and ocd to reflect the values we got back.   */
 926 static void store_old (void *obj, GC_finalization_proc my_old_fn,
 927                        struct closure *my_old_cd, GC_finalization_proc *ofn,
 928                        void **ocd)
 929 {
 930     if (0 != my_old_fn) {
 931       if (my_old_fn != GC_debug_invoke_finalizer) {
 932         GC_err_printf("Debuggable object at %p had non-debug finalizer.\n",
 933                       obj);
 934         /* This should probably be fatal. */
 935       } else {
 936         if (ofn) *ofn = my_old_cd -> cl_fn;
 937         if (ocd) *ocd = my_old_cd -> cl_data;
 938       }
 939     } else {
 940       if (ofn) *ofn = 0;
 941       if (ocd) *ocd = 0;
 942     }
 943 }
 944
 945 void GC_debug_register_finalizer(void * obj, GC_finalization_proc fn,
 946                                  void * cd, GC_finalization_proc *ofn,
 947                                  void * *ocd)
 948 {
 949     GC_finalization_proc my_old_fn;
 950     void * my_old_cd;
 951     ptr_t base = GC_base(obj);
 952     if (0 == base) return;
 953     if ((ptr_t)obj - base != sizeof(oh)) {
 954         GC_err_printf(
 955             "GC_debug_register_finalizer called with non-base-pointer %p\n",
 956             obj);
 957     }
 958     if (0 == fn) {
 959       GC_register_finalizer(base, 0, 0, &my_old_fn, &my_old_cd);
 960     } else {
 961       GC_register_finalizer(base, GC_debug_invoke_finalizer,
 962                             GC_make_closure(fn,cd), &my_old_fn, &my_old_cd);
 963     }
 964     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
 965 }
 966
 967 void GC_debug_register_finalizer_no_order
 968                                     (void * obj, GC_finalization_proc fn,
 969                                      void * cd, GC_finalization_proc *ofn,
 970                                      void * *ocd)
 971 {
 972     GC_finalization_proc my_old_fn;
 973     void * my_old_cd;
 974     ptr_t base = GC_base(obj);
 975     if (0 == base) return;
 976     if ((ptr_t)obj - base != sizeof(oh)) {
 977         GC_err_printf(
 978           "GC_debug_register_finalizer_no_order called with "
 979           "non-base-pointer %p\n",
 980           obj);
 981     }
 982     if (0 == fn) {
 983       GC_register_finalizer_no_order(base, 0, 0, &my_old_fn, &my_old_cd);
 984     } else {
 985       GC_register_finalizer_no_order(base, GC_debug_invoke_finalizer,
 986                                      GC_make_closure(fn,cd), &my_old_fn,
 987                                      &my_old_cd);
 988     }
 989     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
 990 }
 991
 992 void GC_debug_register_finalizer_unreachable
 993                                     (void * obj, GC_finalization_proc fn,
 994                                      void * cd, GC_finalization_proc *ofn,
 995                                      void * *ocd)
 996 {
 997     GC_finalization_proc my_old_fn;
 998     void * my_old_cd;
 999     ptr_t base = GC_base(obj);
1000     if (0 == base) return;
1001     if ((ptr_t)obj - base != sizeof(oh)) {
1002         GC_err_printf(
1003             "GC_debug_register_finalizer_unreachable called with "
1004             "non-base-pointer %p\n",
1005             obj);
1006     }
1007     if (0 == fn) {
1008       GC_register_finalizer_unreachable(base, 0, 0, &my_old_fn, &my_old_cd);
1009     } else {
1010       GC_register_finalizer_unreachable(base, GC_debug_invoke_finalizer,
1011                                         GC_make_closure(fn,cd), &my_old_fn,
1012                                         &my_old_cd);
1013     }
1014     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
1015 }
1016
1017 void GC_debug_register_finalizer_ignore_self
1018                                     (void * obj, GC_finalization_proc fn,
1019                                      void * cd, GC_finalization_proc *ofn,
1020                                      void * *ocd)
1021 {
1022     GC_finalization_proc my_old_fn;
1023     void * my_old_cd;
1024     ptr_t base = GC_base(obj);
1025     if (0 == base) return;
1026     if ((ptr_t)obj - base != sizeof(oh)) {
1027         GC_err_printf(
1028             "GC_debug_register_finalizer_ignore_self called with "
1029             "non-base-pointer %p\n", obj);
1030     }
1031     if (0 == fn) {
1032       GC_register_finalizer_ignore_self(base, 0, 0, &my_old_fn, &my_old_cd);
1033     } else {
1034       GC_register_finalizer_ignore_self(base, GC_debug_invoke_finalizer,
1035                                      GC_make_closure(fn,cd), &my_old_fn,
1036                                      &my_old_cd);
1037     }
1038     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
1039 }
1040
1041 #ifdef GC_ADD_CALLER
1042 # define RA GC_RETURN_ADDR,
1043 #else
1044 # define RA
1045 #endif
1046
1047 void * GC_debug_malloc_replacement(size_t lb)
1048 {
1049     return GC_debug_malloc(lb, RA "unknown", 0);
1050 }
1051
1052 void * GC_debug_realloc_replacement(void *p, size_t lb)
1053 {
1054     return GC_debug_realloc(p, lb, RA "unknown", 0);
1055 }