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