typd_mlc.c

/*
 * Copyright (c) 1991-1994 by Xerox Corporation.  All rights reserved.
 * Copyright (c) 1999-2000 by Hewlett-Packard Company.  All rights reserved.
 * Copyright (c) 2008-2022 Ivan Maidanski
 *
 * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
 * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
 *
 * Permission is hereby granted to use or copy this program
 * for any purpose, provided the above notices are retained on all copies.
 * Permission to modify the code and to distribute modified code is granted,
 * provided the above notices are retained, and a notice that the code was
 * modified is included with the above copyright notice.
 */

#include "private/gc_pmark.h"

/*
 * Some simple primitives for allocation with explicit type information.
 * Simple objects are allocated such that they contain a GC_descr at the
 * end (in the last allocated word).  This descriptor may be a procedure
 * which then examines an extended descriptor passed as its environment.
 *
 * Arrays are treated as simple objects if they have sufficiently simple
 * structure.  Otherwise they are allocated from an array kind that supplies
 * a special mark procedure.  These arrays contain a pointer to a
 * complex_descriptor as their last "pointer-sized" word.
 * This is done because the environment field is too small, and the collector
 * must trace the complex_descriptor.
 *
 * Note that descriptors inside objects may appear cleared, if we encounter
 * a false reference to an object on a free list.  In the case of a simple
 * object, this is OK, since a zero descriptor corresponds to examining no
 * fields.  In the complex_descriptor case, we explicitly check for that case.
 *
 * MAJOR PARTS OF THIS CODE HAVE NOT BEEN TESTED AT ALL and are not testable,
 * since they are not accessible through the current interface.
 */

#include "gc/gc_typed.h"

/* Object kind for objects with indirect (possibly extended) descriptors. */
STATIC int GC_explicit_kind = 0;

/* Object kind for objects with complex descriptors and GC_array_mark_proc. */
STATIC int GC_array_kind = 0;

#define ED_INITIAL_SIZE 100

/* Indices of the typed mark procedures.        */
STATIC unsigned GC_typed_mark_proc_index = 0;
STATIC unsigned GC_array_mark_proc_index = 0;

STATIC void GC_push_typed_structures_proc(void)
{
  GC_PUSH_ALL_SYM(GC_ext_descriptors);
}

/* Add a multi-word bitmap to GC_ext_descriptors arrays.        */
/* Returns starting index on success, -1 otherwise.             */
STATIC signed_word GC_add_ext_descriptor(const word * bm, size_t nbits)
{
    signed_word result;
    size_t i;
    size_t nwords = divWORDSZ(nbits + CPP_WORDSZ-1);

    LOCK();
    while (EXPECT(GC_avail_descr + nwords >= GC_ed_size, FALSE)) {
        typed_ext_descr_t *newExtD;
        size_t new_size;
        size_t ed_size = GC_ed_size;

        if (0 == ed_size) {
            GC_ASSERT(ADDR(&GC_ext_descriptors) % sizeof(ptr_t) == 0);
            GC_push_typed_structures = GC_push_typed_structures_proc;
            UNLOCK();
            new_size = ED_INITIAL_SIZE;
        } else {
            UNLOCK();
            new_size = 2 * ed_size;
            if (new_size > MAX_ENV) return -1;
        }
        newExtD = (typed_ext_descr_t*)GC_malloc_atomic(new_size
                                                * sizeof(typed_ext_descr_t));
        if (NULL == newExtD)
            return -1;
        LOCK();
        if (ed_size == GC_ed_size) {
            if (GC_avail_descr != 0) {
                BCOPY(GC_ext_descriptors, newExtD,
                      GC_avail_descr * sizeof(typed_ext_descr_t));
            }
            GC_ed_size = new_size;
            GC_ext_descriptors = newExtD;
        } else {
            /* Another thread is already resized it in the meantime.    */
        }
    }
    result = (signed_word)GC_avail_descr;
    for (i = 0; i < nwords - 1; i++) {
        GC_ext_descriptors[(size_t)result + i].ed_bitmap = bm[i];
        GC_ext_descriptors[(size_t)result + i].ed_continued = TRUE;
    }
    /* Clear irrelevant (highest) bits for the last element.    */
    GC_ext_descriptors[(size_t)result + i].ed_bitmap =
                bm[i] & (GC_WORD_MAX >> (nwords * CPP_WORDSZ - nbits));
    GC_ext_descriptors[(size_t)result + i].ed_continued = FALSE;
    GC_avail_descr += nwords;
    GC_ASSERT(result >= 0);
    UNLOCK();
    return result;
}

/* Table of bitmap descriptors for n pointer-long all-pointer objects.  */
STATIC GC_descr GC_bm_table[CPP_WORDSZ / 2];

/* Return a descriptor for the concatenation of 2 objects, each one is  */
/* lpw pointers long and described by descriptor d.  The result is      */
/* known to be short enough to fit into a bitmap descriptor.            */
/* d is a GC_DS_LENGTH or GC_DS_BITMAP descriptor.                      */
STATIC GC_descr GC_double_descr(GC_descr d, size_t lpw)
{
    GC_ASSERT(GC_bm_table[0] == GC_DS_BITMAP); /* bm table is initialized */
    if ((d & GC_DS_TAGS) == GC_DS_LENGTH) {
        d = GC_bm_table[BYTES_TO_PTRS(d)];
    }
    d |= (d & ~(GC_descr)GC_DS_TAGS) >> lpw;
    return d;
}

STATIC mse *GC_CALLBACK GC_typed_mark_proc(word *addr, mse *mark_stack_top,
                                           mse *mark_stack_limit, word env);

STATIC mse *GC_CALLBACK GC_array_mark_proc(word *addr, mse *mark_stack_top,
                                           mse *mark_stack_limit, word env);

STATIC void GC_init_explicit_typing(void)
{
    unsigned i;

    /* Set up object kind with simple indirect descriptor.      */
    /* Descriptor is in the last word of the object.            */
    GC_typed_mark_proc_index = GC_new_proc_inner(GC_typed_mark_proc);
    GC_explicit_kind = (int)GC_new_kind_inner(GC_new_free_list_inner(),
                            (PTRS_TO_BYTES(GC_WORD_MAX) | GC_DS_PER_OBJECT),
                            TRUE, TRUE);

    /* Set up object kind with array descriptor. */
    GC_array_mark_proc_index = GC_new_proc_inner(GC_array_mark_proc);
    GC_array_kind = (int)GC_new_kind_inner(GC_new_free_list_inner(),
                            GC_MAKE_PROC(GC_array_mark_proc_index, 0),
                            FALSE, TRUE);

    GC_bm_table[0] = GC_DS_BITMAP;
    for (i = 1; i < CPP_WORDSZ / 2; i++) {
      GC_bm_table[i] = (GC_WORD_MAX << (CPP_WORDSZ - i)) | GC_DS_BITMAP;
    }
}

STATIC mse *GC_CALLBACK GC_typed_mark_proc(word *addr, mse *mark_stack_top,
                                           mse *mark_stack_limit, word env)
{
    word bm;
    ptr_t current_p = (ptr_t)addr;
    ptr_t greatest_ha = (ptr_t)GC_greatest_plausible_heap_addr;
    ptr_t least_ha = (ptr_t)GC_least_plausible_heap_addr;
    DECLARE_HDR_CACHE;

    /* The allocator lock is held by the collection initiating thread.  */
    GC_ASSERT(GC_get_parallel() || I_HOLD_LOCK());
    bm = GC_ext_descriptors[env].ed_bitmap;

    INIT_HDR_CACHE;
    for (; bm != 0; bm >>= 1, current_p += sizeof(ptr_t)) {
        if (bm & 1) {
            ptr_t q;

            LOAD_PTR_OR_CONTINUE(q, current_p);
            FIXUP_POINTER(q);
            if (ADDR_LT(least_ha, q) && ADDR_LT(q, greatest_ha)) {
                PUSH_CONTENTS(q, mark_stack_top, mark_stack_limit, current_p);
            }
        }
    }
    if (GC_ext_descriptors[env].ed_continued) {
        /* Push an entry with the rest of the descriptor back onto the  */
        /* stack.  Thus we never do too much work at once.  Note that   */
        /* we also can't overflow the mark stack unless we actually     */
        /* mark something.                                              */
        mark_stack_top = GC_custom_push_proc(
                            GC_MAKE_PROC(GC_typed_mark_proc_index, env + 1),
                            (ptr_t *)addr + CPP_WORDSZ, mark_stack_top,
                            mark_stack_limit);
    }
    return mark_stack_top;
}

GC_API GC_descr GC_CALL GC_make_descriptor(const GC_word * bm, size_t len)
{
    signed_word last_set_bit = (signed_word)len - 1;
    GC_descr d;

#   if defined(AO_HAVE_load_acquire) && defined(AO_HAVE_store_release)
      if (!EXPECT(AO_load_acquire(&GC_explicit_typing_initialized), TRUE)) {
        LOCK();
        if (!GC_explicit_typing_initialized) {
          GC_init_explicit_typing();
          AO_store_release(&GC_explicit_typing_initialized, TRUE);
        }
        UNLOCK();
      }
#   else
      LOCK();
      if (!EXPECT(GC_explicit_typing_initialized, TRUE)) {
        GC_init_explicit_typing();
        GC_explicit_typing_initialized = TRUE;
      }
      UNLOCK();
#   endif

    while (last_set_bit >= 0 && !GC_get_bit(bm, (word)last_set_bit))
      last_set_bit--;
    if (last_set_bit < 0) {
      /* No pointers.   */
      return 0;
    }

#   if ALIGNMENT == CPP_PTRSZ / 8
      {
        signed_word i;

        for (i = 0; i < last_set_bit; i++) {
          if (!GC_get_bit(bm, (word)i))
            break;
        }
        if (i == last_set_bit) {
          /* The initial section contains all pointers; use the     */
          /* length descriptor.                                     */
          return PTRS_TO_BYTES((word)last_set_bit + 1) | GC_DS_LENGTH;
        }
      }
#   endif
    if (last_set_bit < BITMAP_BITS) {
        signed_word i;

        /* Hopefully the common case.  Build the bitmap descriptor  */
        /* (with the bits reversed).                                */
        d = SIGNB;
        for (i = last_set_bit - 1; i >= 0; i--) {
            d >>= 1;
            if (GC_get_bit(bm, (word)i)) d |= SIGNB;
        }
        d |= GC_DS_BITMAP;
    } else {
        signed_word index = GC_add_ext_descriptor(bm,
                                                  (size_t)last_set_bit + 1);

        if (EXPECT(index < 0, FALSE)) {
            /* Out of memory: use a conservative approximation. */
            return PTRS_TO_BYTES((word)last_set_bit + 1) | GC_DS_LENGTH;
        }
#       ifdef LINT2
          if ((word)index > MAX_ENV)
            ABORT("GC_add_ext_descriptor() result cannot exceed MAX_ENV");
#       endif
        d = GC_MAKE_PROC(GC_typed_mark_proc_index, index);
    }
    return d;
}

static void set_obj_descr(ptr_t op, GC_descr d)
{
  size_t sz;

  if (EXPECT(NULL == op, FALSE)) return;

  /* It is not safe to use GC_size_map[] here as the table might be */
  /* updated asynchronously.                                        */
  sz = GC_size(op);

  GC_ASSERT((sz & (GC_GRANULE_BYTES-1)) == 0 && sz > sizeof(GC_descr));
# ifdef AO_HAVE_store_release
    AO_store_release((volatile AO_t *)&op[sz - sizeof(GC_descr)], d);
# else
    *(GC_descr *)&op[sz - sizeof(GC_descr)] = d;
# endif
}

GC_API GC_ATTR_MALLOC void * GC_CALL GC_malloc_explicitly_typed(size_t lb,
                                                                GC_descr d)
{
    ptr_t op;

    GC_ASSERT(GC_explicit_typing_initialized);
    if (EXPECT(lb < sizeof(ptr_t) - sizeof(GC_descr) + 1, FALSE)) {
       /* Ensure the descriptor does not occupy the first pointer place. */
      lb = sizeof(ptr_t) - sizeof(GC_descr) + 1;
    }
    op = (ptr_t)GC_malloc_kind(
                        SIZET_SAT_ADD(lb, sizeof(GC_descr) - EXTRA_BYTES),
                        GC_explicit_kind);
    set_obj_descr(op, d);
    return op;
}

GC_API GC_ATTR_MALLOC void * GC_CALL
    GC_malloc_explicitly_typed_ignore_off_page(size_t lb, GC_descr d)
{
    ptr_t op;

    if (lb < HBLKSIZE - sizeof(GC_descr))
      return GC_malloc_explicitly_typed(lb, d);

    GC_ASSERT(GC_explicit_typing_initialized);
    /* Note that ignore-off-page objects with the requested size    */
    /* of at least HBLKSIZE do not have EXTRA_BYTES added by        */
    /* GC_generic_malloc_aligned().                                 */
    op = (ptr_t)GC_clear_stack(GC_generic_malloc_aligned(
                                SIZET_SAT_ADD(lb, sizeof(GC_descr)),
                                GC_explicit_kind, IGNORE_OFF_PAGE, 0));
    set_obj_descr(op, d);
    return op;
}

/* Array descriptors.  GC_array_mark_proc understands these.    */
/* We may eventually need to add provisions for headers and     */
/* trailers.  Hence we provide for tree structured descriptors, */
/* though we don't really use them currently.                   */

/* This type describes simple array.    */
struct LeafDescriptor {
  word ld_tag;
# define LEAF_TAG 1
  /* Bytes per element; non-zero, multiple of ALIGNMENT.        */
  size_t ld_size;
  /* Number of elements.        */
  size_t ld_nelements;
  /* A simple length, bitmap, or procedure descriptor.          */
  GC_descr ld_descriptor;
};

struct ComplexArrayDescriptor {
  word ad_tag;
# define ARRAY_TAG 2
  size_t ad_nelements;
  union ComplexDescriptor *ad_element_descr;
};

struct SequenceDescriptor {
  word sd_tag;
# define SEQUENCE_TAG 3
  union ComplexDescriptor *sd_first;
  union ComplexDescriptor *sd_second;
};

typedef union ComplexDescriptor {
  struct LeafDescriptor ld;
  struct ComplexArrayDescriptor ad;
  struct SequenceDescriptor sd;
} complex_descriptor;

STATIC complex_descriptor *GC_make_leaf_descriptor(size_t size,
                                                   size_t nelements,
                                                   GC_descr d)
{
  complex_descriptor *result = (complex_descriptor *)
                GC_malloc_atomic(sizeof(struct LeafDescriptor));

  GC_ASSERT(size != 0);
  if (EXPECT(NULL == result, FALSE)) return NULL;

  result -> ld.ld_tag = LEAF_TAG;
  result -> ld.ld_size = size;
  result -> ld.ld_nelements = nelements;
  result -> ld.ld_descriptor = d;
  return result;
}

STATIC complex_descriptor *GC_make_sequence_descriptor(
                                                complex_descriptor *first,
                                                complex_descriptor *second)
{
  /* Note: for a reason, the sanitizer runtime complains of             */
  /* insufficient space for complex_descriptor if the pointer type of   */
  /* result variable is changed to.                                     */
  struct SequenceDescriptor *result = (struct SequenceDescriptor *)
                GC_malloc(sizeof(struct SequenceDescriptor));

  if (EXPECT(NULL == result, FALSE)) return NULL;

  /* Can't result in overly conservative marking, since tags are        */
  /* very small integers. Probably faster than maintaining type info.   */
  result -> sd_tag = SEQUENCE_TAG;
  result -> sd_first = first;
  result -> sd_second = second;
  GC_dirty(result);
  REACHABLE_AFTER_DIRTY(first);
  REACHABLE_AFTER_DIRTY(second);
  return (complex_descriptor *)result;
}

#define NO_MEM  (-1)
#define SIMPLE  0
#define LEAF    1
#define COMPLEX 2

/* Build a descriptor for an array with nelements elements, each of     */
/* which can be described by a simple descriptor d.  We try to optimize */
/* some common cases.  If the result is COMPLEX, a complex_descriptor*  */
/* value is returned in *pcomplex_d.  If the result is LEAF, then a     */
/* LeafDescriptor value is built in the structure pointed to by pleaf.  */
/* The tag in the *pleaf structure is not set.  If the result is        */
/* SIMPLE, then a GC_descr value is returned in *psimple_d.  If the     */
/* result is NO_MEM, then we failed to allocate the descriptor.         */
/* The implementation assumes GC_DS_LENGTH is 0.  *pleaf, *pcomplex_d   */
/* and *psimple_d may be used as temporaries during the construction.   */
STATIC int GC_make_array_descriptor(size_t nelements, size_t size,
                                    GC_descr d, GC_descr *psimple_d,
                                    complex_descriptor **pcomplex_d,
                                    struct LeafDescriptor *pleaf)
{
  /* For larger arrays, we try to combine descriptors of adjacent       */
  /* descriptors to speed up marking, and to reduce the amount of space */
  /* needed on the mark stack.                                          */
# define OPT_THRESHOLD 50

  GC_ASSERT(size != 0);
  if ((d & GC_DS_TAGS) == GC_DS_LENGTH) {
    if (d == (GC_descr)size) {
      /* Note: no overflow is guaranteed by caller.     */
      *psimple_d = nelements * d;
      return SIMPLE;
    } else if (0 == d) {
      *psimple_d = 0;
      return SIMPLE;
    }
  }

  if (nelements <= OPT_THRESHOLD) {
    if (nelements <= 1) {
      *psimple_d = nelements == 1 ? d : 0;
      return SIMPLE;
    }
  } else if (size <= BITMAP_BITS / 2
             && (d & GC_DS_TAGS) != GC_DS_PROC
             && (size & (sizeof(ptr_t)-1)) == 0) {
    complex_descriptor *one_element, *beginning;
    int result = GC_make_array_descriptor(nelements / 2, 2 * size,
                                GC_double_descr(d, BYTES_TO_PTRS(size)),
                                psimple_d, pcomplex_d, pleaf);

    if ((nelements & 1) == 0 || EXPECT(NO_MEM == result, FALSE))
      return result;

    one_element = GC_make_leaf_descriptor(size, 1, d);
    if (EXPECT(NULL == one_element, FALSE)) return NO_MEM;

    if (COMPLEX == result) {
      beginning = *pcomplex_d;
    } else {
      beginning = SIMPLE == result
                    ? GC_make_leaf_descriptor(size, 1, *psimple_d)
                    : GC_make_leaf_descriptor(pleaf -> ld_size,
                                              pleaf -> ld_nelements,
                                              pleaf -> ld_descriptor);
      if (EXPECT(NULL == beginning, FALSE)) return NO_MEM;
    }
    *pcomplex_d = GC_make_sequence_descriptor(beginning, one_element);
    if (EXPECT(NULL == *pcomplex_d, FALSE)) return NO_MEM;

    return COMPLEX;
  }

  pleaf -> ld_size = size;
  pleaf -> ld_nelements = nelements;
  pleaf -> ld_descriptor = d;
  return LEAF;
}

struct GC_calloc_typed_descr_s {
  complex_descriptor *complex_d; /* the first field, the only pointer */
  struct LeafDescriptor leaf;
  GC_descr simple_d;
  word alloc_lb; /* size_t actually */
  signed_word descr_type; /* int actually */
};

GC_API int GC_CALL GC_calloc_prepare_explicitly_typed(
                                struct GC_calloc_typed_descr_s *pctd,
                                size_t ctd_sz,
                                size_t n, size_t lb, GC_descr d)
{
    GC_STATIC_ASSERT(sizeof(struct GC_calloc_typed_descr_s)
        == GC_CALLOC_TYPED_DESCR_PTRS * sizeof(ptr_t)
            + (GC_CALLOC_TYPED_DESCR_WORDS - GC_CALLOC_TYPED_DESCR_PTRS)
                * sizeof(word));
    GC_ASSERT(GC_explicit_typing_initialized);
    GC_ASSERT(sizeof(struct GC_calloc_typed_descr_s) == ctd_sz);
    (void)ctd_sz; /* unused currently */
    if (EXPECT(0 == lb || 0 == n, FALSE)) lb = n = 1;
    if (EXPECT((lb | n) > GC_SQRT_SIZE_MAX, FALSE) /* fast initial check */
        && n > GC_SIZE_MAX / lb) {
      /* n*lb overflows.        */
      pctd -> alloc_lb = GC_SIZE_MAX;
      pctd -> descr_type = NO_MEM;
      /* The rest of the fields are unset. */
      return 0; /* failure */
    }

    pctd -> descr_type = GC_make_array_descriptor(n, lb, d,
                                                  &(pctd -> simple_d),
                                                  &(pctd -> complex_d),
                                                  &(pctd -> leaf));
    switch (pctd -> descr_type) {
    case NO_MEM:
    case SIMPLE:
      pctd -> alloc_lb = (word)lb * n;
      break;
    case LEAF:
      pctd -> alloc_lb
        = SIZET_SAT_ADD(lb * n,
                        (BYTES_TO_PTRS_ROUNDUP(sizeof(struct LeafDescriptor))
                         + 1) * sizeof(ptr_t) - EXTRA_BYTES);
      break;
    case COMPLEX:
      pctd -> alloc_lb = SIZET_SAT_ADD(lb * n, sizeof(ptr_t) - EXTRA_BYTES);
      break;
    }
    return 1; /* success */
}

GC_API GC_ATTR_MALLOC void * GC_CALL GC_calloc_do_explicitly_typed(
                                const struct GC_calloc_typed_descr_s *pctd,
                                size_t ctd_sz)
{
    void *op;
    size_t lpw_m1;

    GC_ASSERT(sizeof(struct GC_calloc_typed_descr_s) == ctd_sz);
    (void)ctd_sz; /* unused currently */
    switch (pctd -> descr_type) {
    case NO_MEM:
      return (*GC_get_oom_fn())((size_t)(pctd -> alloc_lb));
    case SIMPLE:
      return GC_malloc_explicitly_typed((size_t)(pctd -> alloc_lb),
                                        pctd -> simple_d);
    case LEAF:
    case COMPLEX:
      break;
    default:
      ABORT_RET("Bad descriptor type");
      return NULL;
    }
    op = GC_malloc_kind((size_t)(pctd -> alloc_lb), GC_array_kind);
    if (EXPECT(NULL == op, FALSE))
      return NULL;

    lpw_m1 = BYTES_TO_PTRS(GC_size(op)) - 1;
    if (pctd -> descr_type == LEAF) {
      /* Set up the descriptor inside the object itself.        */
      struct LeafDescriptor *lp
                = (struct LeafDescriptor *)((ptr_t *)op + lpw_m1
                    - BYTES_TO_PTRS_ROUNDUP(sizeof(struct LeafDescriptor)));

      lp -> ld_tag = LEAF_TAG;
      lp -> ld_size = pctd -> leaf.ld_size;
      lp -> ld_nelements = pctd -> leaf.ld_nelements;
      lp -> ld_descriptor = pctd -> leaf.ld_descriptor;
      /* Hold the allocator lock (in the reader mode which should be    */
      /* enough) while writing the descriptor word to the object to     */
      /* ensure that the descriptor contents are seen by                */
      /* GC_array_mark_proc as expected.                                */
      /* TODO: It should be possible to replace locking with the atomic */
      /* operations (with the release barrier here) but, in this case,  */
      /* avoiding the acquire barrier in GC_array_mark_proc seems to    */
      /* be tricky as GC_mark_some might be invoked with the world      */
      /* running.                                                       */
      READER_LOCK();
      ((struct LeafDescriptor **)op)[lpw_m1] = lp;
      READER_UNLOCK_RELEASE();
    } else {
#     ifndef GC_NO_FINALIZATION
        READER_LOCK();
        ((complex_descriptor **)op)[lpw_m1] = pctd -> complex_d;
        READER_UNLOCK_RELEASE();

        GC_dirty((ptr_t *)op + lpw_m1);
        REACHABLE_AFTER_DIRTY(pctd -> complex_d);

        /* Make sure the descriptor is cleared once there is any danger */
        /* it may have been collected.                                  */
        if (EXPECT(GC_general_register_disappearing_link(
                        (void **)op + lpw_m1, op) == GC_NO_MEMORY, FALSE))
#     endif
        {
            /* Couldn't register it due to lack of memory.  Punt.       */
            return (*GC_get_oom_fn())((size_t)(pctd -> alloc_lb));
        }
    }
    return op;
}

GC_API GC_ATTR_MALLOC void * GC_CALL GC_calloc_explicitly_typed(size_t n,
                                                                size_t lb,
                                                                GC_descr d)
{
  struct GC_calloc_typed_descr_s ctd;

  (void)GC_calloc_prepare_explicitly_typed(&ctd, sizeof(ctd), n, lb, d);
  return GC_calloc_do_explicitly_typed(&ctd, sizeof(ctd));
}

/* Return the size of the object described by complex_d.  It would be   */
/* faster to store this directly, or to compute it as part of           */
/* GC_push_complex_descriptor, but hopefully it does not matter.        */
STATIC size_t GC_descr_obj_size(complex_descriptor *complex_d)
{
  switch (complex_d -> ad.ad_tag) {
  case LEAF_TAG:
    return complex_d -> ld.ld_nelements * complex_d -> ld.ld_size;
  case ARRAY_TAG:
    return complex_d -> ad.ad_nelements
           * GC_descr_obj_size(complex_d -> ad.ad_element_descr);
  case SEQUENCE_TAG:
    return GC_descr_obj_size(complex_d -> sd.sd_first)
           + GC_descr_obj_size(complex_d -> sd.sd_second);
  default:
    ABORT_RET("Bad complex descriptor");
    return 0;
  }
}

/* Push descriptors for the object with complex descriptor onto the */
/* mark stack.  Return NULL if the mark stack overflowed.           */
STATIC mse *GC_push_complex_descriptor(ptr_t current,
                                       complex_descriptor *complex_d,
                                       mse *msp, mse *msl)
{
  size_t i, nelements;
  size_t sz;
  GC_descr d;
  complex_descriptor *element_descr;

  switch (complex_d -> ad.ad_tag) {
  case LEAF_TAG:
    d = complex_d -> ld.ld_descriptor;
    nelements = complex_d -> ld.ld_nelements;
    sz = complex_d -> ld.ld_size;

    if (EXPECT(msl - msp <= (signed_word)nelements, FALSE)) return NULL;
    GC_ASSERT(sz != 0);
    for (i = 0; i < nelements; i++) {
      msp++;
      msp -> mse_start = current;
      msp -> mse_descr = d;
      current += sz;
    }
    break;
  case ARRAY_TAG:
    element_descr = complex_d -> ad.ad_element_descr;
    nelements = complex_d -> ad.ad_nelements;
    sz = GC_descr_obj_size(element_descr);
    GC_ASSERT(sz != 0 || 0 == nelements);
    for (i = 0; i < nelements; i++) {
      msp = GC_push_complex_descriptor(current, element_descr, msp, msl);
      if (EXPECT(NULL == msp, FALSE)) return NULL;
      current += sz;
    }
    break;
  case SEQUENCE_TAG:
    sz = GC_descr_obj_size(complex_d -> sd.sd_first);
    msp = GC_push_complex_descriptor(current, complex_d -> sd.sd_first,
                                     msp, msl);
    if (EXPECT(NULL == msp, FALSE)) return NULL;
    GC_ASSERT(sz != 0);
    current += sz;
    msp = GC_push_complex_descriptor(current, complex_d -> sd.sd_second,
                                     msp, msl);
    break;
  default:
    ABORT("Bad complex descriptor");
  }
  return msp;
}

GC_ATTR_NO_SANITIZE_THREAD
static complex_descriptor *get_complex_descr(ptr_t *p, size_t lpw)
{
  return (complex_descriptor *)p[lpw - 1];
}

/* Used by GC_calloc_do_explicitly_typed via GC_array_kind.     */
STATIC mse *GC_CALLBACK GC_array_mark_proc(word *addr, mse *mark_stack_top,
                                           mse *mark_stack_limit, word env)
{
  size_t sz = HDR(addr) -> hb_sz;
  size_t lpw = BYTES_TO_PTRS(sz);
  complex_descriptor *complex_d = get_complex_descr((ptr_t *)addr, lpw);
  mse *orig_mark_stack_top = mark_stack_top;
  mse *new_mark_stack_top;

  UNUSED_ARG(env);
  if (NULL == complex_d) {
    /* Found a reference to a free-list entry.  Ignore it.      */
    return orig_mark_stack_top;
  }
  /* In-use counts were already updated when array descriptor was       */
  /* pushed.  Here we only replace it by subobject descriptors, so      */
  /* no update is necessary.                                            */
  new_mark_stack_top = GC_push_complex_descriptor((ptr_t)addr, complex_d,
                                                  mark_stack_top,
                                                  mark_stack_limit - 1);
  if (NULL == new_mark_stack_top) {
    /* Explicitly instruct Clang Static Analyzer that ptr is non-null.  */
    if (NULL == mark_stack_top) ABORT("Bad mark_stack_top");

    /* Does not fit.  Conservatively push the whole array as a unit and */
    /* request a mark stack expansion.  This cannot cause a mark stack  */
    /* overflow, since it replaces the original array entry.            */
#   ifdef PARALLEL_MARK
      /* We might be using a local_mark_stack in parallel mode. */
      if (GC_mark_stack + GC_mark_stack_size == mark_stack_limit)
#   endif
    {
      GC_mark_stack_too_small = TRUE;
    }
    new_mark_stack_top = orig_mark_stack_top + 1;
    new_mark_stack_top -> mse_start = (ptr_t)addr;
    new_mark_stack_top -> mse_descr = sz | GC_DS_LENGTH;
  } else {
    /* Push descriptor itself.  */
    new_mark_stack_top++;
    new_mark_stack_top -> mse_start = (ptr_t)((ptr_t *)addr + lpw - 1);
    new_mark_stack_top -> mse_descr = sizeof(ptr_t) | GC_DS_LENGTH;
  }
  return new_mark_stack_top;
}