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-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(IRIX5) || 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 # define CROSSES_HBLK(p, sz) \
 232         (((word)(p + sizeof(oh) + sz - 1) ^ (word)p) >= HBLKSIZE)
 233 /* Store debugging info into p.  Return displaced pointer. */
 234 /* Assumes we don't hold allocation lock.                  */
 235 ptr_t GC_store_debug_info(p, sz, string, integer)
 236 register ptr_t p;       /* base pointer */
 237 word sz;        /* bytes */
 238 GC_CONST char * string;
 239 word integer;
 240 {
 241     register word * result = (word *)((oh *)p + 1);
 242     DCL_LOCK_STATE;
 243
 244     /* There is some argument that we should dissble signals here.      */
 245     /* But that's expensive.  And this way things should only appear    */
 246     /* inconsistent while we're in the handler.                         */
 247     LOCK();
 248     GC_ASSERT(GC_size(p) >= sizeof(oh) + sz);
 249     GC_ASSERT(!(SMALL_OBJ(sz) && CROSSES_HBLK(p, sz)));
 250 #   ifdef KEEP_BACK_PTRS
 251       ((oh *)p) -> oh_back_ptr = HIDE_BACK_PTR(NOT_MARKED);
 252 #   endif
 253 #   ifdef MAKE_BACK_GRAPH
 254       ((oh *)p) -> oh_bg_ptr = HIDE_BACK_PTR((ptr_t)0);
 255 #   endif
 256     ((oh *)p) -> oh_string = string;
 257     ((oh *)p) -> oh_int = integer;
 258 #   ifndef SHORT_DBG_HDRS
 259       ((oh *)p) -> oh_sz = sz;
 260       ((oh *)p) -> oh_sf = START_FLAG ^ (word)result;
 261       ((word *)p)[BYTES_TO_WORDS(GC_size(p))-1] =
 262          result[SIMPLE_ROUNDED_UP_WORDS(sz)] = END_FLAG ^ (word)result;
 263 #   endif
 264     UNLOCK();
 265     return((ptr_t)result);
 266 }
 267
 268 #ifdef DBG_HDRS_ALL
 269 /* Store debugging info into p.  Return displaced pointer.         */
 270 /* This version assumes we do hold the allocation lock.            */
 271 ptr_t GC_store_debug_info_inner(p, sz, string, integer)
 272 register ptr_t p;       /* base pointer */
 273 word sz;        /* bytes */
 274 char * string;
 275 word integer;
 276 {
 277     register word * result = (word *)((oh *)p + 1);
 278
 279     /* There is some argument that we should disable signals here.      */
 280     /* But that's expensive.  And this way things should only appear    */
 281     /* inconsistent while we're in the handler.                         */
 282     GC_ASSERT(GC_size(p) >= sizeof(oh) + sz);
 283     GC_ASSERT(!(SMALL_OBJ(sz) && CROSSES_HBLK(p, sz)));
 284 #   ifdef KEEP_BACK_PTRS
 285       ((oh *)p) -> oh_back_ptr = HIDE_BACK_PTR(NOT_MARKED);
 286 #   endif
 287 #   ifdef MAKE_BACK_GRAPH
 288       ((oh *)p) -> oh_bg_ptr = HIDE_BACK_PTR((ptr_t)0);
 289 #   endif
 290     ((oh *)p) -> oh_string = string;
 291     ((oh *)p) -> oh_int = integer;
 292 #   ifndef SHORT_DBG_HDRS
 293       ((oh *)p) -> oh_sz = sz;
 294       ((oh *)p) -> oh_sf = START_FLAG ^ (word)result;
 295       ((word *)p)[BYTES_TO_WORDS(GC_size(p))-1] =
 296          result[SIMPLE_ROUNDED_UP_WORDS(sz)] = END_FLAG ^ (word)result;
 297 #   endif
 298     return((ptr_t)result);
 299 }
 300 #endif
 301
 302 #ifndef SHORT_DBG_HDRS
 303 /* Check the object with debugging info at ohdr         */
 304 /* return NIL if it's OK.  Else return clobbered        */
 305 /* address.                                             */
 306 ptr_t GC_check_annotated_obj(ohdr)
 307 register 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 void GC_print_obj(p)
 329 ptr_t p;
 330 {
 331     register oh * ohdr = (oh *)GC_base(p);
 332
 333     GC_ASSERT(!I_HOLD_LOCK());
 334     GC_err_printf1("0x%lx (", ((unsigned long)ohdr + sizeof(oh)));
 335     GC_err_puts(ohdr -> oh_string);
 336 #   ifdef SHORT_DBG_HDRS
 337       GC_err_printf1(":%ld)\n", (unsigned long)(ohdr -> oh_int));
 338 #   else
 339       GC_err_printf2(":%ld, sz=%ld)\n", (unsigned long)(ohdr -> oh_int),
 340                                         (unsigned long)(ohdr -> oh_sz));
 341 #   endif
 342     PRINT_CALL_CHAIN(ohdr);
 343 }
 344
 345 # if defined(__STDC__) || defined(__cplusplus)
 346     void GC_debug_print_heap_obj_proc(ptr_t p)
 347 # else
 348     void GC_debug_print_heap_obj_proc(p)
 349     ptr_t p;
 350 # endif
 351 {
 352     GC_ASSERT(!I_HOLD_LOCK());
 353     if (GC_HAS_DEBUG_INFO(p)) {
 354         GC_print_obj(p);
 355     } else {
 356         GC_default_print_heap_obj_proc(p);
 357     }
 358 }
 359
 360 #ifndef SHORT_DBG_HDRS
 361 void GC_print_smashed_obj(p, clobbered_addr)
 362 ptr_t p, clobbered_addr;
 363 {
 364     register oh * ohdr = (oh *)GC_base(p);
 365
 366     GC_ASSERT(!I_HOLD_LOCK());
 367     GC_err_printf2("0x%lx in object at 0x%lx(", (unsigned long)clobbered_addr,
 368                                                 (unsigned long)p);
 369     if (clobbered_addr <= (ptr_t)(&(ohdr -> oh_sz))
 370         || ohdr -> oh_string == 0) {
 371         GC_err_printf1("<smashed>, appr. sz = %ld)\n",
 372                        (GC_size((ptr_t)ohdr) - DEBUG_BYTES));
 373     } else {
 374         if (ohdr -> oh_string[0] == '\0') {
 375             GC_err_puts("EMPTY(smashed?)");
 376         } else {
 377             GC_err_puts(ohdr -> oh_string);
 378         }
 379         GC_err_printf2(":%ld, sz=%ld)\n", (unsigned long)(ohdr -> oh_int),
 380                                           (unsigned long)(ohdr -> oh_sz));
 381         PRINT_CALL_CHAIN(ohdr);
 382     }
 383 }
 384 #endif
 385
 386 void GC_check_heap_proc GC_PROTO((void));
 387
 388 void GC_print_all_smashed_proc GC_PROTO((void));
 389
 390 void GC_do_nothing() {}
 391
 392 void GC_start_debugging()
 393 {
 394 #   ifndef SHORT_DBG_HDRS
 395       GC_check_heap = GC_check_heap_proc;
 396       GC_print_all_smashed = GC_print_all_smashed_proc;
 397 #   else
 398       GC_check_heap = GC_do_nothing;
 399       GC_print_all_smashed = GC_do_nothing;
 400 #   endif
 401     GC_print_heap_obj = GC_debug_print_heap_obj_proc;
 402     GC_debugging_started = TRUE;
 403     GC_register_displacement((word)sizeof(oh));
 404 }
 405
 406 # if defined(__STDC__) || defined(__cplusplus)
 407     void GC_debug_register_displacement(GC_word offset)
 408 # else
 409     void GC_debug_register_displacement(offset)
 410     GC_word offset;
 411 # endif
 412 {
 413     GC_register_displacement(offset);
 414     GC_register_displacement((word)sizeof(oh) + offset);
 415 }
 416
 417 # ifdef __STDC__
 418     GC_PTR GC_debug_malloc(size_t lb, GC_EXTRA_PARAMS)
 419 # else
 420     GC_PTR GC_debug_malloc(lb, s, i)
 421     size_t lb;
 422     char * s;
 423     int i;
 424 #   ifdef GC_ADD_CALLER
 425         --> GC_ADD_CALLER not implemented for K&R C
 426 #   endif
 427 # endif
 428 {
 429     GC_PTR result = GC_malloc(lb + DEBUG_BYTES);
 430
 431     if (result == 0) {
 432         GC_err_printf1("GC_debug_malloc(%ld) returning NIL (",
 433                        (unsigned long) lb);
 434         GC_err_puts(s);
 435         GC_err_printf1(":%ld)\n", (unsigned long)i);
 436         return(0);
 437     }
 438     if (!GC_debugging_started) {
 439         GC_start_debugging();
 440     }
 441     ADD_CALL_CHAIN(result, ra);
 442     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 443 }
 444
 445 # ifdef __STDC__
 446     GC_PTR GC_debug_malloc_ignore_off_page(size_t lb, GC_EXTRA_PARAMS)
 447 # else
 448     GC_PTR GC_debug_malloc_ignore_off_page(lb, s, i)
 449     size_t lb;
 450     char * s;
 451     int i;
 452 #   ifdef GC_ADD_CALLER
 453         --> GC_ADD_CALLER not implemented for K&R C
 454 #   endif
 455 # endif
 456 {
 457     GC_PTR result = GC_malloc_ignore_off_page(lb + DEBUG_BYTES);
 458
 459     if (result == 0) {
 460         GC_err_printf1("GC_debug_malloc_ignore_off_page(%ld) returning NIL (",
 461                        (unsigned long) lb);
 462         GC_err_puts(s);
 463         GC_err_printf1(":%ld)\n", (unsigned long)i);
 464         return(0);
 465     }
 466     if (!GC_debugging_started) {
 467         GC_start_debugging();
 468     }
 469     ADD_CALL_CHAIN(result, ra);
 470     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 471 }
 472
 473 # ifdef __STDC__
 474     GC_PTR GC_debug_malloc_atomic_ignore_off_page(size_t lb, GC_EXTRA_PARAMS)
 475 # else
 476     GC_PTR GC_debug_malloc_atomic_ignore_off_page(lb, s, i)
 477     size_t lb;
 478     char * s;
 479     int i;
 480 #   ifdef GC_ADD_CALLER
 481         --> GC_ADD_CALLER not implemented for K&R C
 482 #   endif
 483 # endif
 484 {
 485     GC_PTR result = GC_malloc_atomic_ignore_off_page(lb + DEBUG_BYTES);
 486
 487     if (result == 0) {
 488         GC_err_printf1("GC_debug_malloc_atomic_ignore_off_page(%ld)"
 489                        " returning NIL (", (unsigned long) lb);
 490         GC_err_puts(s);
 491         GC_err_printf1(":%ld)\n", (unsigned long)i);
 492         return(0);
 493     }
 494     if (!GC_debugging_started) {
 495         GC_start_debugging();
 496     }
 497     ADD_CALL_CHAIN(result, ra);
 498     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 499 }
 500
 501 # ifdef DBG_HDRS_ALL
 502 /*
 503  * An allocation function for internal use.
 504  * Normally internally allocated objects do not have debug information.
 505  * But in this case, we need to make sure that all objects have debug
 506  * headers.
 507  * We assume debugging was started in collector initialization,
 508  * and we already hold the GC lock.
 509  */
 510   GC_PTR GC_debug_generic_malloc_inner(size_t lb, int k)
 511   {
 512     GC_PTR result = GC_generic_malloc_inner(lb + DEBUG_BYTES, k);
 513
 514     if (result == 0) {
 515         GC_err_printf1("GC internal allocation (%ld bytes) returning NIL\n",
 516                        (unsigned long) lb);
 517         return(0);
 518     }
 519     ADD_CALL_CHAIN(result, GC_RETURN_ADDR);
 520     return (GC_store_debug_info_inner(result, (word)lb, "INTERNAL", (word)0));
 521   }
 522
 523   GC_PTR GC_debug_generic_malloc_inner_ignore_off_page(size_t lb, int k)
 524   {
 525     GC_PTR result = GC_generic_malloc_inner_ignore_off_page(
 526                                                 lb + DEBUG_BYTES, k);
 527
 528     if (result == 0) {
 529         GC_err_printf1("GC internal allocation (%ld 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 # endif
 537
 538 #ifdef STUBBORN_ALLOC
 539 # ifdef __STDC__
 540     GC_PTR GC_debug_malloc_stubborn(size_t lb, GC_EXTRA_PARAMS)
 541 # else
 542     GC_PTR GC_debug_malloc_stubborn(lb, s, i)
 543     size_t lb;
 544     char * s;
 545     int i;
 546 # endif
 547 {
 548     GC_PTR result = GC_malloc_stubborn(lb + DEBUG_BYTES);
 549
 550     if (result == 0) {
 551         GC_err_printf1("GC_debug_malloc(%ld) returning NIL (",
 552                        (unsigned long) lb);
 553         GC_err_puts(s);
 554         GC_err_printf1(":%ld)\n", (unsigned long)i);
 555         return(0);
 556     }
 557     if (!GC_debugging_started) {
 558         GC_start_debugging();
 559     }
 560     ADD_CALL_CHAIN(result, ra);
 561     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 562 }
 563
 564 void GC_debug_change_stubborn(p)
 565 GC_PTR p;
 566 {
 567     register GC_PTR q = GC_base(p);
 568     register hdr * hhdr;
 569
 570     if (q == 0) {
 571         GC_err_printf1("Bad argument: 0x%lx to GC_debug_change_stubborn\n",
 572                        (unsigned long) p);
 573         ABORT("GC_debug_change_stubborn: bad arg");
 574     }
 575     hhdr = HDR(q);
 576     if (hhdr -> hb_obj_kind != STUBBORN) {
 577         GC_err_printf1("GC_debug_change_stubborn arg not stubborn: 0x%lx\n",
 578                        (unsigned long) p);
 579         ABORT("GC_debug_change_stubborn: arg not stubborn");
 580     }
 581     GC_change_stubborn(q);
 582 }
 583
 584 void GC_debug_end_stubborn_change(p)
 585 GC_PTR p;
 586 {
 587     register GC_PTR q = GC_base(p);
 588     register hdr * hhdr;
 589
 590     if (q == 0) {
 591         GC_err_printf1("Bad argument: 0x%lx to GC_debug_end_stubborn_change\n",
 592                        (unsigned long) p);
 593         ABORT("GC_debug_end_stubborn_change: bad arg");
 594     }
 595     hhdr = HDR(q);
 596     if (hhdr -> hb_obj_kind != STUBBORN) {
 597         GC_err_printf1("debug_end_stubborn_change arg not stubborn: 0x%lx\n",
 598                        (unsigned long) p);
 599         ABORT("GC_debug_end_stubborn_change: arg not stubborn");
 600     }
 601     GC_end_stubborn_change(q);
 602 }
 603
 604 #else /* !STUBBORN_ALLOC */
 605
 606 # ifdef __STDC__
 607     GC_PTR GC_debug_malloc_stubborn(size_t lb, GC_EXTRA_PARAMS)
 608 # else
 609     GC_PTR GC_debug_malloc_stubborn(lb, s, i)
 610     size_t lb;
 611     char * s;
 612     int i;
 613 # endif
 614 {
 615     return GC_debug_malloc(lb, OPT_RA s, i);
 616 }
 617
 618 void GC_debug_change_stubborn(p)
 619 GC_PTR p;
 620 {
 621 }
 622
 623 void GC_debug_end_stubborn_change(p)
 624 GC_PTR p;
 625 {
 626 }
 627
 628 #endif /* !STUBBORN_ALLOC */
 629
 630 # ifdef __STDC__
 631     GC_PTR GC_debug_malloc_atomic(size_t lb, GC_EXTRA_PARAMS)
 632 # else
 633     GC_PTR GC_debug_malloc_atomic(lb, s, i)
 634     size_t lb;
 635     char * s;
 636     int i;
 637 # endif
 638 {
 639     GC_PTR result = GC_malloc_atomic(lb + DEBUG_BYTES);
 640
 641     if (result == 0) {
 642         GC_err_printf1("GC_debug_malloc_atomic(%ld) returning NIL (",
 643                       (unsigned long) lb);
 644         GC_err_puts(s);
 645         GC_err_printf1(":%ld)\n", (unsigned long)i);
 646         return(0);
 647     }
 648     if (!GC_debugging_started) {
 649         GC_start_debugging();
 650     }
 651     ADD_CALL_CHAIN(result, ra);
 652     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 653 }
 654
 655 # ifdef __STDC__
 656     GC_PTR GC_debug_malloc_uncollectable(size_t lb, GC_EXTRA_PARAMS)
 657 # else
 658     GC_PTR GC_debug_malloc_uncollectable(lb, s, i)
 659     size_t lb;
 660     char * s;
 661     int i;
 662 # endif
 663 {
 664     GC_PTR result = GC_malloc_uncollectable(lb + UNCOLLECTABLE_DEBUG_BYTES);
 665
 666     if (result == 0) {
 667         GC_err_printf1("GC_debug_malloc_uncollectable(%ld) returning NIL (",
 668                       (unsigned long) lb);
 669         GC_err_puts(s);
 670         GC_err_printf1(":%ld)\n", (unsigned long)i);
 671         return(0);
 672     }
 673     if (!GC_debugging_started) {
 674         GC_start_debugging();
 675     }
 676     ADD_CALL_CHAIN(result, ra);
 677     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 678 }
 679
 680 #ifdef ATOMIC_UNCOLLECTABLE
 681 # ifdef __STDC__
 682     GC_PTR GC_debug_malloc_atomic_uncollectable(size_t lb, GC_EXTRA_PARAMS)
 683 # else
 684     GC_PTR GC_debug_malloc_atomic_uncollectable(lb, s, i)
 685     size_t lb;
 686     char * s;
 687     int i;
 688 # endif
 689 {
 690     GC_PTR result =
 691         GC_malloc_atomic_uncollectable(lb + UNCOLLECTABLE_DEBUG_BYTES);
 692
 693     if (result == 0) {
 694         GC_err_printf1(
 695                 "GC_debug_malloc_atomic_uncollectable(%ld) returning NIL (",
 696                 (unsigned long) lb);
 697         GC_err_puts(s);
 698         GC_err_printf1(":%ld)\n", (unsigned long)i);
 699         return(0);
 700     }
 701     if (!GC_debugging_started) {
 702         GC_start_debugging();
 703     }
 704     ADD_CALL_CHAIN(result, ra);
 705     return (GC_store_debug_info(result, (word)lb, s, (word)i));
 706 }
 707 #endif /* ATOMIC_UNCOLLECTABLE */
 708
 709 # ifdef __STDC__
 710     void GC_debug_free(GC_PTR p)
 711 # else
 712     void GC_debug_free(p)
 713     GC_PTR p;
 714 # endif
 715 {
 716     register GC_PTR base;
 717     register ptr_t clobbered;
 718
 719     if (0 == p) return;
 720     base = GC_base(p);
 721     if (base == 0) {
 722         GC_err_printf1("Attempt to free invalid pointer %lx\n",
 723                        (unsigned long)p);
 724         ABORT("free(invalid pointer)");
 725     }
 726     if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
 727         GC_err_printf1(
 728                   "GC_debug_free called on pointer %lx wo debugging info\n",
 729                   (unsigned long)p);
 730     } else {
 731 #     ifndef SHORT_DBG_HDRS
 732         clobbered = GC_check_annotated_obj((oh *)base);
 733         if (clobbered != 0) {
 734           if (((oh *)base) -> oh_sz == GC_size(base)) {
 735             GC_err_printf0(
 736                   "GC_debug_free: found previously deallocated (?) object at ");
 737           } else {
 738             GC_err_printf0("GC_debug_free: found smashed location at ");
 739           }
 740           GC_print_smashed_obj(p, clobbered);
 741         }
 742         /* Invalidate size */
 743         ((oh *)base) -> oh_sz = GC_size(base);
 744 #     endif /* SHORT_DBG_HDRS */
 745     }
 746     if (GC_find_leak) {
 747         GC_free(base);
 748     } else {
 749         register hdr * hhdr = HDR(p);
 750         GC_bool uncollectable = FALSE;
 751
 752         if (hhdr ->  hb_obj_kind == UNCOLLECTABLE) {
 753             uncollectable = TRUE;
 754         }
 755 #       ifdef ATOMIC_UNCOLLECTABLE
 756             if (hhdr ->  hb_obj_kind == AUNCOLLECTABLE) {
 757                     uncollectable = TRUE;
 758             }
 759 #       endif
 760         if (uncollectable) GC_free(base);
 761     } /* !GC_find_leak */
 762 }
 763
 764 #ifdef THREADS
 765
 766 extern void GC_free_inner(GC_PTR p);
 767
 768 /* Used internally; we assume it's called correctly.    */
 769 void GC_debug_free_inner(GC_PTR p)
 770 {
 771     GC_free_inner(GC_base(p));
 772 }
 773 #endif
 774
 775 # ifdef __STDC__
 776     GC_PTR GC_debug_realloc(GC_PTR p, size_t lb, GC_EXTRA_PARAMS)
 777 # else
 778     GC_PTR GC_debug_realloc(p, lb, s, i)
 779     GC_PTR p;
 780     size_t lb;
 781     char *s;
 782     int i;
 783 # endif
 784 {
 785     register GC_PTR base = GC_base(p);
 786     register ptr_t clobbered;
 787     register GC_PTR result;
 788     register size_t copy_sz = lb;
 789     register size_t old_sz;
 790     register hdr * hhdr;
 791
 792     if (p == 0) return(GC_debug_malloc(lb, OPT_RA s, i));
 793     if (base == 0) {
 794         GC_err_printf1(
 795               "Attempt to reallocate invalid pointer %lx\n", (unsigned long)p);
 796         ABORT("realloc(invalid pointer)");
 797     }
 798     if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
 799         GC_err_printf1(
 800                 "GC_debug_realloc called on pointer %lx wo debugging info\n",
 801                 (unsigned long)p);
 802         return(GC_realloc(p, lb));
 803     }
 804     hhdr = HDR(base);
 805     switch (hhdr -> hb_obj_kind) {
 806 #    ifdef STUBBORN_ALLOC
 807       case STUBBORN:
 808         result = GC_debug_malloc_stubborn(lb, OPT_RA s, i);
 809         break;
 810 #    endif
 811       case NORMAL:
 812         result = GC_debug_malloc(lb, OPT_RA s, i);
 813         break;
 814       case PTRFREE:
 815         result = GC_debug_malloc_atomic(lb, OPT_RA s, i);
 816         break;
 817       case UNCOLLECTABLE:
 818         result = GC_debug_malloc_uncollectable(lb, OPT_RA s, i);
 819         break;
 820 #    ifdef ATOMIC_UNCOLLECTABLE
 821       case AUNCOLLECTABLE:
 822         result = GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i);
 823         break;
 824 #    endif
 825       default:
 826         GC_err_printf0("GC_debug_realloc: encountered bad kind\n");
 827         ABORT("bad kind");
 828     }
 829 #   ifdef SHORT_DBG_HDRS
 830       old_sz = GC_size(base) - sizeof(oh);
 831 #   else
 832       clobbered = GC_check_annotated_obj((oh *)base);
 833       if (clobbered != 0) {
 834         GC_err_printf0("GC_debug_realloc: found smashed location at ");
 835         GC_print_smashed_obj(p, clobbered);
 836       }
 837       old_sz = ((oh *)base) -> oh_sz;
 838 #   endif
 839     if (old_sz < copy_sz) copy_sz = old_sz;
 840     if (result == 0) return(0);
 841     BCOPY(p, result,  copy_sz);
 842     GC_debug_free(p);
 843     return(result);
 844 }
 845
 846 #ifndef SHORT_DBG_HDRS
 847
 848 /* List of smashed objects.  We defer printing these, since we can't    */
 849 /* always print them nicely with the allocation lock held.              */
 850 /* We put them here instead of in GC_arrays, since it may be useful to  */
 851 /* be able to look at them with the debugger.                           */
 852 #define MAX_SMASHED 20
 853 ptr_t GC_smashed[MAX_SMASHED];
 854 unsigned GC_n_smashed = 0;
 855
 856 # if defined(__STDC__) || defined(__cplusplus)
 857     void GC_add_smashed(ptr_t smashed)
 858 # else
 859     void GC_add_smashed(smashed)
 860     ptr_t smashed;
 861 #endif
 862 {
 863     GC_ASSERT(GC_is_marked(GC_base(smashed)));
 864     GC_smashed[GC_n_smashed] = smashed;
 865     if (GC_n_smashed < MAX_SMASHED - 1) ++GC_n_smashed;
 866       /* In case of overflow, we keep the first MAX_SMASHED-1   */
 867       /* entries plus the last one.                             */
 868     GC_have_errors = TRUE;
 869 }
 870
 871 /* Print all objects on the list.  Clear the list.      */
 872 void GC_print_all_smashed_proc ()
 873 {
 874     unsigned i;
 875
 876     GC_ASSERT(!I_HOLD_LOCK());
 877     if (GC_n_smashed == 0) return;
 878     GC_err_printf0("GC_check_heap_block: found smashed heap objects:\n");
 879     for (i = 0; i < GC_n_smashed; ++i) {
 880         GC_print_smashed_obj(GC_base(GC_smashed[i]), GC_smashed[i]);
 881         GC_smashed[i] = 0;
 882     }
 883     GC_n_smashed = 0;
 884 }
 885
 886 /* Check all marked objects in the given block for validity */
 887 /*ARGSUSED*/
 888 # if defined(__STDC__) || defined(__cplusplus)
 889     void GC_check_heap_block(register struct hblk *hbp, word dummy)
 890 # else
 891     void GC_check_heap_block(hbp, dummy)
 892     register struct hblk *hbp;  /* ptr to current heap block            */
 893     word dummy;
 894 # endif
 895 {
 896     register struct hblkhdr * hhdr = HDR(hbp);
 897     register word sz = hhdr -> hb_sz;
 898     register int word_no;
 899     register word *p, *plim;
 900
 901     p = (word *)(hbp->hb_body);
 902     word_no = 0;
 903     if (sz > MAXOBJSZ) {
 904         plim = p;
 905     } else {
 906         plim = (word *)((((word)hbp) + HBLKSIZE) - WORDS_TO_BYTES(sz));
 907     }
 908     /* go through all words in block */
 909         while( p <= plim ) {
 910             if( mark_bit_from_hdr(hhdr, word_no)
 911                 && GC_HAS_DEBUG_INFO((ptr_t)p)) {
 912                 ptr_t clobbered = GC_check_annotated_obj((oh *)p);
 913
 914                 if (clobbered != 0) GC_add_smashed(clobbered);
 915             }
 916             word_no += sz;
 917             p += sz;
 918         }
 919 }
 920
 921
 922 /* This assumes that all accessible objects are marked, and that        */
 923 /* I hold the allocation lock.  Normally called by collector.           */
 924 void GC_check_heap_proc()
 925 {
 926 #   ifndef SMALL_CONFIG
 927 #     ifdef ALIGN_DOUBLE
 928         GC_STATIC_ASSERT((sizeof(oh) & (2 * sizeof(word) - 1)) == 0);
 929 #     else
 930         GC_STATIC_ASSERT((sizeof(oh) & (sizeof(word) - 1)) == 0);
 931 #     endif
 932 #   endif
 933     GC_apply_to_all_blocks(GC_check_heap_block, (word)0);
 934 }
 935
 936 #endif /* !SHORT_DBG_HDRS */
 937
 938 struct closure {
 939     GC_finalization_proc cl_fn;
 940     GC_PTR cl_data;
 941 };
 942
 943 # ifdef __STDC__
 944     void * GC_make_closure(GC_finalization_proc fn, void * data)
 945 # else
 946     GC_PTR GC_make_closure(fn, data)
 947     GC_finalization_proc fn;
 948     GC_PTR data;
 949 # endif
 950 {
 951     struct closure * result =
 952 #   ifdef DBG_HDRS_ALL
 953       (struct closure *) GC_debug_malloc(sizeof (struct closure),
 954                                          GC_EXTRAS);
 955 #   else
 956       (struct closure *) GC_malloc(sizeof (struct closure));
 957 #   endif
 958
 959     result -> cl_fn = fn;
 960     result -> cl_data = data;
 961     return((GC_PTR)result);
 962 }
 963
 964 # ifdef __STDC__
 965     void GC_debug_invoke_finalizer(void * obj, void * data)
 966 # else
 967     void GC_debug_invoke_finalizer(obj, data)
 968     char * obj;
 969     char * data;
 970 # endif
 971 {
 972     register struct closure * cl = (struct closure *) data;
 973
 974     (*(cl -> cl_fn))((GC_PTR)((char *)obj + sizeof(oh)), cl -> cl_data);
 975 }
 976
 977 /* Set ofn and ocd to reflect the values we got back.   */
 978 static void store_old (obj, my_old_fn, my_old_cd, ofn, ocd)
 979 GC_PTR obj;
 980 GC_finalization_proc my_old_fn;
 981 struct closure * my_old_cd;
 982 GC_finalization_proc *ofn;
 983 GC_PTR *ocd;
 984 {
 985     if (0 != my_old_fn) {
 986       if (my_old_fn != GC_debug_invoke_finalizer) {
 987         GC_err_printf1("Debuggable object at 0x%lx had non-debug finalizer.\n",
 988                        obj);
 989         /* This should probably be fatal. */
 990       } else {
 991         if (ofn) *ofn = my_old_cd -> cl_fn;
 992         if (ocd) *ocd = my_old_cd -> cl_data;
 993       }
 994     } else {
 995       if (ofn) *ofn = 0;
 996       if (ocd) *ocd = 0;
 997     }
 998 }
 999
1000 # ifdef __STDC__
1001     void GC_debug_register_finalizer(GC_PTR obj, GC_finalization_proc fn,
1002                                      GC_PTR cd, GC_finalization_proc *ofn,
1003                                      GC_PTR *ocd)
1004 # else
1005     void GC_debug_register_finalizer(obj, fn, cd, ofn, ocd)
1006     GC_PTR obj;
1007     GC_finalization_proc fn;
1008     GC_PTR cd;
1009     GC_finalization_proc *ofn;
1010     GC_PTR *ocd;
1011 # endif
1012 {
1013     GC_finalization_proc my_old_fn;
1014     GC_PTR my_old_cd;
1015     ptr_t base = GC_base(obj);
1016     if (0 == base || (ptr_t)obj - base != sizeof(oh)) {
1017         GC_err_printf1(
1018             "GC_debug_register_finalizer called with non-base-pointer 0x%lx\n",
1019             obj);
1020     }
1021     if (0 == fn) {
1022       GC_register_finalizer(base, 0, 0, &my_old_fn, &my_old_cd);
1023     } else {
1024       GC_register_finalizer(base, GC_debug_invoke_finalizer,
1025                             GC_make_closure(fn,cd), &my_old_fn, &my_old_cd);
1026     }
1027     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
1028 }
1029
1030 # ifdef __STDC__
1031     void GC_debug_register_finalizer_no_order
1032                                     (GC_PTR obj, GC_finalization_proc fn,
1033                                      GC_PTR cd, GC_finalization_proc *ofn,
1034                                      GC_PTR *ocd)
1035 # else
1036     void GC_debug_register_finalizer_no_order
1037                                     (obj, fn, cd, ofn, ocd)
1038     GC_PTR obj;
1039     GC_finalization_proc fn;
1040     GC_PTR cd;
1041     GC_finalization_proc *ofn;
1042     GC_PTR *ocd;
1043 # endif
1044 {
1045     GC_finalization_proc my_old_fn;
1046     GC_PTR my_old_cd;
1047     ptr_t base = GC_base(obj);
1048     if (0 == base || (ptr_t)obj - base != sizeof(oh)) {
1049         GC_err_printf1(
1050           "GC_debug_register_finalizer_no_order called with non-base-pointer 0x%lx\n",
1051           obj);
1052     }
1053     if (0 == fn) {
1054       GC_register_finalizer_no_order(base, 0, 0, &my_old_fn, &my_old_cd);
1055     } else {
1056       GC_register_finalizer_no_order(base, GC_debug_invoke_finalizer,
1057                                      GC_make_closure(fn,cd), &my_old_fn,
1058                                      &my_old_cd);
1059     }
1060     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
1061  }
1062
1063 # ifdef __STDC__
1064     void GC_debug_register_finalizer_ignore_self
1065                                     (GC_PTR obj, GC_finalization_proc fn,
1066                                      GC_PTR cd, GC_finalization_proc *ofn,
1067                                      GC_PTR *ocd)
1068 # else
1069     void GC_debug_register_finalizer_ignore_self
1070                                     (obj, fn, cd, ofn, ocd)
1071     GC_PTR obj;
1072     GC_finalization_proc fn;
1073     GC_PTR cd;
1074     GC_finalization_proc *ofn;
1075     GC_PTR *ocd;
1076 # endif
1077 {
1078     GC_finalization_proc my_old_fn;
1079     GC_PTR my_old_cd;
1080     ptr_t base = GC_base(obj);
1081     if (0 == base || (ptr_t)obj - base != sizeof(oh)) {
1082         GC_err_printf1(
1083             "GC_debug_register_finalizer_ignore_self called with non-base-pointer 0x%lx\n",
1084             obj);
1085     }
1086     if (0 == fn) {
1087       GC_register_finalizer_ignore_self(base, 0, 0, &my_old_fn, &my_old_cd);
1088     } else {
1089       GC_register_finalizer_ignore_self(base, GC_debug_invoke_finalizer,
1090                                      GC_make_closure(fn,cd), &my_old_fn,
1091                                      &my_old_cd);
1092     }
1093     store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
1094 }
1095
1096 #ifdef GC_ADD_CALLER
1097 # define RA GC_RETURN_ADDR,
1098 #else
1099 # define RA
1100 #endif
1101
1102 GC_PTR GC_debug_malloc_replacement(lb)
1103 size_t lb;
1104 {
1105     return GC_debug_malloc(lb, RA "unknown", 0);
1106 }
1107
1108 GC_PTR GC_debug_realloc_replacement(p, lb)
1109 GC_PTR p;
1110 size_t lb;
1111 {
1112     return GC_debug_realloc(p, lb, RA "unknown", 0);
1113 }