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