/* q are pointers to the object base, i.e. pointers to an oh.		*/
static void add_edge(ptr_t p,  ptr_t q)
{
    ptr_t old_back_ptr = GET_OH_BG_PTR(q);
    back_edges * be, *be_cont;
    word i;
    static unsigned random_number = 13;
#   define GOT_LUCKY_NUMBER (((++random_number) & 0x7f) == 0)
      /* A not very random number we use to occasionally allocate a	*/
      /* back_edges structure even for a single backward edge.  This	*/
      /* prevents us from repeatedly tracing back through very long	*/
      /* chains, since we will have some place to store height and	*/
      /* in_progress flags along the way.				*/

    GC_ASSERT(p == GC_base(p) && q == GC_base(q));
    if (!GC_HAS_DEBUG_INFO(q) || !GC_HAS_DEBUG_INFO(p)) {
      /* This is really a misinterpreted free list link, since we saw */
      /* a pointer to a free list.  Dont overwrite it!		      */
      return;
    }
    if (0 == old_back_ptr) {
	SET_OH_BG_PTR(q, p);
	if (GOT_LUCKY_NUMBER) ensure_struct(q);
	return;
    }
    /* Check whether it was already in the list of predecessors. */
      FOR_EACH_PRED(pred, q, { if (p == pred) return; });

//const char *str_dup( const char *str ) {
// permAlloc default: FALSE
const char *str_dup( const char *str, const bool permAlloc ) {
  if (fBootDb || permAlloc )
    return alloc_perm_string(str); // at boot time, we can safely allocate each string permanently.

  nStrDup++;
  char *str_new;

  if ( str[0] == '\0' ) {
    nStrDupEmpty++;

    return &str_empty[0];
  }

  void* dummy = GC_base((void*)str);

  if ( GC_base((void*)str) != NULL ) { // Since strings in the heap cannot be changed, it is ok just to return the pointer.
    nStrDupGC++;

    return str;
  }
  else {
    nStrDupNoGC++;
    sStrDupNoGC += strlen(str)+1;

    str_new = (char *) GC_MALLOC_ATOMIC( strlen(str) + 1 );
    strcpy( str_new, str );
    return str_new;
  }
}

  /* with key are marked.                                           */
  void GC_check_tsd_marks(tsd *key)
  {
    int i;
    tse *p;

    if (!GC_is_marked(GC_base(key))) {
      ABORT("Unmarked thread-specific-data table");
    }
    for (i = 0; i < TS_HASH_SIZE; ++i) {
      for (p = key->hash[i].p; p != 0; p = p -> next) {
        if (!GC_is_marked(GC_base(p))) {
          GC_err_printf("Thread-specific-data entry at %p not marked\n", p);
          ABORT("Unmarked tse");
        }
      }
    }
    for (i = 0; i < TS_CACHE_SIZE; ++i) {
      p = key -> cache[i];
      if (p != &invalid_tse && !GC_is_marked(GC_base(p))) {
        GC_err_printf("Cached thread-specific-data entry at %p not marked\n",
                      p);
        ABORT("Unmarked cached tse");
      }
    }
  }

void GC_CALLBACK pair_dct(void *obj, void *cd)
{
    pair_t p = obj;
    int checksum;

    /* Check that obj and its car and cdr are not trashed. */
#   ifdef DEBUG_DISCLAIM_DESTRUCT
      printf("Destruct %p = (%p, %p)\n",
             (void *)p, (void *)p->car, (void *)p->cdr);
#   endif
    my_assert(GC_base(obj));
    my_assert(is_pair(p));
    my_assert(!p->car || is_pair(p->car));
    my_assert(!p->cdr || is_pair(p->cdr));
    checksum = 782;
    if (p->car) checksum += p->car->checksum;
    if (p->cdr) checksum += p->cdr->checksum;
    my_assert(p->checksum == checksum);

    /* Invalidate it. */
    memset(p->magic, '*', sizeof(p->magic));
    p->checksum = 0;
    p->car = cd;
    p->cdr = NULL;
}

void * GC_debug_realloc(void * p, size_t lb, GC_EXTRA_PARAMS)
{
    void * base = GC_base(p);
    ptr_t clobbered;
    void * result;
    size_t copy_sz = lb;
    size_t old_sz;
    hdr * hhdr;
    
    if (p == 0) return(GC_debug_malloc(lb, OPT_RA s, i));
    if (base == 0) {
        GC_err_printf("Attempt to reallocate invalid pointer %p\n", p);
        ABORT("realloc(invalid pointer)");
    }
    if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
        GC_err_printf(
        	"GC_debug_realloc called on pointer %p wo debugging info\n", p);
        return(GC_realloc(p, lb));
    }
    hhdr = HDR(base);
    switch (hhdr -> hb_obj_kind) {
#    ifdef STUBBORN_ALLOC
      case STUBBORN:
        result = GC_debug_malloc_stubborn(lb, OPT_RA s, i);
        break;
#    endif
      case NORMAL:
        result = GC_debug_malloc(lb, OPT_RA s, i);
        break;
      case PTRFREE:
        result = GC_debug_malloc_atomic(lb, OPT_RA s, i);
        break;
      case UNCOLLECTABLE:
	result = GC_debug_malloc_uncollectable(lb, OPT_RA s, i);
 	break;
#    ifdef ATOMIC_UNCOLLECTABLE
      case AUNCOLLECTABLE:
	result = GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i);
	break;
#    endif
      default:
        GC_err_printf("GC_debug_realloc: encountered bad kind\n");
        ABORT("bad kind");
    }
#   ifdef SHORT_DBG_HDRS
      old_sz = GC_size(base) - sizeof(oh);
#   else
      clobbered = GC_check_annotated_obj((oh *)base);
      if (clobbered != 0) {
        GC_err_printf("GC_debug_realloc: found smashed location at ");
        GC_print_smashed_obj(p, clobbered);
      }
      old_sz = ((oh *)base) -> oh_sz;
#   endif
    if (old_sz < copy_sz) copy_sz = old_sz;
    if (result == 0) return(0);
    BCOPY(p, result,  copy_sz);
    GC_debug_free(p);
    return(result);
}

  /* clobbered_addr.                                                    */
  STATIC void GC_print_smashed_obj(const char *msg, ptr_t p,
                                   ptr_t clobbered_addr)
  {
    oh * ohdr = (oh *)GC_base(p);

    GC_ASSERT(I_DONT_HOLD_LOCK());
#   ifdef LINT2
      if (!ohdr) ABORT("Invalid GC_print_smashed_obj argument");
#   endif
    if (clobbered_addr <= (ptr_t)(&(ohdr -> oh_sz))
        || ohdr -> oh_string == 0) {
        GC_err_printf(
                "%s %p in or near object at %p(<smashed>, appr. sz = %lu)\n",
                msg, clobbered_addr, p,
                (unsigned long)(GC_size((ptr_t)ohdr) - DEBUG_BYTES));
    } else {
        GC_err_printf("%s %p in or near object at %p (%s:%d, sz=%lu)\n",
                msg, clobbered_addr, p,
                (word)(ohdr -> oh_string) < HBLKSIZE ? "(smashed string)" :
                ohdr -> oh_string[0] == '\0' ? "EMPTY(smashed?)" :
                                                ohdr -> oh_string,
                GET_OH_LINENUM(ohdr), (unsigned long)(ohdr -> oh_sz));
        PRINT_CALL_CHAIN(ohdr);
    }
  }

GC_API void GC_CALL GC_debug_register_finalizer_ignore_self
                                    (void * obj, GC_finalization_proc fn,
                                     void * cd, GC_finalization_proc *ofn,
                                     void * *ocd)
{
    GC_finalization_proc my_old_fn = OFN_UNSET;
    void * my_old_cd;
    ptr_t base = GC_base(obj);
    if (0 == base) {
        /* We won't collect it, hence finalizer wouldn't be run. */
        if (ocd) *ocd = 0;
        if (ofn) *ofn = 0;
        return;
    }
    if ((ptr_t)obj - base != sizeof(oh)) {
        GC_err_printf(
            "GC_debug_register_finalizer_ignore_self called with "
            "non-base-pointer %p\n", obj);
    }
    if (0 == fn) {
      GC_register_finalizer_ignore_self(base, 0, 0, &my_old_fn, &my_old_cd);
    } else {
      cd = GC_make_closure(fn, cd);
      if (cd == 0) return; /* out of memory */
      GC_register_finalizer_ignore_self(base, GC_debug_invoke_finalizer,
                                        cd, &my_old_fn, &my_old_cd);
    }
    store_old(obj, my_old_fn, (struct closure *)my_old_cd, ofn, ocd);
}

void GC_default_print_heap_obj_proc(ptr_t p)
{
    ptr_t base = GC_base(p);

    GC_err_printf("start: %p, appr. length: %ld", base,
		  (unsigned long)GC_size(base));
}

/* Explicitly deallocate an object p.                           */
GC_API void GC_CALL GC_free(void * p)
{
    struct hblk *h;
    hdr *hhdr;
    size_t sz; /* In bytes */
    size_t ngranules;   /* sz in granules */
    void **flh;
    int knd;
    struct obj_kind * ok;
    DCL_LOCK_STATE;

    if (p == 0) return;
    /* Required by ANSI.  It's not my fault ...     */
#   ifdef LOG_ALLOCS
    GC_log_printf("GC_free(%p) after GC #%lu\n",
                  p, (unsigned long)GC_gc_no);
#   endif
    h = HBLKPTR(p);
    hhdr = HDR(h);
#   if defined(REDIRECT_MALLOC) && \
        (defined(GC_SOLARIS_THREADS) || defined(GC_LINUX_THREADS) \
         || defined(MSWIN32))
    /* For Solaris, we have to redirect malloc calls during         */
    /* initialization.  For the others, this seems to happen        */
    /* implicitly.                                                  */
    /* Don't try to deallocate that memory.                         */
    if (0 == hhdr) return;
#   endif
    GC_ASSERT(GC_base(p) == p);
    sz = hhdr -> hb_sz;
    ngranules = BYTES_TO_GRANULES(sz);
    knd = hhdr -> hb_obj_kind;
    ok = &GC_obj_kinds[knd];
    if (EXPECT(ngranules <= MAXOBJGRANULES, TRUE)) {
        LOCK();
        GC_bytes_freed += sz;
        if (IS_UNCOLLECTABLE(knd)) GC_non_gc_bytes -= sz;
        /* Its unnecessary to clear the mark bit.  If the       */
        /* object is reallocated, it doesn't matter.  O.w. the  */
        /* collector will do it, since it's on a free list.     */
        if (ok -> ok_init) {
            BZERO((word *)p + 1, sz-sizeof(word));
        }
        flh = &(ok -> ok_freelist[ngranules]);
        obj_link(p) = *flh;
        *flh = (ptr_t)p;
        UNLOCK();
    } else {
        size_t nblocks = OBJ_SZ_TO_BLOCKS(sz);
        LOCK();
        GC_bytes_freed += sz;
        if (IS_UNCOLLECTABLE(knd)) GC_non_gc_bytes -= sz;
        if (nblocks > 1) {
            GC_large_allocd_bytes -= nblocks * HBLKSIZE;
        }
        GC_freehblk(h);
        UNLOCK();
    }
}

  /* Dest can be any address within a heap object.                      */
  GC_API GC_ref_kind GC_CALL GC_get_back_ptr_info(void *dest, void **base_p,
                                                  size_t *offset_p)
  {
    oh * hdr = (oh *)GC_base(dest);
    ptr_t bp;
    ptr_t bp_base;

#   ifdef LINT2
      /* Explicitly instruct the code analysis tool that                */
      /* GC_get_back_ptr_info is not expected to be called with an      */
      /* incorrect "dest" value.                                        */
      if (!hdr) ABORT("Invalid GC_get_back_ptr_info argument");
#   endif
    if (!GC_HAS_DEBUG_INFO((ptr_t) hdr)) return GC_NO_SPACE;
    bp = GC_REVEAL_POINTER(hdr -> oh_back_ptr);
    if (MARKED_FOR_FINALIZATION == bp) return GC_FINALIZER_REFD;
    if (MARKED_FROM_REGISTER == bp) return GC_REFD_FROM_REG;
    if (NOT_MARKED == bp) return GC_UNREFERENCED;
#   if ALIGNMENT == 1
      /* Heuristically try to fix off by 1 errors we introduced by      */
      /* insisting on even addresses.                                   */
      {
        ptr_t alternate_ptr = bp + 1;
        ptr_t target = *(ptr_t *)bp;
        ptr_t alternate_target = *(ptr_t *)alternate_ptr;

        if (alternate_target >= GC_least_plausible_heap_addr
            && alternate_target <= GC_greatest_plausible_heap_addr
            && (target < GC_least_plausible_heap_addr
                || target > GC_greatest_plausible_heap_addr)) {
            bp = alternate_ptr;
        }
      }
#   endif
    bp_base = GC_base(bp);
    if (0 == bp_base) {
      *base_p = bp;
      *offset_p = 0;
      return GC_REFD_FROM_ROOT;
    } else {
      if (GC_HAS_DEBUG_INFO(bp_base)) bp_base += sizeof(oh);
      *base_p = bp_base;
      *offset_p = bp - bp_base;
      return GC_REFD_FROM_HEAP;
    }
  }

  /* Print back trace for p */
  GC_API void GC_CALL GC_print_backtrace(void *p)
  {
    void *current = p;
    int i;
    GC_ref_kind source;
    size_t offset;
    void *base;

    GC_print_heap_obj(GC_base(current));
    GC_err_printf("\n");
    for (i = 0; ; ++i) {
      source = GC_get_back_ptr_info(current, &base, &offset);
      if (GC_UNREFERENCED == source) {
        GC_err_printf("Reference could not be found\n");
        goto out;
      }
      if (GC_NO_SPACE == source) {
        GC_err_printf("No debug info in object: Can't find reference\n");
        goto out;
      }
      GC_err_printf("Reachable via %d levels of pointers from ", i);
      switch(source) {
        case GC_REFD_FROM_ROOT:
          GC_err_printf("root at %p\n\n", base);
          goto out;
        case GC_REFD_FROM_REG:
          GC_err_printf("root in register\n\n");
          goto out;
        case GC_FINALIZER_REFD:
          GC_err_printf("list of finalizable objects\n\n");
          goto out;
        case GC_REFD_FROM_HEAP:
          GC_err_printf("offset %ld in object:\n", (unsigned long)offset);
          /* Take GC_base(base) to get real base, i.e. header. */
          GC_print_heap_obj(GC_base(base));
          GC_err_printf("\n");
          break;
        default:
          GC_err_printf("INTERNAL ERROR: UNEXPECTED SOURCE!!!!\n");
          goto out;
      }
      current = base;
    }
    out:;
  }

void GC_add_smashed(ptr_t smashed)
{
    GC_ASSERT(GC_is_marked(GC_base(smashed)));
    GC_smashed[GC_n_smashed] = smashed;
    if (GC_n_smashed < MAX_SMASHED - 1) ++GC_n_smashed;
      /* In case of overflow, we keep the first MAX_SMASHED-1	*/
      /* entries plus the last one.				*/
    GC_have_errors = TRUE;
}

GC_API void GC_CALL GC_debug_free(void * p)
{
    ptr_t base;
    if (0 == p) return;

    base = GC_base(p);
    if (base == 0) {
      GC_err_printf("Attempt to free invalid pointer %p\n", p);
      ABORT("Invalid pointer passed to free()");
    }
    if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
      GC_err_printf(
               "GC_debug_free called on pointer %p w/o debugging info\n", p);
    } else {
#     ifndef SHORT_DBG_HDRS
        ptr_t clobbered = GC_check_annotated_obj((oh *)base);
        word sz = GC_size(base);
        if (clobbered != 0) {
          GC_have_errors = TRUE;
          if (((oh *)base) -> oh_sz == sz) {
            GC_print_smashed_obj(
                  "GC_debug_free: found previously deallocated (?) object at",
                  p, clobbered);
            return; /* ignore double free */
          } else {
            GC_print_smashed_obj("GC_debug_free: found smashed location at",
                                 p, clobbered);
          }
        }
        /* Invalidate size (mark the object as deallocated) */
        ((oh *)base) -> oh_sz = sz;
#     endif /* SHORT_DBG_HDRS */
    }
    if (GC_find_leak
#       ifndef SHORT_DBG_HDRS
          && ((ptr_t)p - (ptr_t)base != sizeof(oh) || !GC_findleak_delay_free)
#       endif
        ) {
      GC_free(base);
    } else {
      hdr * hhdr = HDR(p);
      if (hhdr -> hb_obj_kind == UNCOLLECTABLE
#         ifdef ATOMIC_UNCOLLECTABLE
            || hhdr -> hb_obj_kind == AUNCOLLECTABLE
#         endif
          ) {
        GC_free(base);
      } else {
        size_t i;
        size_t obj_sz = BYTES_TO_WORDS(hhdr -> hb_sz - sizeof(oh));

        for (i = 0; i < obj_sz; ++i)
          ((word *)p)[i] = GC_FREED_MEM_MARKER;
        GC_ASSERT((word *)p + i == (word *)(base + hhdr -> hb_sz));
      }
    } /* !GC_find_leak */
}

GC_API void * GC_CALL GC_debug_realloc(void * p, size_t lb, GC_EXTRA_PARAMS)
{
    void * base;
    void * result;
    hdr * hhdr;
    if (p == 0)
      return(GC_debug_malloc(lb, OPT_RA s, i));

    base = GC_base(p);
    if (base == 0) {
        GC_err_printf("Attempt to reallocate invalid pointer %p\n", p);
        ABORT("Invalid pointer passed to realloc()");
    }
    if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
        GC_err_printf(
              "GC_debug_realloc called on pointer %p w/o debugging info\n", p);
        return(GC_realloc(p, lb));
    }
    hhdr = HDR(base);
    switch (hhdr -> hb_obj_kind) {
#    ifdef STUBBORN_ALLOC
      case STUBBORN:
        result = GC_debug_malloc_stubborn(lb, OPT_RA s, i);
        break;
#    endif
      case NORMAL:
        result = GC_debug_malloc(lb, OPT_RA s, i);
        break;
      case PTRFREE:
        result = GC_debug_malloc_atomic(lb, OPT_RA s, i);
        break;
      case UNCOLLECTABLE:
        result = GC_debug_malloc_uncollectable(lb, OPT_RA s, i);
        break;
#    ifdef ATOMIC_UNCOLLECTABLE
      case AUNCOLLECTABLE:
        result = GC_debug_malloc_atomic_uncollectable(lb, OPT_RA s, i);
        break;
#    endif
      default:
        result = NULL; /* initialized to prevent warning. */
        GC_err_printf("GC_debug_realloc: encountered bad kind\n");
        ABORT("Bad kind");
    }

    if (result != NULL) {
      size_t old_sz;
#     ifdef SHORT_DBG_HDRS
        old_sz = GC_size(base) - sizeof(oh);
#     else
        old_sz = ((oh *)base) -> oh_sz;
#     endif
      BCOPY(p, result, old_sz < lb ? old_sz : lb);
      GC_debug_free(p);
    }
    return(result);
}

int GC_register_disappearing_link(void * * link)
{
    ptr_t base;
    
    base = (ptr_t)GC_base((void *)link);
    if (base == 0)
    	ABORT("Bad arg to GC_register_disappearing_link");
    return(GC_general_register_disappearing_link(link, base));
}

 /* Generate a random address inside a valid marked heap object. */
 GC_API void * GC_CALL GC_generate_random_valid_address(void)
 {
   ptr_t result;
   ptr_t base;
   do {
     result = GC_generate_random_heap_address();
     base = GC_base(result);
   } while (base == 0 || !GC_is_marked(base));
   return result;
 }

GC_INNER void GC_default_print_heap_obj_proc(ptr_t p)
{
    ptr_t base = (ptr_t)GC_base(p);
    int kind = HDR(base)->hb_obj_kind;

    GC_err_printf("object at %p of appr. %lu bytes (%s)\n",
                  (void *)base, (unsigned long)GC_size(base),
                  kind == PTRFREE ? "atomic" :
                    IS_UNCOLLECTABLE(kind) ? "uncollectable" : "composite");
}

STATIC void GC_add_smashed(ptr_t smashed)
{
    GC_ASSERT(GC_is_marked(GC_base(smashed)));
    /* FIXME: Prevent adding an object while printing smashed list.     */
    GC_smashed[GC_n_smashed] = smashed;
    if (GC_n_smashed < MAX_SMASHED - 1) ++GC_n_smashed;
      /* In case of overflow, we keep the first MAX_SMASHED-1   */
      /* entries plus the last one.                             */
    GC_have_errors = TRUE;
}

void GC_debug_free(void * p)
{
    ptr_t base;
    ptr_t clobbered;
    
    if (0 == p) return;
    base = GC_base(p);
    if (base == 0) {
        GC_err_printf("Attempt to free invalid pointer %p\n", p);
        ABORT("free(invalid pointer)");
    }
    if ((ptr_t)p - (ptr_t)base != sizeof(oh)) {
        GC_err_printf(
        	  "GC_debug_free called on pointer %p wo debugging info\n", p);
    } else {
#     ifndef SHORT_DBG_HDRS
        clobbered = GC_check_annotated_obj((oh *)base);
        if (clobbered != 0) {
          if (((oh *)base) -> oh_sz == GC_size(base)) {
            GC_err_printf(
                  "GC_debug_free: found previously deallocated (?) object at ");
          } else {
            GC_err_printf("GC_debug_free: found smashed location at ");
          }
          GC_print_smashed_obj(p, clobbered);
        }
        /* Invalidate size */
        ((oh *)base) -> oh_sz = GC_size(base);
#     endif /* SHORT_DBG_HDRS */
    }
    if (GC_find_leak) {
        GC_free(base);
    } else {
	hdr * hhdr = HDR(p);
	GC_bool uncollectable = FALSE;

        if (hhdr ->  hb_obj_kind == UNCOLLECTABLE) {
	    uncollectable = TRUE;
	}
#	ifdef ATOMIC_UNCOLLECTABLE
	    if (hhdr ->  hb_obj_kind == AUNCOLLECTABLE) {
		    uncollectable = TRUE;
	    }
#	endif
	if (uncollectable) {
	    GC_free(base);
	} else {
	    size_t i;
	    size_t obj_sz = BYTES_TO_WORDS(hhdr -> hb_sz - sizeof(oh));

	    for (i = 0; i < obj_sz; ++i) ((word *)p)[i] = 0xdeadbeef;
	    GC_ASSERT((word *)p + i == (word *)(base + hhdr -> hb_sz));
	}
    } /* !GC_find_leak */
}

void
cuP_memory_init()
{
    void *ptr;

    cu_debug_assert_once();

    /* Determine size of debug header. */
    ptr = cuD_galloc(1, __FILE__, __LINE__);
    cuD_gc_base_shift = (char *)ptr - (char *)GC_base(ptr);
    cuD_gfree(ptr, __FILE__, __LINE__);
}