typd_mlc.c raw

   1  /*
   2   * Copyright (c) 1991-1994 by Xerox Corporation.  All rights reserved.
   3   * Copyright (c) 1999-2000 by Hewlett-Packard Company.  All rights reserved.
   4   * Copyright (c) 2008-2022 Ivan Maidanski
   5   *
   6   * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
   7   * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
   8   *
   9   * Permission is hereby granted to use or copy this program
  10   * for any purpose, provided the above notices are retained on all copies.
  11   * Permission to modify the code and to distribute modified code is granted,
  12   * provided the above notices are retained, and a notice that the code was
  13   * modified is included with the above copyright notice.
  14   */
  15  
  16  #include "private/gc_pmark.h"
  17  
  18  /*
  19   * Some simple primitives for allocation with explicit type information.
  20   * Simple objects are allocated such that they contain a `GC_descr` at the
  21   * end (in the last allocated word).  This descriptor may be a procedure
  22   * which then examines an extended descriptor passed as its environment.
  23   *
  24   * Arrays are treated as simple objects if they have sufficiently simple
  25   * structure.  Otherwise they are allocated from an array kind that supplies
  26   * a special mark procedure.  These arrays contain a pointer to a
  27   * `complex_descriptor` as their last "pointer-sized" word.
  28   * This is done because the environment field is too small, and the collector
  29   * must trace the `complex_descriptor`.
  30   *
  31   * Note that descriptors inside objects may appear cleared, if we encounter
  32   * a false reference to an object on a free list.  In the case of a simple
  33   * object, this is OK, since a zero descriptor corresponds to examining no
  34   * fields.  In the `complex_descriptor` case, we explicitly check for that
  35   * case.
  36   *
  37   * Note: major parts of this code have not been tested at all and are not
  38   * testable, since they are not accessible through the current interface.
  39   */
  40  
  41  #include "gc/gc_typed.h"
  42  
  43  /* Object kind for objects with indirect (possibly extended) descriptors. */
  44  STATIC int GC_explicit_kind = 0;
  45  
  46  /*
  47   * Object kind for objects with complex descriptors and
  48   * `GC_array_mark_proc`.
  49   */
  50  STATIC int GC_array_kind = 0;
  51  
  52  #define ED_INITIAL_SIZE 100
  53  
  54  /* Indices of the typed mark procedures. */
  55  STATIC unsigned GC_typed_mark_proc_index = 0;
  56  STATIC unsigned GC_array_mark_proc_index = 0;
  57  
  58  STATIC void
  59  GC_push_typed_structures_proc(void)
  60  {
  61    GC_PUSH_ALL_SYM(GC_ext_descriptors);
  62  }
  63  
  64  /*
  65   * Add a multi-word bitmap to `GC_ext_descriptors` arrays.
  66   * Returns starting index on success, -1 otherwise.
  67   */
  68  STATIC GC_signed_word
  69  GC_add_ext_descriptor(const word *bm, size_t nbits)
  70  {
  71    GC_signed_word result;
  72    size_t i;
  73    size_t nwords = divWORDSZ(nbits + CPP_WORDSZ - 1);
  74  
  75    LOCK();
  76    while (UNLIKELY(GC_avail_descr + nwords >= GC_ed_size)) {
  77      typed_ext_descr_t *newExtD;
  78      size_t new_size;
  79      size_t ed_size = GC_ed_size;
  80  
  81      if (0 == ed_size) {
  82        GC_ASSERT(ADDR(&GC_ext_descriptors) % ALIGNMENT == 0);
  83        GC_push_typed_structures = GC_push_typed_structures_proc;
  84        UNLOCK();
  85        new_size = ED_INITIAL_SIZE;
  86      } else {
  87        UNLOCK();
  88        new_size = 2 * ed_size;
  89        if (new_size > MAX_ENV)
  90          return -1;
  91      }
  92      newExtD = (typed_ext_descr_t *)GC_malloc_atomic(
  93          new_size * sizeof(typed_ext_descr_t));
  94      if (NULL == newExtD)
  95        return -1;
  96      LOCK();
  97      if (ed_size == GC_ed_size) {
  98        if (GC_avail_descr != 0) {
  99          BCOPY(GC_ext_descriptors, newExtD,
 100                GC_avail_descr * sizeof(typed_ext_descr_t));
 101        }
 102        GC_ed_size = new_size;
 103        GC_ext_descriptors = newExtD;
 104      } else {
 105        /* Another thread is already resized it in the meantime. */
 106      }
 107    }
 108    result = (GC_signed_word)GC_avail_descr;
 109    for (i = 0; i < nwords - 1; i++) {
 110      GC_ext_descriptors[(size_t)result + i].ed_bitmap = bm[i];
 111      GC_ext_descriptors[(size_t)result + i].ed_continued = TRUE;
 112    }
 113    /* Clear irrelevant (highest) bits for the last element. */
 114    GC_ext_descriptors[(size_t)result + i].ed_bitmap
 115        = bm[i] & (GC_WORD_MAX >> (nwords * CPP_WORDSZ - nbits));
 116    GC_ext_descriptors[(size_t)result + i].ed_continued = FALSE;
 117    GC_avail_descr += nwords;
 118    GC_ASSERT(result >= 0);
 119    UNLOCK();
 120    return result;
 121  }
 122  
 123  /* Table of bitmap descriptors for `n` pointer-long all-pointer objects. */
 124  STATIC GC_descr GC_bm_table[CPP_WORDSZ / 2];
 125  
 126  /*
 127   * Return a descriptor for the concatenation of 2 objects, each one is
 128   * `lpw` pointers long and described by descriptor `d`.  The result is
 129   * known to be short enough to fit into a bitmap descriptor.
 130   * `d` is a `GC_DS_LENGTH` or `GC_DS_BITMAP` descriptor.
 131   */
 132  STATIC GC_descr
 133  GC_double_descr(GC_descr d, size_t lpw)
 134  {
 135    GC_ASSERT(GC_bm_table[0] == GC_DS_BITMAP); /*< `bm` table is initialized */
 136    if ((d & GC_DS_TAGS) == GC_DS_LENGTH) {
 137      d = GC_bm_table[BYTES_TO_PTRS(d)];
 138    }
 139    d |= (d & ~(GC_descr)GC_DS_TAGS) >> lpw;
 140    return d;
 141  }
 142  
 143  STATIC mse *GC_CALLBACK GC_typed_mark_proc(word *addr, mse *mark_stack_top,
 144                                             mse *mark_stack_limit, word env);
 145  
 146  STATIC mse *GC_CALLBACK GC_array_mark_proc(word *addr, mse *mark_stack_top,
 147                                             mse *mark_stack_limit, word env);
 148  
 149  STATIC void
 150  GC_init_explicit_typing(void)
 151  {
 152    unsigned i;
 153  
 154    /*
 155     * Set up object kind with simple indirect descriptor.
 156     * Descriptor is in the last `word` of the object.
 157     */
 158    GC_typed_mark_proc_index = GC_new_proc_inner(GC_typed_mark_proc);
 159    GC_explicit_kind = (int)GC_new_kind_inner(
 160        GC_new_free_list_inner(),
 161        (PTRS_TO_BYTES(GC_WORD_MAX) | GC_DS_PER_OBJECT), TRUE, TRUE);
 162  
 163    /* Set up object kind with array descriptor. */
 164    GC_array_mark_proc_index = GC_new_proc_inner(GC_array_mark_proc);
 165    GC_array_kind = (int)GC_new_kind_inner(
 166        GC_new_free_list_inner(), GC_MAKE_PROC(GC_array_mark_proc_index, 0),
 167        FALSE, TRUE);
 168  
 169    GC_bm_table[0] = GC_DS_BITMAP;
 170    for (i = 1; i < CPP_WORDSZ / 2; i++) {
 171      GC_bm_table[i] = (GC_WORD_MAX << (CPP_WORDSZ - i)) | GC_DS_BITMAP;
 172    }
 173  }
 174  
 175  STATIC mse *GC_CALLBACK
 176  GC_typed_mark_proc(word *addr, mse *mark_stack_top, mse *mark_stack_limit,
 177                     word env)
 178  {
 179    word bm;
 180    ptr_t current_p = (ptr_t)addr;
 181    ptr_t greatest_ha = (ptr_t)GC_greatest_plausible_heap_addr;
 182    ptr_t least_ha = (ptr_t)GC_least_plausible_heap_addr;
 183    DECLARE_HDR_CACHE;
 184  
 185    /* The allocator lock is held by the collection initiating thread. */
 186    GC_ASSERT(GC_get_parallel() || I_HOLD_LOCK());
 187    bm = GC_ext_descriptors[env].ed_bitmap;
 188  
 189    INIT_HDR_CACHE;
 190    for (; bm != 0; bm >>= 1, current_p += sizeof(ptr_t)) {
 191      if (bm & 1) {
 192        ptr_t q;
 193  
 194        LOAD_PTR_OR_CONTINUE(q, current_p);
 195        FIXUP_POINTER(q);
 196        if (ADDR_LT(least_ha, q) && ADDR_LT(q, greatest_ha)) {
 197          PUSH_CONTENTS(q, mark_stack_top, mark_stack_limit, current_p);
 198        }
 199      }
 200    }
 201    if (GC_ext_descriptors[env].ed_continued) {
 202      /*
 203       * Push an entry with the rest of the descriptor back onto the stack.
 204       * Thus we never do too much work at once.  Note that we also cannot
 205       * overflow the mark stack unless we actually mark something.
 206       */
 207      mark_stack_top = GC_custom_push_proc(
 208          GC_MAKE_PROC(GC_typed_mark_proc_index, env + 1),
 209          (ptr_t *)addr + CPP_WORDSZ, mark_stack_top, mark_stack_limit);
 210    }
 211    return mark_stack_top;
 212  }
 213  
 214  GC_API GC_descr GC_CALL
 215  GC_make_descriptor(const GC_word *bm, size_t len)
 216  {
 217    GC_signed_word last_set_bit = (GC_signed_word)len - 1;
 218    GC_descr d;
 219  
 220  #if defined(AO_HAVE_load_acquire) && defined(AO_HAVE_store_release)
 221    if (UNLIKELY(!AO_load_acquire(&GC_explicit_typing_initialized))) {
 222      LOCK();
 223      if (!GC_explicit_typing_initialized) {
 224        GC_init_explicit_typing();
 225        AO_store_release(&GC_explicit_typing_initialized, TRUE);
 226      }
 227      UNLOCK();
 228    }
 229  #else
 230    LOCK();
 231    if (UNLIKELY(!GC_explicit_typing_initialized)) {
 232      GC_init_explicit_typing();
 233      GC_explicit_typing_initialized = TRUE;
 234    }
 235    UNLOCK();
 236  #endif
 237  
 238    while (last_set_bit >= 0 && !GC_get_bit(bm, (word)last_set_bit))
 239      last_set_bit--;
 240    if (last_set_bit < 0) {
 241      /* No pointers. */
 242      return 0;
 243    }
 244  
 245  #if ALIGNMENT == CPP_PTRSZ / 8
 246    {
 247      GC_signed_word i;
 248  
 249      for (i = 0; i < last_set_bit; i++) {
 250        if (!GC_get_bit(bm, (word)i))
 251          break;
 252      }
 253      if (i == last_set_bit) {
 254        /*
 255         * The initial section contains all pointers; use the length
 256         * descriptor.
 257         */
 258        return PTRS_TO_BYTES((word)last_set_bit + 1) | GC_DS_LENGTH;
 259      }
 260    }
 261  #endif
 262    if (last_set_bit < BITMAP_BITS) {
 263      GC_signed_word i;
 264  
 265      /*
 266       * Hopefully the common case.  Build the bitmap descriptor (with the
 267       * bits reversed).
 268       */
 269      d = SIGNB;
 270      for (i = last_set_bit - 1; i >= 0; i--) {
 271        d >>= 1;
 272        if (GC_get_bit(bm, (word)i))
 273          d |= SIGNB;
 274      }
 275      d |= GC_DS_BITMAP;
 276    } else {
 277      GC_signed_word index = GC_add_ext_descriptor(bm, (size_t)last_set_bit + 1);
 278  
 279      if (UNLIKELY(index < 0)) {
 280        /* Out of memory: use a conservative approximation. */
 281        return PTRS_TO_BYTES((word)last_set_bit + 1) | GC_DS_LENGTH;
 282      }
 283  #ifdef LINT2
 284      if ((word)index > MAX_ENV)
 285        ABORT("GC_add_ext_descriptor() result cannot exceed MAX_ENV");
 286  #endif
 287      d = GC_MAKE_PROC(GC_typed_mark_proc_index, index);
 288    }
 289    return d;
 290  }
 291  
 292  static void
 293  set_obj_descr(ptr_t op, GC_descr d)
 294  {
 295    size_t sz;
 296  
 297    if (UNLIKELY(NULL == op))
 298      return;
 299    /*
 300     * It is not safe to use `GC_size_map[]` here as the table might be
 301     * updated asynchronously.
 302     */
 303    sz = GC_size(op);
 304  
 305    GC_ASSERT((sz & (GC_GRANULE_BYTES - 1)) == 0 && sz > sizeof(GC_descr));
 306  #ifdef AO_HAVE_store_release
 307    AO_store_release((volatile AO_t *)&op[sz - sizeof(GC_descr)], d);
 308  #else
 309    *(GC_descr *)&op[sz - sizeof(GC_descr)] = d;
 310  #endif
 311  }
 312  
 313  GC_API GC_ATTR_MALLOC void *GC_CALL
 314  GC_malloc_explicitly_typed(size_t lb, GC_descr d)
 315  {
 316    ptr_t op;
 317  
 318    GC_ASSERT(GC_explicit_typing_initialized);
 319    if (UNLIKELY(lb < sizeof(ptr_t) - sizeof(GC_descr) + 1)) {
 320      /* Ensure the descriptor does not occupy the first pointer place. */
 321      lb = sizeof(ptr_t) - sizeof(GC_descr) + 1;
 322    }
 323    op = (ptr_t)GC_malloc_kind(SIZET_SAT_ADD(lb, sizeof(GC_descr) - EXTRA_BYTES),
 324                               GC_explicit_kind);
 325    set_obj_descr(op, d);
 326    return op;
 327  }
 328  
 329  GC_API GC_ATTR_MALLOC void *GC_CALL
 330  GC_malloc_explicitly_typed_ignore_off_page(size_t lb, GC_descr d)
 331  {
 332    ptr_t op;
 333  
 334    if (lb < HBLKSIZE - sizeof(GC_descr))
 335      return GC_malloc_explicitly_typed(lb, d);
 336  
 337    GC_ASSERT(GC_explicit_typing_initialized);
 338    /*
 339     * Note that ignore-off-page objects with the requested size of
 340     * at least `HBLKSIZE` do not have `EXTRA_BYTES` added by
 341     * `GC_generic_malloc_aligned()`.
 342     */
 343    op = (ptr_t)GC_clear_stack(
 344        GC_generic_malloc_aligned(SIZET_SAT_ADD(lb, sizeof(GC_descr)),
 345                                  GC_explicit_kind, IGNORE_OFF_PAGE, 0));
 346    set_obj_descr(op, d);
 347    return op;
 348  }
 349  
 350  /*
 351   * Array descriptors.  `GC_array_mark_proc` understands these.
 352   * We may eventually need to add provisions for headers and trailers.
 353   * Hence we provide for tree structured descriptors, though we do not
 354   * really use them currently.
 355   */
 356  
 357  /* This type describes simple array. */
 358  struct LeafDescriptor {
 359    word ld_tag;
 360  #define LEAF_TAG 1
 361    /* Bytes per element; nonzero, multiple of `ALIGNMENT`. */
 362    size_t ld_size;
 363    /* Number of elements. */
 364    size_t ld_nelements;
 365    /* A simple length, bitmap, or procedure descriptor. */
 366    GC_descr ld_descriptor;
 367  };
 368  
 369  struct ComplexArrayDescriptor {
 370    word ad_tag;
 371  #define ARRAY_TAG 2
 372    size_t ad_nelements;
 373    union ComplexDescriptor *ad_element_descr;
 374  };
 375  
 376  struct SequenceDescriptor {
 377    word sd_tag;
 378  #define SEQUENCE_TAG 3
 379    union ComplexDescriptor *sd_first;
 380    union ComplexDescriptor *sd_second;
 381  };
 382  
 383  typedef union ComplexDescriptor {
 384    struct LeafDescriptor ld;
 385    struct ComplexArrayDescriptor ad;
 386    struct SequenceDescriptor sd;
 387  } complex_descriptor;
 388  
 389  STATIC complex_descriptor *
 390  GC_make_leaf_descriptor(size_t size, size_t nelements, GC_descr d)
 391  {
 392    complex_descriptor *result
 393        = (complex_descriptor *)GC_malloc_atomic(sizeof(struct LeafDescriptor));
 394  
 395    GC_ASSERT(size != 0);
 396    if (UNLIKELY(NULL == result))
 397      return NULL;
 398  
 399    result->ld.ld_tag = LEAF_TAG;
 400    result->ld.ld_size = size;
 401    result->ld.ld_nelements = nelements;
 402    result->ld.ld_descriptor = d;
 403    return result;
 404  }
 405  
 406  STATIC complex_descriptor *
 407  GC_make_sequence_descriptor(complex_descriptor *first,
 408                              complex_descriptor *second)
 409  {
 410    /*
 411     * Note: for a reason, the sanitizer runtime complains of insufficient
 412     * space for `complex_descriptor` if the pointer type of `result` variable
 413     * is changed to.
 414     */
 415    struct SequenceDescriptor *result = (struct SequenceDescriptor *)GC_malloc(
 416        sizeof(struct SequenceDescriptor));
 417  
 418    if (UNLIKELY(NULL == result))
 419      return NULL;
 420  
 421    /*
 422     * Cannot result in overly conservative marking, since tags are very
 423     * small integers.  Probably faster than maintaining type information.
 424     */
 425    result->sd_tag = SEQUENCE_TAG;
 426    result->sd_first = first;
 427    result->sd_second = second;
 428    GC_dirty(result);
 429    REACHABLE_AFTER_DIRTY(first);
 430    REACHABLE_AFTER_DIRTY(second);
 431    return (complex_descriptor *)result;
 432  }
 433  
 434  #define NO_MEM (-1)
 435  #define SIMPLE 0
 436  #define LEAF 1
 437  #define COMPLEX 2
 438  
 439  /*
 440   * Build a descriptor for an array with `nelements` elements, each of
 441   * which can be described by a simple descriptor `d`.
 442   * We try to optimize some common cases.  If the result is `COMPLEX`,
 443   * a `complex_descriptor *` value is returned in `*pcomplex_d`.
 444   * If the result is `LEAF`, then a `LeafDescriptor` value is built in the
 445   * structure pointed to by `pleaf`.  The tag in the `*pleaf` structure
 446   * is not set.  If the result is `SIMPLE`, then a `GC_descr` value is
 447   * returned in `*psimple_d`.  If the result is `NO_MEM`, then we failed
 448   * to allocate the descriptor.  The implementation assumes `GC_DS_LENGTH`
 449   * is 0.  `*pleaf`, `*pcomplex_d` and `*psimple_d` may be used as
 450   * temporaries during the construction.
 451   */
 452  STATIC int
 453  GC_make_array_descriptor(size_t nelements, size_t size, GC_descr d,
 454                           GC_descr *psimple_d, complex_descriptor **pcomplex_d,
 455                           struct LeafDescriptor *pleaf)
 456  {
 457    /*
 458     * For larger arrays, we try to combine descriptors of adjacent
 459     * descriptors to speed up marking, and to reduce the amount of space
 460     * needed on the mark stack.
 461     */
 462  #define OPT_THRESHOLD 50
 463  
 464    GC_ASSERT(size != 0);
 465    if ((d & GC_DS_TAGS) == GC_DS_LENGTH) {
 466      if (d == (GC_descr)size) {
 467        /* Note: no overflow is guaranteed by caller. */
 468        *psimple_d = nelements * d;
 469        return SIMPLE;
 470      } else if (0 == d) {
 471        *psimple_d = 0;
 472        return SIMPLE;
 473      }
 474    }
 475  
 476    if (nelements <= OPT_THRESHOLD) {
 477      if (nelements <= 1) {
 478        *psimple_d = nelements == 1 ? d : 0;
 479        return SIMPLE;
 480      }
 481    } else if (size <= BITMAP_BITS / 2 && (d & GC_DS_TAGS) != GC_DS_PROC
 482               && (size & (sizeof(ptr_t) - 1)) == 0) {
 483      complex_descriptor *one_element, *beginning;
 484      int result = GC_make_array_descriptor(
 485          nelements / 2, 2 * size, GC_double_descr(d, BYTES_TO_PTRS(size)),
 486          psimple_d, pcomplex_d, pleaf);
 487  
 488      if ((nelements & 1) == 0 || UNLIKELY(NO_MEM == result))
 489        return result;
 490  
 491      one_element = GC_make_leaf_descriptor(size, 1, d);
 492      if (UNLIKELY(NULL == one_element))
 493        return NO_MEM;
 494  
 495      if (COMPLEX == result) {
 496        beginning = *pcomplex_d;
 497      } else {
 498        beginning
 499            = SIMPLE == result
 500                  ? GC_make_leaf_descriptor(size, 1, *psimple_d)
 501                  : GC_make_leaf_descriptor(pleaf->ld_size, pleaf->ld_nelements,
 502                                            pleaf->ld_descriptor);
 503        if (UNLIKELY(NULL == beginning))
 504          return NO_MEM;
 505      }
 506      *pcomplex_d = GC_make_sequence_descriptor(beginning, one_element);
 507      if (UNLIKELY(NULL == *pcomplex_d))
 508        return NO_MEM;
 509  
 510      return COMPLEX;
 511    }
 512  
 513    pleaf->ld_size = size;
 514    pleaf->ld_nelements = nelements;
 515    pleaf->ld_descriptor = d;
 516    return LEAF;
 517  }
 518  
 519  struct GC_calloc_typed_descr_s {
 520    complex_descriptor *complex_d; /*< the first field, the only pointer */
 521    struct LeafDescriptor leaf;
 522    GC_descr simple_d;
 523    word alloc_lb;             /*< of `size_t` type actually */
 524    GC_signed_word descr_type; /*< of `int` type actually */
 525  };
 526  
 527  GC_API int GC_CALL
 528  GC_calloc_prepare_explicitly_typed(struct GC_calloc_typed_descr_s *pctd,
 529                                     size_t ctd_sz, size_t n, size_t lb,
 530                                     GC_descr d)
 531  {
 532    GC_STATIC_ASSERT(sizeof(struct GC_calloc_typed_descr_opaque_s)
 533                     == sizeof(struct GC_calloc_typed_descr_s));
 534    GC_ASSERT(GC_explicit_typing_initialized);
 535    GC_ASSERT(sizeof(struct GC_calloc_typed_descr_s) == ctd_sz);
 536    (void)ctd_sz; /*< unused currently */
 537    if (UNLIKELY(0 == lb || 0 == n))
 538      lb = n = 1;
 539    if (UNLIKELY((lb | n) > GC_SQRT_SIZE_MAX) /*< fast initial check */
 540        && n > GC_SIZE_MAX / lb) {
 541      /* `n * lb` overflows. */
 542      pctd->alloc_lb = GC_SIZE_MAX;
 543      pctd->descr_type = NO_MEM;
 544      /* The rest of the fields are unset. */
 545      return 0; /*< failure */
 546    }
 547  
 548    pctd->descr_type = GC_make_array_descriptor(n, lb, d, &pctd->simple_d,
 549                                                &pctd->complex_d, &pctd->leaf);
 550    switch (pctd->descr_type) {
 551    case NO_MEM:
 552    case SIMPLE:
 553      pctd->alloc_lb = (word)lb * n;
 554      break;
 555    case LEAF:
 556      pctd->alloc_lb = SIZET_SAT_ADD(
 557          lb * n, (BYTES_TO_PTRS_ROUNDUP(sizeof(struct LeafDescriptor)) + 1)
 558                          * sizeof(ptr_t)
 559                      - EXTRA_BYTES);
 560      break;
 561    case COMPLEX:
 562      pctd->alloc_lb = SIZET_SAT_ADD(lb * n, sizeof(ptr_t) - EXTRA_BYTES);
 563      break;
 564    }
 565    return 1; /*< success */
 566  }
 567  
 568  GC_API GC_ATTR_MALLOC void *GC_CALL
 569  GC_calloc_do_explicitly_typed(const struct GC_calloc_typed_descr_s *pctd,
 570                                size_t ctd_sz)
 571  {
 572    void *op;
 573    size_t lpw_m1;
 574  
 575    GC_ASSERT(sizeof(struct GC_calloc_typed_descr_s) == ctd_sz);
 576    (void)ctd_sz; /*< unused currently */
 577    switch (pctd->descr_type) {
 578    case NO_MEM:
 579      return (*GC_get_oom_fn())((size_t)pctd->alloc_lb);
 580    case SIMPLE:
 581      return GC_malloc_explicitly_typed((size_t)pctd->alloc_lb, pctd->simple_d);
 582    case LEAF:
 583    case COMPLEX:
 584      break;
 585    default:
 586      ABORT_RET("Bad descriptor type");
 587      return NULL;
 588    }
 589    op = GC_malloc_kind((size_t)pctd->alloc_lb, GC_array_kind);
 590    if (UNLIKELY(NULL == op))
 591      return NULL;
 592  
 593    lpw_m1 = BYTES_TO_PTRS(GC_size(op)) - 1;
 594    if (pctd->descr_type == LEAF) {
 595      /* Set up the descriptor inside the object itself. */
 596      struct LeafDescriptor *lp
 597          = (struct LeafDescriptor *)((ptr_t *)op + lpw_m1
 598                                      - BYTES_TO_PTRS_ROUNDUP(
 599                                          sizeof(struct LeafDescriptor)));
 600  
 601      lp->ld_tag = LEAF_TAG;
 602      lp->ld_size = pctd->leaf.ld_size;
 603      lp->ld_nelements = pctd->leaf.ld_nelements;
 604      lp->ld_descriptor = pctd->leaf.ld_descriptor;
 605      /*
 606       * Hold the allocator lock (in the reader mode which should be enough)
 607       * while writing the descriptor `word` to the object to ensure that
 608       * the descriptor contents are seen by `GC_array_mark_proc` as expected.
 609       */
 610  
 611      /*
 612       * TODO: It should be possible to replace locking with the atomic
 613       * operations (with the release barrier here) but, in this case,
 614       * avoiding the acquire barrier in `GC_array_mark_proc` seems to
 615       * be tricky as `GC_mark_some` might be invoked with the world running.
 616       */
 617      READER_LOCK();
 618      ((struct LeafDescriptor **)op)[lpw_m1] = lp;
 619      READER_UNLOCK_RELEASE();
 620    } else {
 621  #ifndef GC_NO_FINALIZATION
 622      READER_LOCK();
 623      ((complex_descriptor **)op)[lpw_m1] = pctd->complex_d;
 624      READER_UNLOCK_RELEASE();
 625  
 626      GC_dirty((ptr_t *)op + lpw_m1);
 627      REACHABLE_AFTER_DIRTY(pctd->complex_d);
 628  
 629      /*
 630       * Make sure the descriptor is cleared once there is any danger
 631       * it may have been collected.
 632       */
 633      if (UNLIKELY(
 634              GC_general_register_disappearing_link((void **)op + lpw_m1, op)
 635              == GC_NO_MEMORY))
 636  #endif
 637      {
 638        /* Could not register it due to lack of memory.  Punt. */
 639        return (*GC_get_oom_fn())((size_t)pctd->alloc_lb);
 640      }
 641    }
 642    return op;
 643  }
 644  
 645  GC_API GC_ATTR_MALLOC void *GC_CALL
 646  GC_calloc_explicitly_typed(size_t n, size_t lb, GC_descr d)
 647  {
 648    struct GC_calloc_typed_descr_s ctd;
 649  
 650    (void)GC_calloc_prepare_explicitly_typed(&ctd, sizeof(ctd), n, lb, d);
 651    return GC_calloc_do_explicitly_typed(&ctd, sizeof(ctd));
 652  }
 653  
 654  /*
 655   * Return the size of the object described by `complex_d`.
 656   * It would be faster to store this directly, or to compute it as part
 657   * of `GC_push_complex_descriptor`, but hopefully it does not matter.
 658   */
 659  STATIC size_t
 660  GC_descr_obj_size(complex_descriptor *complex_d)
 661  {
 662    switch (complex_d->ad.ad_tag) {
 663    case LEAF_TAG:
 664      return complex_d->ld.ld_nelements * complex_d->ld.ld_size;
 665    case ARRAY_TAG:
 666      return complex_d->ad.ad_nelements
 667             * GC_descr_obj_size(complex_d->ad.ad_element_descr);
 668    case SEQUENCE_TAG:
 669      return GC_descr_obj_size(complex_d->sd.sd_first)
 670             + GC_descr_obj_size(complex_d->sd.sd_second);
 671    default:
 672      ABORT_RET("Bad complex descriptor");
 673      return 0;
 674    }
 675  }
 676  
 677  /*
 678   * Push descriptors for the object with the complex descriptor onto
 679   * the mark stack.  Return `NULL` if the mark stack overflowed.
 680   */
 681  STATIC mse *
 682  GC_push_complex_descriptor(ptr_t current, complex_descriptor *complex_d,
 683                             mse *msp, mse *msl)
 684  {
 685    size_t i, nelements;
 686    size_t sz;
 687    GC_descr d;
 688    complex_descriptor *element_descr;
 689  
 690    switch (complex_d->ad.ad_tag) {
 691    case LEAF_TAG:
 692      d = complex_d->ld.ld_descriptor;
 693      nelements = complex_d->ld.ld_nelements;
 694      sz = complex_d->ld.ld_size;
 695  
 696      if (UNLIKELY(msl - msp <= (GC_signed_word)nelements))
 697        return NULL;
 698      GC_ASSERT(sz != 0);
 699      for (i = 0; i < nelements; i++) {
 700        msp++;
 701        msp->mse_start = current;
 702        msp->mse_descr = d;
 703        current += sz;
 704      }
 705      break;
 706    case ARRAY_TAG:
 707      element_descr = complex_d->ad.ad_element_descr;
 708      nelements = complex_d->ad.ad_nelements;
 709      sz = GC_descr_obj_size(element_descr);
 710      GC_ASSERT(sz != 0 || 0 == nelements);
 711      for (i = 0; i < nelements; i++) {
 712        msp = GC_push_complex_descriptor(current, element_descr, msp, msl);
 713        if (UNLIKELY(NULL == msp))
 714          return NULL;
 715        current += sz;
 716      }
 717      break;
 718    case SEQUENCE_TAG:
 719      sz = GC_descr_obj_size(complex_d->sd.sd_first);
 720      msp = GC_push_complex_descriptor(current, complex_d->sd.sd_first, msp,
 721                                       msl);
 722      if (UNLIKELY(NULL == msp))
 723        return NULL;
 724      GC_ASSERT(sz != 0);
 725      current += sz;
 726      msp = GC_push_complex_descriptor(current, complex_d->sd.sd_second, msp,
 727                                       msl);
 728      break;
 729    default:
 730      ABORT("Bad complex descriptor");
 731    }
 732    return msp;
 733  }
 734  
 735  GC_ATTR_NO_SANITIZE_THREAD
 736  static complex_descriptor *
 737  get_complex_descr(ptr_t *p, size_t lpw)
 738  {
 739    return (complex_descriptor *)p[lpw - 1];
 740  }
 741  
 742  /* Used by `GC_calloc_do_explicitly_typed()` via `GC_array_kind`. */
 743  STATIC mse *GC_CALLBACK
 744  GC_array_mark_proc(word *addr, mse *mark_stack_top, mse *mark_stack_limit,
 745                     word env)
 746  {
 747    size_t sz = HDR(addr)->hb_sz;
 748    size_t lpw = BYTES_TO_PTRS(sz);
 749    complex_descriptor *complex_d = get_complex_descr((ptr_t *)addr, lpw);
 750    mse *orig_mark_stack_top = mark_stack_top;
 751    mse *new_mark_stack_top;
 752  
 753    UNUSED_ARG(env);
 754    if (NULL == complex_d) {
 755      /* Found a reference to a free-list entry.  Ignore it. */
 756      return orig_mark_stack_top;
 757    }
 758    /*
 759     * In-use counts were already updated when array descriptor was pushed.
 760     * Here we only replace it by subobject descriptors, so no update is
 761     * necessary.
 762     */
 763    new_mark_stack_top = GC_push_complex_descriptor(
 764        (ptr_t)addr, complex_d, mark_stack_top, mark_stack_limit - 1);
 765    if (NULL == new_mark_stack_top) {
 766      /* Explicitly instruct Clang Static Analyzer that pointer is non-`NULL`. */
 767      if (NULL == mark_stack_top) {
 768        ABORT("Bad mark_stack_top");
 769      }
 770  
 771      /*
 772       * Does not fit.  Conservatively push the whole array as a unit and
 773       * request a mark stack expansion.  This cannot cause a mark stack
 774       * overflow, since it replaces the original array entry.
 775       */
 776  #ifdef PARALLEL_MARK
 777      /* We might be using a `local_mark_stack` in the parallel collection. */
 778      if (GC_mark_stack + GC_mark_stack_size == mark_stack_limit)
 779  #endif
 780      {
 781        GC_mark_stack_too_small = TRUE;
 782      }
 783      new_mark_stack_top = orig_mark_stack_top + 1;
 784      new_mark_stack_top->mse_start = (ptr_t)addr;
 785      new_mark_stack_top->mse_descr = sz | GC_DS_LENGTH;
 786    } else {
 787      /* Push descriptor itself. */
 788      new_mark_stack_top++;
 789      new_mark_stack_top->mse_start = (ptr_t)((ptr_t *)addr + lpw - 1);
 790      new_mark_stack_top->mse_descr = sizeof(ptr_t) | GC_DS_LENGTH;
 791    }
 792    return new_mark_stack_top;
 793  }
 794