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