src/mm/boehm-gc/typd_mlc.c

   1 /*
   2  * Copyright (c) 1991-1994 by Xerox Corporation.  All rights reserved.
   3  * opyright (c) 1999-2000 by Hewlett-Packard Company.  All rights reserved.
   4  *
   5  * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
   6  * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
   7  *
   8  * Permission is hereby granted to use or copy this program
   9  * for any purpose,  provided the above notices are retained on all copies.
  10  * Permission to modify the code and to distribute modified code is granted,
  11  * provided the above notices are retained, and a notice that the code was
  12  * modified is included with the above copyright notice.
  13  *
  14  */
  15
  16
  17 /*
  18  * Some simple primitives for allocation with explicit type information.
  19  * Simple objects are allocated such that they contain a GC_descr at the
  20  * end (in the last allocated word).  This descriptor may be a procedure
  21  * which then examines an extended descriptor passed as its environment.
  22  *
  23  * Arrays are treated as simple objects if they have sufficiently simple
  24  * structure.  Otherwise they are allocated from an array kind that supplies
  25  * a special mark procedure.  These arrays contain a pointer to a
  26  * complex_descriptor as their last word.
  27  * This is done because the environment field is too small, and the collector
  28  * must trace the complex_descriptor.
  29  *
  30  * Note that descriptors inside objects may appear cleared, if we encounter a
  31  * false reference to an object on a free list.  In the GC_descr case, this
  32  * is OK, since a 0 descriptor corresponds to examining no fields.
  33  * In the complex_descriptor case, we explicitly check for that case.
  34  *
  35  * MAJOR PARTS OF THIS CODE HAVE NOT BEEN TESTED AT ALL and are not testable,
  36  * since they are not accessible through the current interface.
  37  */
  38
  39 #include "private/gc_pmark.h"
  40 #include "gc_typed.h"
  41
  42 # define TYPD_EXTRA_BYTES (sizeof(word) - EXTRA_BYTES)
  43
  44 STATIC GC_bool GC_explicit_typing_initialized = FALSE;
  45
  46 STATIC int GC_explicit_kind;
  47                         /* Object kind for objects with indirect        */
  48                         /* (possibly extended) descriptors.             */
  49
  50 STATIC int GC_array_kind;
  51                         /* Object kind for objects with complex         */
  52                         /* descriptors and GC_array_mark_proc.          */
  53
  54 /* Extended descriptors.  GC_typed_mark_proc understands these. */
  55 /* These are used for simple objects that are larger than what  */
  56 /* can be described by a BITMAP_BITS sized bitmap.              */
  57 typedef struct {
  58         word ed_bitmap; /* lsb corresponds to first word.       */
  59         GC_bool ed_continued;   /* next entry is continuation.  */
  60 } ext_descr;
  61
  62 /* Array descriptors.  GC_array_mark_proc understands these.    */
  63 /* We may eventually need to add provisions for headers and     */
  64 /* trailers.  Hence we provide for tree structured descriptors, */
  65 /* though we don't really use them currently.                   */
  66 typedef union ComplexDescriptor {
  67     struct LeafDescriptor {     /* Describes simple array       */
  68         word ld_tag;
  69 #       define LEAF_TAG 1
  70         size_t ld_size;         /* bytes per element    */
  71                                 /* multiple of ALIGNMENT        */
  72         size_t ld_nelements;    /* Number of elements.  */
  73         GC_descr ld_descriptor; /* A simple length, bitmap,     */
  74                                 /* or procedure descriptor.     */
  75     } ld;
  76     struct ComplexArrayDescriptor {
  77         word ad_tag;
  78 #       define ARRAY_TAG 2
  79         size_t ad_nelements;
  80         union ComplexDescriptor * ad_element_descr;
  81     } ad;
  82     struct SequenceDescriptor {
  83         word sd_tag;
  84 #       define SEQUENCE_TAG 3
  85         union ComplexDescriptor * sd_first;
  86         union ComplexDescriptor * sd_second;
  87     } sd;
  88 } complex_descriptor;
  89 #define TAG ld.ld_tag
  90
  91 STATIC ext_descr * GC_ext_descriptors;  /* Points to array of extended  */
  92                                         /* descriptors.                 */
  93
  94 STATIC size_t GC_ed_size = 0;   /* Current size of above arrays.        */
  95 # define ED_INITIAL_SIZE 100;
  96
  97 STATIC size_t GC_avail_descr = 0;       /* Next available slot.         */
  98
  99 STATIC int GC_typed_mark_proc_index;    /* Indices of my mark           */
 100 STATIC int GC_array_mark_proc_index;    /* procedures.                  */
 101
 102 static void GC_push_typed_structures_proc (void)
 103 {
 104   GC_push_all((ptr_t)&GC_ext_descriptors, (ptr_t)&GC_ext_descriptors + sizeof(word));
 105 }
 106
 107 /* Add a multiword bitmap to GC_ext_descriptors arrays.  Return */
 108 /* starting index.                                              */
 109 /* Returns -1 on failure.                                       */
 110 /* Caller does not hold allocation lock.                        */
 111 STATIC signed_word GC_add_ext_descriptor(GC_bitmap bm, word nbits)
 112 {
 113     size_t nwords = divWORDSZ(nbits + WORDSZ-1);
 114     signed_word result;
 115     size_t i;
 116     word last_part;
 117     size_t extra_bits;
 118     DCL_LOCK_STATE;
 119
 120     LOCK();
 121     while (GC_avail_descr + nwords >= GC_ed_size) {
 122         ext_descr * new;
 123         size_t new_size;
 124         word ed_size = GC_ed_size;
 125
 126         if (ed_size == 0) {
 127             GC_push_typed_structures = GC_push_typed_structures_proc;
 128             UNLOCK();
 129             new_size = ED_INITIAL_SIZE;
 130         } else {
 131             UNLOCK();
 132             new_size = 2 * ed_size;
 133             if (new_size > MAX_ENV) return(-1);
 134         }
 135         new = (ext_descr *) GC_malloc_atomic(new_size * sizeof(ext_descr));
 136         if (new == 0) return(-1);
 137         LOCK();
 138         if (ed_size == GC_ed_size) {
 139             if (GC_avail_descr != 0) {
 140                 BCOPY(GC_ext_descriptors, new,
 141                       GC_avail_descr * sizeof(ext_descr));
 142             }
 143             GC_ed_size = new_size;
 144             GC_ext_descriptors = new;
 145         }  /* else another thread already resized it in the meantime */
 146     }
 147     result = GC_avail_descr;
 148     for (i = 0; i < nwords-1; i++) {
 149         GC_ext_descriptors[result + i].ed_bitmap = bm[i];
 150         GC_ext_descriptors[result + i].ed_continued = TRUE;
 151     }
 152     last_part = bm[i];
 153     /* Clear irrelevant bits. */
 154     extra_bits = nwords * WORDSZ - nbits;
 155     last_part <<= extra_bits;
 156     last_part >>= extra_bits;
 157     GC_ext_descriptors[result + i].ed_bitmap = last_part;
 158     GC_ext_descriptors[result + i].ed_continued = FALSE;
 159     GC_avail_descr += nwords;
 160     UNLOCK();
 161     return(result);
 162 }
 163
 164 /* Table of bitmap descriptors for n word long all pointer objects.     */
 165 GC_descr GC_bm_table[WORDSZ/2];
 166
 167 /* Return a descriptor for the concatenation of 2 nwords long objects,  */
 168 /* each of which is described by descriptor.                            */
 169 /* The result is known to be short enough to fit into a bitmap          */
 170 /* descriptor.                                                          */
 171 /* Descriptor is a GC_DS_LENGTH or GC_DS_BITMAP descriptor.             */
 172 STATIC GC_descr GC_double_descr(GC_descr descriptor, word nwords)
 173 {
 174     if ((descriptor & GC_DS_TAGS) == GC_DS_LENGTH) {
 175         descriptor = GC_bm_table[BYTES_TO_WORDS((word)descriptor)];
 176     };
 177     descriptor |= (descriptor & ~GC_DS_TAGS) >> nwords;
 178     return(descriptor);
 179 }
 180
 181 STATIC complex_descriptor *
 182 GC_make_sequence_descriptor(complex_descriptor *first,
 183                             complex_descriptor *second);
 184
 185 /* Build a descriptor for an array with nelements elements,     */
 186 /* each of which can be described by a simple descriptor.       */
 187 /* We try to optimize some common cases.                        */
 188 /* If the result is COMPLEX, then a complex_descr* is returned  */
 189 /* in *complex_d.                                                       */
 190 /* If the result is LEAF, then we built a LeafDescriptor in     */
 191 /* the structure pointed to by leaf.                            */
 192 /* The tag in the leaf structure is not set.                    */
 193 /* If the result is SIMPLE, then a GC_descr                     */
 194 /* is returned in *simple_d.                                    */
 195 /* If the result is NO_MEM, then                                */
 196 /* we failed to allocate the descriptor.                        */
 197 /* The implementation knows that GC_DS_LENGTH is 0.             */
 198 /* *leaf, *complex_d, and *simple_d may be used as temporaries  */
 199 /* during the construction.                                     */
 200 # define COMPLEX 2
 201 # define LEAF 1
 202 # define SIMPLE 0
 203 # define NO_MEM (-1)
 204 STATIC int GC_make_array_descriptor(size_t nelements, size_t size,
 205                                     GC_descr descriptor, GC_descr *simple_d,
 206                                     complex_descriptor **complex_d,
 207                                     struct LeafDescriptor * leaf)
 208 {
 209 #   define OPT_THRESHOLD 50
 210         /* For larger arrays, we try to combine descriptors of adjacent */
 211         /* descriptors to speed up marking, and to reduce the amount    */
 212         /* of space needed on the mark stack.                           */
 213     if ((descriptor & GC_DS_TAGS) == GC_DS_LENGTH) {
 214       if (descriptor == (GC_descr)size) {
 215         *simple_d = nelements * descriptor;
 216         return(SIMPLE);
 217       } else if ((word)descriptor == 0) {
 218         *simple_d = (GC_descr)0;
 219         return(SIMPLE);
 220       }
 221     }
 222     if (nelements <= OPT_THRESHOLD) {
 223       if (nelements <= 1) {
 224         if (nelements == 1) {
 225             *simple_d = descriptor;
 226             return(SIMPLE);
 227         } else {
 228             *simple_d = (GC_descr)0;
 229             return(SIMPLE);
 230         }
 231       }
 232     } else if (size <= BITMAP_BITS/2
 233                && (descriptor & GC_DS_TAGS) != GC_DS_PROC
 234                && (size & (sizeof(word)-1)) == 0) {
 235       int result =
 236           GC_make_array_descriptor(nelements/2, 2*size,
 237                                    GC_double_descr(descriptor,
 238                                                    BYTES_TO_WORDS(size)),
 239                                    simple_d, complex_d, leaf);
 240       if ((nelements & 1) == 0) {
 241           return(result);
 242       } else {
 243           struct LeafDescriptor * one_element =
 244               (struct LeafDescriptor *)
 245                 GC_malloc_atomic(sizeof(struct LeafDescriptor));
 246
 247           if (result == NO_MEM || one_element == 0) return(NO_MEM);
 248           one_element -> ld_tag = LEAF_TAG;
 249           one_element -> ld_size = size;
 250           one_element -> ld_nelements = 1;
 251           one_element -> ld_descriptor = descriptor;
 252           switch(result) {
 253             case SIMPLE:
 254             {
 255               struct LeafDescriptor * beginning =
 256                 (struct LeafDescriptor *)
 257                   GC_malloc_atomic(sizeof(struct LeafDescriptor));
 258               if (beginning == 0) return(NO_MEM);
 259               beginning -> ld_tag = LEAF_TAG;
 260               beginning -> ld_size = size;
 261               beginning -> ld_nelements = 1;
 262               beginning -> ld_descriptor = *simple_d;
 263               *complex_d = GC_make_sequence_descriptor(
 264                                 (complex_descriptor *)beginning,
 265                                 (complex_descriptor *)one_element);
 266               break;
 267             }
 268             case LEAF:
 269             {
 270               struct LeafDescriptor * beginning =
 271                 (struct LeafDescriptor *)
 272                   GC_malloc_atomic(sizeof(struct LeafDescriptor));
 273               if (beginning == 0) return(NO_MEM);
 274               beginning -> ld_tag = LEAF_TAG;
 275               beginning -> ld_size = leaf -> ld_size;
 276               beginning -> ld_nelements = leaf -> ld_nelements;
 277               beginning -> ld_descriptor = leaf -> ld_descriptor;
 278               *complex_d = GC_make_sequence_descriptor(
 279                                 (complex_descriptor *)beginning,
 280                                 (complex_descriptor *)one_element);
 281               break;
 282             }
 283             case COMPLEX:
 284               *complex_d = GC_make_sequence_descriptor(
 285                                 *complex_d,
 286                                 (complex_descriptor *)one_element);
 287               break;
 288           }
 289           return(COMPLEX);
 290       }
 291     }
 292     {
 293         leaf -> ld_size = size;
 294         leaf -> ld_nelements = nelements;
 295         leaf -> ld_descriptor = descriptor;
 296         return(LEAF);
 297     }
 298 }
 299
 300 STATIC complex_descriptor *
 301 GC_make_sequence_descriptor(complex_descriptor *first,
 302                             complex_descriptor *second)
 303 {
 304     struct SequenceDescriptor * result =
 305         (struct SequenceDescriptor *)
 306                 GC_malloc(sizeof(struct SequenceDescriptor));
 307     /* Can't result in overly conservative marking, since tags are      */
 308     /* very small integers. Probably faster than maintaining type       */
 309     /* info.                                                            */
 310     if (result != 0) {
 311         result -> sd_tag = SEQUENCE_TAG;
 312         result -> sd_first = first;
 313         result -> sd_second = second;
 314     }
 315     return((complex_descriptor *)result);
 316 }
 317
 318 #ifdef UNDEFINED
 319 complex_descriptor * GC_make_complex_array_descriptor(word nelements,
 320                                                       complex_descriptor *descr)
 321 {
 322     struct ComplexArrayDescriptor * result =
 323         (struct ComplexArrayDescriptor *)
 324                 GC_malloc(sizeof(struct ComplexArrayDescriptor));
 325
 326     if (result != 0) {
 327         result -> ad_tag = ARRAY_TAG;
 328         result -> ad_nelements = nelements;
 329         result -> ad_element_descr = descr;
 330     }
 331     return((complex_descriptor *)result);
 332 }
 333 #endif
 334
 335 STATIC ptr_t * GC_eobjfreelist;
 336
 337 STATIC ptr_t * GC_arobjfreelist;
 338
 339 STATIC mse * GC_typed_mark_proc(word * addr, mse * mark_stack_ptr,
 340                                 mse * mark_stack_limit, word env);
 341
 342 STATIC mse * GC_array_mark_proc(word * addr, mse * mark_stack_ptr,
 343                                 mse * mark_stack_limit, word env);
 344
 345 /* Caller does not hold allocation lock. */
 346 STATIC void GC_init_explicit_typing(void)
 347 {
 348     register int i;
 349     DCL_LOCK_STATE;
 350
 351     GC_STATIC_ASSERT(sizeof(struct LeafDescriptor) % sizeof(word) == 0);
 352     LOCK();
 353     if (GC_explicit_typing_initialized) {
 354       UNLOCK();
 355       return;
 356     }
 357     GC_explicit_typing_initialized = TRUE;
 358     /* Set up object kind with simple indirect descriptor. */
 359       GC_eobjfreelist = (ptr_t *)GC_new_free_list_inner();
 360       GC_explicit_kind = GC_new_kind_inner(
 361                             (void **)GC_eobjfreelist,
 362                             (((word)WORDS_TO_BYTES(-1)) | GC_DS_PER_OBJECT),
 363                             TRUE, TRUE);
 364                 /* Descriptors are in the last word of the object. */
 365       GC_typed_mark_proc_index = GC_new_proc_inner(GC_typed_mark_proc);
 366     /* Set up object kind with array descriptor. */
 367       GC_arobjfreelist = (ptr_t *)GC_new_free_list_inner();
 368       GC_array_mark_proc_index = GC_new_proc_inner(GC_array_mark_proc);
 369       GC_array_kind = GC_new_kind_inner(
 370                             (void **)GC_arobjfreelist,
 371                             GC_MAKE_PROC(GC_array_mark_proc_index, 0),
 372                             FALSE, TRUE);
 373       for (i = 0; i < WORDSZ/2; i++) {
 374           GC_descr d = (((word)(-1)) >> (WORDSZ - i)) << (WORDSZ - i);
 375           d |= GC_DS_BITMAP;
 376           GC_bm_table[i] = d;
 377       }
 378     UNLOCK();
 379 }
 380
 381 STATIC mse * GC_typed_mark_proc(word * addr, mse * mark_stack_ptr,
 382                                 mse * mark_stack_limit, word env)
 383 {
 384     word bm = GC_ext_descriptors[env].ed_bitmap;
 385     word * current_p = addr;
 386     word current;
 387     ptr_t greatest_ha = GC_greatest_plausible_heap_addr;
 388     ptr_t least_ha = GC_least_plausible_heap_addr;
 389     DECLARE_HDR_CACHE;
 390
 391     INIT_HDR_CACHE;
 392     for (; bm != 0; bm >>= 1, current_p++) {
 393         if (bm & 1) {
 394             current = *current_p;
 395             FIXUP_POINTER(current);
 396             if ((ptr_t)current >= least_ha && (ptr_t)current <= greatest_ha) {
 397                 PUSH_CONTENTS((ptr_t)current, mark_stack_ptr,
 398                               mark_stack_limit, (ptr_t)current_p, exit1);
 399             }
 400         }
 401     }
 402     if (GC_ext_descriptors[env].ed_continued) {
 403         /* Push an entry with the rest of the descriptor back onto the  */
 404         /* stack.  Thus we never do too much work at once.  Note that   */
 405         /* we also can't overflow the mark stack unless we actually     */
 406         /* mark something.                                              */
 407         mark_stack_ptr++;
 408         if (mark_stack_ptr >= mark_stack_limit) {
 409             mark_stack_ptr = GC_signal_mark_stack_overflow(mark_stack_ptr);
 410         }
 411         mark_stack_ptr -> mse_start = (ptr_t)(addr + WORDSZ);
 412         mark_stack_ptr -> mse_descr =
 413                 GC_MAKE_PROC(GC_typed_mark_proc_index, env+1);
 414     }
 415     return(mark_stack_ptr);
 416 }
 417
 418 /* Return the size of the object described by d.  It would be faster to */
 419 /* store this directly, or to compute it as part of                     */
 420 /* GC_push_complex_descriptor, but hopefully it doesn't matter.         */
 421 STATIC word GC_descr_obj_size(complex_descriptor *d)
 422 {
 423     switch(d -> TAG) {
 424       case LEAF_TAG:
 425         return(d -> ld.ld_nelements * d -> ld.ld_size);
 426       case ARRAY_TAG:
 427         return(d -> ad.ad_nelements
 428                * GC_descr_obj_size(d -> ad.ad_element_descr));
 429       case SEQUENCE_TAG:
 430         return(GC_descr_obj_size(d -> sd.sd_first)
 431                + GC_descr_obj_size(d -> sd.sd_second));
 432       default:
 433         ABORT("Bad complex descriptor");
 434         /*NOTREACHED*/ return 0; /*NOTREACHED*/
 435     }
 436 }
 437
 438 /* Push descriptors for the object at addr with complex descriptor d    */
 439 /* onto the mark stack.  Return 0 if the mark stack overflowed.         */
 440 STATIC mse * GC_push_complex_descriptor(word *addr, complex_descriptor *d,
 441                                         mse *msp, mse *msl)
 442 {
 443     register ptr_t current = (ptr_t) addr;
 444     register word nelements;
 445     register word sz;
 446     register word i;
 447
 448     switch(d -> TAG) {
 449       case LEAF_TAG:
 450         {
 451           register GC_descr descr = d -> ld.ld_descriptor;
 452
 453           nelements = d -> ld.ld_nelements;
 454           if (msl - msp <= (ptrdiff_t)nelements) return(0);
 455           sz = d -> ld.ld_size;
 456           for (i = 0; i < nelements; i++) {
 457               msp++;
 458               msp -> mse_start = current;
 459               msp -> mse_descr = descr;
 460               current += sz;
 461           }
 462           return(msp);
 463         }
 464       case ARRAY_TAG:
 465         {
 466           register complex_descriptor *descr = d -> ad.ad_element_descr;
 467
 468           nelements = d -> ad.ad_nelements;
 469           sz = GC_descr_obj_size(descr);
 470           for (i = 0; i < nelements; i++) {
 471               msp = GC_push_complex_descriptor((word *)current, descr,
 472                                                 msp, msl);
 473               if (msp == 0) return(0);
 474               current += sz;
 475           }
 476           return(msp);
 477         }
 478       case SEQUENCE_TAG:
 479         {
 480           sz = GC_descr_obj_size(d -> sd.sd_first);
 481           msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_first,
 482                                            msp, msl);
 483           if (msp == 0) return(0);
 484           current += sz;
 485           msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_second,
 486                                            msp, msl);
 487           return(msp);
 488         }
 489       default:
 490         ABORT("Bad complex descriptor");
 491         /*NOTREACHED*/ return 0; /*NOTREACHED*/
 492    }
 493 }
 494
 495 /*ARGSUSED*/
 496 STATIC mse * GC_array_mark_proc(word * addr, mse * mark_stack_ptr,
 497                                 mse * mark_stack_limit, word env)
 498 {
 499     hdr * hhdr = HDR(addr);
 500     size_t sz = hhdr -> hb_sz;
 501     size_t nwords = BYTES_TO_WORDS(sz);
 502     complex_descriptor * descr = (complex_descriptor *)(addr[nwords-1]);
 503     mse * orig_mark_stack_ptr = mark_stack_ptr;
 504     mse * new_mark_stack_ptr;
 505
 506     if (descr == 0) {
 507         /* Found a reference to a free list entry.  Ignore it. */
 508         return(orig_mark_stack_ptr);
 509     }
 510     /* In use counts were already updated when array descriptor was     */
 511     /* pushed.  Here we only replace it by subobject descriptors, so    */
 512     /* no update is necessary.                                          */
 513     new_mark_stack_ptr = GC_push_complex_descriptor(addr, descr,
 514                                                     mark_stack_ptr,
 515                                                     mark_stack_limit-1);
 516     if (new_mark_stack_ptr == 0) {
 517         /* Doesn't fit.  Conservatively push the whole array as a unit  */
 518         /* and request a mark stack expansion.                          */
 519         /* This cannot cause a mark stack overflow, since it replaces   */
 520         /* the original array entry.                                    */
 521         GC_mark_stack_too_small = TRUE;
 522         new_mark_stack_ptr = orig_mark_stack_ptr + 1;
 523         new_mark_stack_ptr -> mse_start = (ptr_t)addr;
 524         new_mark_stack_ptr -> mse_descr = sz | GC_DS_LENGTH;
 525     } else {
 526         /* Push descriptor itself */
 527         new_mark_stack_ptr++;
 528         new_mark_stack_ptr -> mse_start = (ptr_t)(addr + nwords - 1);
 529         new_mark_stack_ptr -> mse_descr = sizeof(word) | GC_DS_LENGTH;
 530     }
 531     return new_mark_stack_ptr;
 532 }
 533
 534 GC_API GC_descr GC_CALL GC_make_descriptor(GC_bitmap bm, size_t len)
 535 {
 536     signed_word last_set_bit = len - 1;
 537     GC_descr result;
 538     signed_word i;
 539 #   define HIGH_BIT (((word)1) << (WORDSZ - 1))
 540
 541     if (!GC_explicit_typing_initialized) GC_init_explicit_typing();
 542     while (last_set_bit >= 0 && !GC_get_bit(bm, last_set_bit)) last_set_bit --;
 543     if (last_set_bit < 0) return(0 /* no pointers */);
 544 #   if ALIGNMENT == CPP_WORDSZ/8
 545     {
 546       register GC_bool all_bits_set = TRUE;
 547       for (i = 0; i < last_set_bit; i++) {
 548         if (!GC_get_bit(bm, i)) {
 549             all_bits_set = FALSE;
 550             break;
 551         }
 552       }
 553       if (all_bits_set) {
 554         /* An initial section contains all pointers.  Use length descriptor. */
 555         return (WORDS_TO_BYTES(last_set_bit+1) | GC_DS_LENGTH);
 556       }
 557     }
 558 #   endif
 559     if (last_set_bit < BITMAP_BITS) {
 560         /* Hopefully the common case.                   */
 561         /* Build bitmap descriptor (with bits reversed) */
 562         result = HIGH_BIT;
 563         for (i = last_set_bit - 1; i >= 0; i--) {
 564             result >>= 1;
 565             if (GC_get_bit(bm, i)) result |= HIGH_BIT;
 566         }
 567         result |= GC_DS_BITMAP;
 568         return(result);
 569     } else {
 570         signed_word index;
 571
 572         index = GC_add_ext_descriptor(bm, (word)last_set_bit+1);
 573         if (index == -1) return(WORDS_TO_BYTES(last_set_bit+1) | GC_DS_LENGTH);
 574                                 /* Out of memory: use conservative      */
 575                                 /* approximation.                       */
 576         result = GC_MAKE_PROC(GC_typed_mark_proc_index, (word)index);
 577         return result;
 578     }
 579 }
 580
 581 void * GC_clear_stack(void *);
 582
 583 #define GENERAL_MALLOC(lb,k) \
 584     (void *)GC_clear_stack(GC_generic_malloc((word)lb, k))
 585
 586 #define GENERAL_MALLOC_IOP(lb,k) \
 587     (void *)GC_clear_stack(GC_generic_malloc_ignore_off_page(lb, k))
 588
 589 GC_API void * GC_CALL GC_malloc_explicitly_typed(size_t lb, GC_descr d)
 590 {
 591     ptr_t op;
 592     ptr_t * opp;
 593     size_t lg;
 594     DCL_LOCK_STATE;
 595
 596     lb += TYPD_EXTRA_BYTES;
 597     if(SMALL_OBJ(lb)) {
 598         lg = GC_size_map[lb];
 599         opp = &(GC_eobjfreelist[lg]);
 600         LOCK();
 601         if( (op = *opp) == 0 ) {
 602             UNLOCK();
 603             op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind);
 604             if (0 == op) return 0;
 605             lg = GC_size_map[lb];       /* May have been uninitialized. */
 606         } else {
 607             *opp = obj_link(op);
 608             obj_link(op) = 0;
 609             GC_bytes_allocd += GRANULES_TO_BYTES(lg);
 610             UNLOCK();
 611         }
 612         ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d;
 613    } else {
 614        op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind);
 615        if (op != NULL) {
 616             lg = BYTES_TO_GRANULES(GC_size(op));
 617             ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d;
 618        }
 619    }
 620    return((void *) op);
 621 }
 622
 623 GC_API void * GC_CALL GC_malloc_explicitly_typed_ignore_off_page(size_t lb,
 624                                                                 GC_descr d)
 625 {
 626 ptr_t op;
 627 ptr_t * opp;
 628 size_t lg;
 629 DCL_LOCK_STATE;
 630
 631     lb += TYPD_EXTRA_BYTES;
 632     if( SMALL_OBJ(lb) ) {
 633         lg = GC_size_map[lb];
 634         opp = &(GC_eobjfreelist[lg]);
 635         LOCK();
 636         if( (op = *opp) == 0 ) {
 637             UNLOCK();
 638             op = (ptr_t)GENERAL_MALLOC_IOP(lb, GC_explicit_kind);
 639             if (0 == op) return 0;
 640             lg = GC_size_map[lb];       /* May have been uninitialized. */
 641         } else {
 642             *opp = obj_link(op);
 643             obj_link(op) = 0;
 644             GC_bytes_allocd += GRANULES_TO_BYTES(lg);
 645             UNLOCK();
 646         }
 647         ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d;
 648    } else {
 649        op = (ptr_t)GENERAL_MALLOC_IOP(lb, GC_explicit_kind);
 650        if (op != NULL) {
 651          lg = BYTES_TO_WORDS(GC_size(op));
 652          ((word *)op)[GRANULES_TO_WORDS(lg) - 1] = d;
 653        }
 654    }
 655    return((void *) op);
 656 }
 657
 658 GC_API void * GC_CALL GC_calloc_explicitly_typed(size_t n, size_t lb,
 659                                                 GC_descr d)
 660 {
 661 ptr_t op;
 662 ptr_t * opp;
 663 size_t lg;
 664 GC_descr simple_descr;
 665 complex_descriptor *complex_descr;
 666 register int descr_type;
 667 struct LeafDescriptor leaf;
 668 DCL_LOCK_STATE;
 669
 670     descr_type = GC_make_array_descriptor((word)n, (word)lb, d,
 671                                           &simple_descr, &complex_descr, &leaf);
 672     switch(descr_type) {
 673         case NO_MEM: return(0);
 674         case SIMPLE: return(GC_malloc_explicitly_typed(n*lb, simple_descr));
 675         case LEAF:
 676             lb *= n;
 677             lb += sizeof(struct LeafDescriptor) + TYPD_EXTRA_BYTES;
 678             break;
 679         case COMPLEX:
 680             lb *= n;
 681             lb += TYPD_EXTRA_BYTES;
 682             break;
 683     }
 684     if( SMALL_OBJ(lb) ) {
 685         lg = GC_size_map[lb];
 686         opp = &(GC_arobjfreelist[lg]);
 687         LOCK();
 688         if( (op = *opp) == 0 ) {
 689             UNLOCK();
 690             op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind);
 691             if (0 == op) return(0);
 692             lg = GC_size_map[lb];       /* May have been uninitialized. */
 693         } else {
 694             *opp = obj_link(op);
 695             obj_link(op) = 0;
 696             GC_bytes_allocd += GRANULES_TO_BYTES(lg);
 697             UNLOCK();
 698         }
 699    } else {
 700        op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind);
 701        if (0 == op) return(0);
 702        lg = BYTES_TO_GRANULES(GC_size(op));
 703    }
 704    if (descr_type == LEAF) {
 705        /* Set up the descriptor inside the object itself. */
 706        volatile struct LeafDescriptor * lp =
 707            (struct LeafDescriptor *)
 708                ((word *)op
 709                 + GRANULES_TO_WORDS(lg)
 710                 - (BYTES_TO_WORDS(sizeof(struct LeafDescriptor)) + 1));
 711
 712        lp -> ld_tag = LEAF_TAG;
 713        lp -> ld_size = leaf.ld_size;
 714        lp -> ld_nelements = leaf.ld_nelements;
 715        lp -> ld_descriptor = leaf.ld_descriptor;
 716        ((volatile word *)op)[GRANULES_TO_WORDS(lg) - 1] = (word)lp;
 717    } else {
 718        size_t lw = GRANULES_TO_WORDS(lg);
 719
 720        ((word *)op)[lw - 1] = (word)complex_descr;
 721        /* Make sure the descriptor is cleared once there is any danger  */
 722        /* it may have been collected.                                   */
 723        if (GC_general_register_disappearing_link((void * *)((word *)op+lw-1),
 724                                                  op) == 2) {
 725            /* Couldn't register it due to lack of memory.  Punt.        */
 726            /* This will probably fail too, but gives the recovery code  */
 727            /* a chance.                                                 */
 728            return(GC_malloc(n*lb));
 729        }
 730    }
 731    return((void *) op);
 732 }