Back to index

plt-scheme  4.2.1
typd_mlc.c
Go to the documentation of this file.
00001 /*
00002  * Copyright (c) 1991-1994 by Xerox Corporation.  All rights reserved.
00003  * opyright (c) 1999-2000 by Hewlett-Packard Company.  All rights reserved.
00004  *
00005  * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
00006  * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
00007  *
00008  * Permission is hereby granted to use or copy this program
00009  * for any purpose,  provided the above notices are retained on all copies.
00010  * Permission to modify the code and to distribute modified code is granted,
00011  * provided the above notices are retained, and a notice that the code was
00012  * modified is included with the above copyright notice.
00013  *
00014  */
00015 
00016 
00017 /*
00018  * Some simple primitives for allocation with explicit type information.
00019  * Simple objects are allocated such that they contain a GC_descr at the
00020  * end (in the last allocated word).  This descriptor may be a procedure
00021  * which then examines an extended descriptor passed as its environment.
00022  *
00023  * Arrays are treated as simple objects if they have sufficiently simple
00024  * structure.  Otherwise they are allocated from an array kind that supplies
00025  * a special mark procedure.  These arrays contain a pointer to a
00026  * complex_descriptor as their last word.
00027  * This is done because the environment field is too small, and the collector
00028  * must trace the complex_descriptor.
00029  *
00030  * Note that descriptors inside objects may appear cleared, if we encounter a
00031  * false refrence to an object on a free list.  In the GC_descr case, this
00032  * is OK, since a 0 descriptor corresponds to examining no fields.
00033  * In the complex_descriptor case, we explicitly check for that case.
00034  *
00035  * MAJOR PARTS OF THIS CODE HAVE NOT BEEN TESTED AT ALL and are not testable,
00036  * since they are not accessible through the current interface.
00037  */
00038 
00039 #include "private/gc_pmark.h"
00040 #include "gc_typed.h"
00041 
00042 # define TYPD_EXTRA_BYTES (sizeof(word) - EXTRA_BYTES)
00043 
00044 GC_bool GC_explicit_typing_initialized = FALSE;
00045 
00046 int GC_explicit_kind;       /* Object kind for objects with indirect  */
00047                      /* (possibly extended) descriptors.              */
00048 
00049 int GC_array_kind;   /* Object kind for objects with complex          */
00050                      /* descriptors and GC_array_mark_proc.           */
00051 
00052 /* Extended descriptors.  GC_typed_mark_proc understands these.       */
00053 /* These are used for simple objects that are larger than what */
00054 /* can be described by a BITMAP_BITS sized bitmap.             */
00055 typedef struct {
00056        word ed_bitmap;      /* lsb corresponds to first word.  */
00057        GC_bool ed_continued;       /* next entry is continuation.     */
00058 } ext_descr;
00059 
00060 /* Array descriptors.  GC_array_mark_proc understands these.   */
00061 /* We may eventually need to add provisions for headers and    */
00062 /* trailers.  Hence we provide for tree structured descriptors, */
00063 /* though we don't really use them currently.                  */
00064 typedef union ComplexDescriptor {
00065     struct LeafDescriptor { /* Describes simple array   */
00066         word ld_tag;
00067 #      define LEAF_TAG 1
00068        word ld_size;        /* bytes per element */
00069                             /* multiple of ALIGNMENT    */
00070        word ld_nelements;   /* Number of elements.      */
00071        GC_descr ld_descriptor; /* A simple length, bitmap,     */
00072                             /* or procedure descriptor. */
00073     } ld;
00074     struct ComplexArrayDescriptor {
00075         word ad_tag;
00076 #      define ARRAY_TAG 2
00077        word ad_nelements;
00078        union ComplexDescriptor * ad_element_descr;
00079     } ad;
00080     struct SequenceDescriptor {
00081         word sd_tag;
00082 #      define SEQUENCE_TAG 3
00083        union ComplexDescriptor * sd_first;
00084        union ComplexDescriptor * sd_second;
00085     } sd;
00086 } complex_descriptor;
00087 #define TAG ld.ld_tag
00088 
00089 ext_descr * GC_ext_descriptors;    /* Points to array of extended     */
00090                             /* descriptors.                    */
00091 
00092 word GC_ed_size = 0; /* Current size of above arrays.   */
00093 # define ED_INITIAL_SIZE 100;
00094 
00095 word GC_avail_descr = 0;    /* Next available slot.            */
00096 
00097 int GC_typed_mark_proc_index;      /* Indices of my mark              */
00098 int GC_array_mark_proc_index;      /* procedures.                     */
00099 
00100 /* Add a multiword bitmap to GC_ext_descriptors arrays.  Return       */
00101 /* starting index.                                      */
00102 /* Returns -1 on failure.                               */
00103 /* Caller does not hold allocation lock.                */
00104 signed_word GC_add_ext_descriptor(bm, nbits)
00105 GC_bitmap bm;
00106 word nbits;
00107 {
00108     register size_t nwords = divWORDSZ(nbits + WORDSZ-1);
00109     register signed_word result;
00110     register word i;
00111     register word last_part;
00112     register int extra_bits;
00113     DCL_LOCK_STATE;
00114 
00115     DISABLE_SIGNALS();
00116     LOCK();
00117     while (GC_avail_descr + nwords >= GC_ed_size) {
00118        ext_descr * new;
00119        size_t new_size;
00120        word ed_size = GC_ed_size;
00121        
00122        UNLOCK();
00123         ENABLE_SIGNALS();
00124        if (ed_size == 0) {
00125            new_size = ED_INITIAL_SIZE;
00126        } else {
00127            new_size = 2 * ed_size;
00128            if (new_size > MAX_ENV) return(-1);
00129        } 
00130        new = (ext_descr *) GC_malloc_atomic(new_size * sizeof(ext_descr));
00131        if (new == 0) return(-1);
00132        DISABLE_SIGNALS();
00133         LOCK();
00134         if (ed_size == GC_ed_size) {
00135             if (GC_avail_descr != 0) {
00136                BCOPY(GC_ext_descriptors, new,
00137                      GC_avail_descr * sizeof(ext_descr));
00138            }
00139            GC_ed_size = new_size;
00140            GC_ext_descriptors = new;
00141        }  /* else another thread already resized it in the meantime */
00142     }
00143     result = GC_avail_descr;
00144     for (i = 0; i < nwords-1; i++) {
00145         GC_ext_descriptors[result + i].ed_bitmap = bm[i];
00146         GC_ext_descriptors[result + i].ed_continued = TRUE;
00147     }
00148     last_part = bm[i];
00149     /* Clear irrelevant bits. */
00150     extra_bits = nwords * WORDSZ - nbits;
00151     last_part <<= extra_bits;
00152     last_part >>= extra_bits;
00153     GC_ext_descriptors[result + i].ed_bitmap = last_part;
00154     GC_ext_descriptors[result + i].ed_continued = FALSE;
00155     GC_avail_descr += nwords;
00156     UNLOCK();
00157     ENABLE_SIGNALS();
00158     return(result);
00159 }
00160 
00161 /* Table of bitmap descriptors for n word long all pointer objects.   */
00162 GC_descr GC_bm_table[WORDSZ/2];
00163        
00164 /* Return a descriptor for the concatenation of 2 nwords long objects,       */
00165 /* each of which is described by descriptor.                          */
00166 /* The result is known to be short enough to fit into a bitmap        */
00167 /* descriptor.                                                        */
00168 /* Descriptor is a GC_DS_LENGTH or GC_DS_BITMAP descriptor.           */
00169 GC_descr GC_double_descr(descriptor, nwords)
00170 register GC_descr descriptor;
00171 register word nwords;
00172 {
00173     if ((descriptor & GC_DS_TAGS) == GC_DS_LENGTH) {
00174         descriptor = GC_bm_table[BYTES_TO_WORDS((word)descriptor)];
00175     };
00176     descriptor |= (descriptor & ~GC_DS_TAGS) >> nwords;
00177     return(descriptor);
00178 }
00179 
00180 complex_descriptor * GC_make_sequence_descriptor();
00181 
00182 /* Build a descriptor for an array with nelements elements,    */
00183 /* each of which can be described by a simple descriptor.      */
00184 /* We try to optimize some common cases.                */
00185 /* If the result is COMPLEX, then a complex_descr* is returned  */
00186 /* in *complex_d.                                              */
00187 /* If the result is LEAF, then we built a LeafDescriptor in    */
00188 /* the structure pointed to by leaf.                           */
00189 /* The tag in the leaf structure is not set.                   */
00190 /* If the result is SIMPLE, then a GC_descr                    */
00191 /* is returned in *simple_d.                                   */
00192 /* If the result is NO_MEM, then                        */
00193 /* we failed to allocate the descriptor.                */
00194 /* The implementation knows that GC_DS_LENGTH is 0.            */
00195 /* *leaf, *complex_d, and *simple_d may be used as temporaries */
00196 /* during the construction.                             */
00197 # define COMPLEX 2
00198 # define LEAF 1
00199 # define SIMPLE 0
00200 # define NO_MEM (-1)
00201 int GC_make_array_descriptor(nelements, size, descriptor,
00202                           simple_d, complex_d, leaf)
00203 word size;
00204 word nelements;
00205 GC_descr descriptor;
00206 GC_descr *simple_d;
00207 complex_descriptor **complex_d;
00208 struct LeafDescriptor * leaf;
00209 {
00210 #   define OPT_THRESHOLD 50
00211        /* For larger arrays, we try to combine descriptors of adjacent       */
00212        /* descriptors to speed up marking, and to reduce the amount   */
00213        /* of space needed on the mark stack.                          */
00214     if ((descriptor & GC_DS_TAGS) == GC_DS_LENGTH) {
00215       if ((word)descriptor == size) {
00216        *simple_d = nelements * descriptor;
00217        return(SIMPLE);
00218       } else if ((word)descriptor == 0) {
00219         *simple_d = (GC_descr)0;
00220         return(SIMPLE);
00221       }
00222     }
00223     if (nelements <= OPT_THRESHOLD) {
00224       if (nelements <= 1) {
00225         if (nelements == 1) {
00226             *simple_d = descriptor;
00227             return(SIMPLE);
00228         } else {
00229             *simple_d = (GC_descr)0;
00230             return(SIMPLE);
00231         }
00232       }
00233     } else if (size <= BITMAP_BITS/2
00234               && (descriptor & GC_DS_TAGS) != GC_DS_PROC
00235               && (size & (sizeof(word)-1)) == 0) {
00236       int result =      
00237           GC_make_array_descriptor(nelements/2, 2*size,
00238                                GC_double_descr(descriptor,
00239                                              BYTES_TO_WORDS(size)),
00240                                simple_d, complex_d, leaf);
00241       if ((nelements & 1) == 0) {
00242           return(result);
00243       } else {
00244           struct LeafDescriptor * one_element =
00245               (struct LeafDescriptor *)
00246               GC_malloc_atomic(sizeof(struct LeafDescriptor));
00247           
00248           if (result == NO_MEM || one_element == 0) return(NO_MEM);
00249           one_element -> ld_tag = LEAF_TAG;
00250           one_element -> ld_size = size;
00251           one_element -> ld_nelements = 1;
00252           one_element -> ld_descriptor = descriptor;
00253           switch(result) {
00254             case SIMPLE:
00255             {
00256               struct LeafDescriptor * beginning =
00257                 (struct LeafDescriptor *)
00258                 GC_malloc_atomic(sizeof(struct LeafDescriptor));
00259               if (beginning == 0) return(NO_MEM);
00260               beginning -> ld_tag = LEAF_TAG;
00261               beginning -> ld_size = size;
00262               beginning -> ld_nelements = 1;
00263               beginning -> ld_descriptor = *simple_d;
00264               *complex_d = GC_make_sequence_descriptor(
00265                                    (complex_descriptor *)beginning,
00266                                    (complex_descriptor *)one_element);
00267               break;
00268             }
00269             case LEAF:
00270             {
00271               struct LeafDescriptor * beginning =
00272                 (struct LeafDescriptor *)
00273                 GC_malloc_atomic(sizeof(struct LeafDescriptor));
00274               if (beginning == 0) return(NO_MEM);
00275               beginning -> ld_tag = LEAF_TAG;
00276               beginning -> ld_size = leaf -> ld_size;
00277               beginning -> ld_nelements = leaf -> ld_nelements;
00278               beginning -> ld_descriptor = leaf -> ld_descriptor;
00279               *complex_d = GC_make_sequence_descriptor(
00280                                    (complex_descriptor *)beginning,
00281                                    (complex_descriptor *)one_element);
00282               break;
00283             }
00284             case COMPLEX:
00285               *complex_d = GC_make_sequence_descriptor(
00286                                    *complex_d,
00287                                    (complex_descriptor *)one_element);
00288               break;
00289           }
00290           return(COMPLEX);
00291       }
00292     }
00293     {
00294         leaf -> ld_size = size;
00295         leaf -> ld_nelements = nelements;
00296         leaf -> ld_descriptor = descriptor;
00297         return(LEAF);
00298     }
00299 }
00300 
00301 complex_descriptor * GC_make_sequence_descriptor(first, second)
00302 complex_descriptor * first;
00303 complex_descriptor * second;
00304 {
00305     struct SequenceDescriptor * result =
00306         (struct SequenceDescriptor *)
00307               GC_malloc(sizeof(struct SequenceDescriptor));
00308     /* Can't result in overly conservative marking, since tags are    */
00309     /* very small integers. Probably faster than maintaining type     */
00310     /* info.                                                   */    
00311     if (result != 0) {
00312        result -> sd_tag = SEQUENCE_TAG;
00313         result -> sd_first = first;
00314         result -> sd_second = second;
00315     }
00316     return((complex_descriptor *)result);
00317 }
00318 
00319 #ifdef UNDEFINED
00320 complex_descriptor * GC_make_complex_array_descriptor(nelements, descr)
00321 word nelements;
00322 complex_descriptor * descr;
00323 {
00324     struct ComplexArrayDescriptor * result =
00325         (struct ComplexArrayDescriptor *)
00326               GC_malloc(sizeof(struct ComplexArrayDescriptor));
00327     
00328     if (result != 0) {
00329        result -> ad_tag = ARRAY_TAG;
00330         result -> ad_nelements = nelements;
00331         result -> ad_element_descr = descr;
00332     }
00333     return((complex_descriptor *)result);
00334 }
00335 #endif
00336 
00337 ptr_t * GC_eobjfreelist;
00338 
00339 ptr_t * GC_arobjfreelist;
00340 
00341 mse * GC_typed_mark_proc GC_PROTO((register word * addr,
00342                                register mse * mark_stack_ptr,
00343                                mse * mark_stack_limit,
00344                                word env));
00345 
00346 mse * GC_array_mark_proc GC_PROTO((register word * addr,
00347                                register mse * mark_stack_ptr,
00348                                mse * mark_stack_limit,
00349                                word env));
00350 
00351 /* Caller does not hold allocation lock. */
00352 void GC_init_explicit_typing()
00353 {
00354     register int i;
00355     DCL_LOCK_STATE;
00356 
00357     
00358 #   ifdef PRINTSTATS
00359        if (sizeof(struct LeafDescriptor) % sizeof(word) != 0)
00360            ABORT("Bad leaf descriptor size");
00361 #   endif
00362     DISABLE_SIGNALS();
00363     LOCK();
00364     if (GC_explicit_typing_initialized) {
00365       UNLOCK();
00366       ENABLE_SIGNALS();
00367       return;
00368     }
00369     GC_explicit_typing_initialized = TRUE;
00370     /* Set up object kind with simple indirect descriptor. */
00371       GC_eobjfreelist = (ptr_t *)GC_new_free_list_inner();
00372       GC_explicit_kind = GC_new_kind_inner(
00373                          (void **)GC_eobjfreelist,
00374                          (((word)WORDS_TO_BYTES(-1)) | GC_DS_PER_OBJECT),
00375                          TRUE, TRUE);
00376               /* Descriptors are in the last word of the object. */
00377       GC_typed_mark_proc_index = GC_new_proc_inner(GC_typed_mark_proc);
00378     /* Set up object kind with array descriptor. */
00379       GC_arobjfreelist = (ptr_t *)GC_new_free_list_inner();
00380       GC_array_mark_proc_index = GC_new_proc_inner(GC_array_mark_proc);
00381       GC_array_kind = GC_new_kind_inner(
00382                          (void **)GC_arobjfreelist,
00383                          GC_MAKE_PROC(GC_array_mark_proc_index, 0),
00384                          FALSE, TRUE);
00385       for (i = 0; i < WORDSZ/2; i++) {
00386           GC_descr d = (((word)(-1)) >> (WORDSZ - i)) << (WORDSZ - i);
00387           d |= GC_DS_BITMAP;
00388           GC_bm_table[i] = d;
00389       }
00390     UNLOCK();
00391     ENABLE_SIGNALS();
00392 }
00393 
00394 # if defined(__STDC__) || defined(__cplusplus)
00395     mse * GC_typed_mark_proc(register word * addr,
00396                           register mse * mark_stack_ptr,
00397                           mse * mark_stack_limit,
00398                           word env)
00399 # else
00400     mse * GC_typed_mark_proc(addr, mark_stack_ptr, mark_stack_limit, env)
00401     register word * addr;
00402     register mse * mark_stack_ptr;
00403     mse * mark_stack_limit;
00404     word env;
00405 # endif
00406 {
00407     register word bm = GC_ext_descriptors[env].ed_bitmap;
00408     register word * current_p = addr;
00409     register word current;
00410     register ptr_t greatest_ha = GC_greatest_plausible_heap_addr;
00411     register ptr_t least_ha = GC_least_plausible_heap_addr;
00412     
00413     for (; bm != 0; bm >>= 1, current_p++) {
00414        if (bm & 1) {
00415            current = *current_p;
00416            FIXUP_POINTER(current);
00417            if ((ptr_t)current >= least_ha && (ptr_t)current <= greatest_ha) {
00418                PUSH_CONTENTS((ptr_t)current, mark_stack_ptr,
00419                            mark_stack_limit, current_p, exit1);
00420            }
00421        }
00422     }
00423     if (GC_ext_descriptors[env].ed_continued) {
00424         /* Push an entry with the rest of the descriptor back onto the       */
00425         /* stack.  Thus we never do too much work at once.  Note that */
00426         /* we also can't overflow the mark stack unless we actually   */
00427         /* mark something.                                     */
00428         mark_stack_ptr++;
00429         if (mark_stack_ptr >= mark_stack_limit) {
00430             mark_stack_ptr = GC_signal_mark_stack_overflow(mark_stack_ptr);
00431         }
00432         mark_stack_ptr -> mse_start = addr + WORDSZ;
00433         mark_stack_ptr -> mse_descr =
00434               GC_MAKE_PROC(GC_typed_mark_proc_index, env+1);
00435     }
00436     return(mark_stack_ptr);
00437 }
00438 
00439 /* Return the size of the object described by d.  It would be faster to      */
00440 /* store this directly, or to compute it as part of                   */
00441 /* GC_push_complex_descriptor, but hopefully it doesn't matter.              */
00442 word GC_descr_obj_size(d)
00443 register complex_descriptor *d;
00444 {
00445     switch(d -> TAG) {
00446       case LEAF_TAG:
00447        return(d -> ld.ld_nelements * d -> ld.ld_size);
00448       case ARRAY_TAG:
00449         return(d -> ad.ad_nelements
00450                * GC_descr_obj_size(d -> ad.ad_element_descr));
00451       case SEQUENCE_TAG:
00452         return(GC_descr_obj_size(d -> sd.sd_first)
00453                + GC_descr_obj_size(d -> sd.sd_second));
00454       default:
00455         ABORT("Bad complex descriptor");
00456         /*NOTREACHED*/ return 0; /*NOTREACHED*/
00457     }
00458 }
00459 
00460 /* Push descriptors for the object at addr with complex descriptor d  */
00461 /* onto the mark stack.  Return 0 if the mark stack overflowed.       */
00462 mse * GC_push_complex_descriptor(addr, d, msp, msl)
00463 word * addr;
00464 register complex_descriptor *d;
00465 register mse * msp;
00466 mse * msl;
00467 {
00468     register ptr_t current = (ptr_t) addr;
00469     register word nelements;
00470     register word sz;
00471     register word i;
00472     
00473     switch(d -> TAG) {
00474       case LEAF_TAG:
00475         {
00476           register GC_descr descr = d -> ld.ld_descriptor;
00477           
00478           nelements = d -> ld.ld_nelements;
00479           if (msl - msp <= (ptrdiff_t)nelements) return(0);
00480           sz = d -> ld.ld_size;
00481           for (i = 0; i < nelements; i++) {
00482               msp++;
00483               msp -> mse_start = (word *)current;
00484               msp -> mse_descr = descr;
00485               current += sz;
00486           }
00487           return(msp);
00488         }
00489       case ARRAY_TAG:
00490         {
00491           register complex_descriptor *descr = d -> ad.ad_element_descr;
00492           
00493           nelements = d -> ad.ad_nelements;
00494           sz = GC_descr_obj_size(descr);
00495           for (i = 0; i < nelements; i++) {
00496               msp = GC_push_complex_descriptor((word *)current, descr,
00497                                                  msp, msl);
00498               if (msp == 0) return(0);
00499               current += sz;
00500           }
00501           return(msp);
00502         }
00503       case SEQUENCE_TAG:
00504         {
00505           sz = GC_descr_obj_size(d -> sd.sd_first);
00506           msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_first,
00507                                       msp, msl);
00508           if (msp == 0) return(0);
00509           current += sz;
00510           msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_second,
00511                                       msp, msl);
00512           return(msp);
00513         }
00514       default:
00515         ABORT("Bad complex descriptor");
00516         /*NOTREACHED*/ return 0; /*NOTREACHED*/
00517    }
00518 }
00519 
00520 /*ARGSUSED*/
00521 # if defined(__STDC__) || defined(__cplusplus)
00522     mse * GC_array_mark_proc(register word * addr,
00523                           register mse * mark_stack_ptr,
00524                           mse * mark_stack_limit,
00525                           word env)
00526 # else
00527     mse * GC_array_mark_proc(addr, mark_stack_ptr, mark_stack_limit, env)
00528     register word * addr;
00529     register mse * mark_stack_ptr;
00530     mse * mark_stack_limit;
00531     word env;
00532 # endif
00533 {
00534     register hdr * hhdr = HDR(addr);
00535     register word sz = hhdr -> hb_sz;
00536     register complex_descriptor * descr = (complex_descriptor *)(addr[sz-1]);
00537     mse * orig_mark_stack_ptr = mark_stack_ptr;
00538     mse * new_mark_stack_ptr;
00539     
00540     if (descr == 0) {
00541        /* Found a reference to a free list entry.  Ignore it. */
00542        return(orig_mark_stack_ptr);
00543     }
00544     /* In use counts were already updated when array descriptor was   */
00545     /* pushed.  Here we only replace it by subobject descriptors, so  */
00546     /* no update is necessary.                                        */
00547     new_mark_stack_ptr = GC_push_complex_descriptor(addr, descr,
00548                                               mark_stack_ptr,
00549                                               mark_stack_limit-1);
00550     if (new_mark_stack_ptr == 0) {
00551        /* Doesn't fit.  Conservatively push the whole array as a unit */
00552        /* and request a mark stack expansion.                         */
00553        /* This cannot cause a mark stack overflow, since it replaces  */
00554        /* the original array entry.                                   */
00555        GC_mark_stack_too_small = TRUE;
00556        new_mark_stack_ptr = orig_mark_stack_ptr + 1;
00557        new_mark_stack_ptr -> mse_start = addr;
00558        new_mark_stack_ptr -> mse_descr = WORDS_TO_BYTES(sz) | GC_DS_LENGTH;
00559     } else {
00560         /* Push descriptor itself */
00561         new_mark_stack_ptr++;
00562         new_mark_stack_ptr -> mse_start = addr + sz - 1;
00563         new_mark_stack_ptr -> mse_descr = sizeof(word) | GC_DS_LENGTH;
00564     }
00565     return(new_mark_stack_ptr);
00566 }
00567 
00568 #if defined(__STDC__) || defined(__cplusplus)
00569   GC_descr GC_make_descriptor(GC_bitmap bm, size_t len)
00570 #else
00571   GC_descr GC_make_descriptor(bm, len)
00572   GC_bitmap bm;
00573   size_t len;
00574 #endif
00575 {
00576     register signed_word last_set_bit = len - 1;
00577     register word result;
00578     register int i;
00579 #   define HIGH_BIT (((word)1) << (WORDSZ - 1))
00580     
00581     if (!GC_explicit_typing_initialized) GC_init_explicit_typing();
00582     while (last_set_bit >= 0 && !GC_get_bit(bm, last_set_bit)) last_set_bit --;
00583     if (last_set_bit < 0) return(0 /* no pointers */);
00584 #   if ALIGNMENT == CPP_WORDSZ/8
00585     {
00586       register GC_bool all_bits_set = TRUE;
00587       for (i = 0; i < last_set_bit; i++) {
00588        if (!GC_get_bit(bm, i)) {
00589            all_bits_set = FALSE;
00590            break;
00591        }
00592       }
00593       if (all_bits_set) {
00594        /* An initial section contains all pointers.  Use length descriptor. */
00595         return(WORDS_TO_BYTES(last_set_bit+1) | GC_DS_LENGTH);
00596       }
00597     }
00598 #   endif
00599     if (last_set_bit < BITMAP_BITS) {
00600        /* Hopefully the common case.                    */
00601        /* Build bitmap descriptor (with bits reversed)  */
00602        result = HIGH_BIT;
00603        for (i = last_set_bit - 1; i >= 0; i--) {
00604            result >>= 1;
00605            if (GC_get_bit(bm, i)) result |= HIGH_BIT;
00606        }
00607        result |= GC_DS_BITMAP;
00608        return(result);
00609     } else {
00610        signed_word index;
00611        
00612        index = GC_add_ext_descriptor(bm, (word)last_set_bit+1);
00613        if (index == -1) return(WORDS_TO_BYTES(last_set_bit+1) | GC_DS_LENGTH);
00614                             /* Out of memory: use conservative */
00615                             /* approximation.                  */
00616        result = GC_MAKE_PROC(GC_typed_mark_proc_index, (word)index);
00617        return(result);
00618     }
00619 }
00620 
00621 ptr_t GC_clear_stack();
00622 
00623 #define GENERAL_MALLOC(lb,k) \
00624     (GC_PTR)GC_clear_stack(GC_generic_malloc((word)lb, k))
00625     
00626 #define GENERAL_MALLOC_IOP(lb,k) \
00627     (GC_PTR)GC_clear_stack(GC_generic_malloc_ignore_off_page(lb, k))
00628 
00629 #if defined(__STDC__) || defined(__cplusplus)
00630   void * GC_malloc_explicitly_typed(size_t lb, GC_descr d)
00631 #else
00632   char * GC_malloc_explicitly_typed(lb, d)
00633   size_t lb;
00634   GC_descr d;
00635 #endif
00636 {
00637 register ptr_t op;
00638 register ptr_t * opp;
00639 register word lw;
00640 DCL_LOCK_STATE;
00641 
00642     lb += TYPD_EXTRA_BYTES;
00643     if( SMALL_OBJ(lb) ) {
00644 #       ifdef MERGE_SIZES
00645          lw = GC_size_map[lb];
00646 #      else
00647          lw = ALIGNED_WORDS(lb);
00648 #       endif
00649        opp = &(GC_eobjfreelist[lw]);
00650        FASTLOCK();
00651         if( !FASTLOCK_SUCCEEDED() || (op = *opp) == 0 ) {
00652             FASTUNLOCK();
00653             op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind);
00654            if (0 == op) return 0;
00655 #          ifdef MERGE_SIZES
00656               lw = GC_size_map[lb];       /* May have been uninitialized.    */
00657 #          endif
00658         } else {
00659             *opp = obj_link(op);
00660            obj_link(op) = 0;
00661             GC_words_allocd += lw;
00662             FASTUNLOCK();
00663         }
00664    } else {
00665        op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind);
00666        if (op != NULL)
00667            lw = BYTES_TO_WORDS(GC_size(op));
00668    }
00669    if (op != NULL)
00670        ((word *)op)[lw - 1] = d;
00671    return((GC_PTR) op);
00672 }
00673 
00674 #if defined(__STDC__) || defined(__cplusplus)
00675   void * GC_malloc_explicitly_typed_ignore_off_page(size_t lb, GC_descr d)
00676 #else
00677   char * GC_malloc_explicitly_typed_ignore_off_page(lb, d)
00678   size_t lb;
00679   GC_descr d;
00680 #endif
00681 {
00682 register ptr_t op;
00683 register ptr_t * opp;
00684 register word lw;
00685 DCL_LOCK_STATE;
00686 
00687     lb += TYPD_EXTRA_BYTES;
00688     if( SMALL_OBJ(lb) ) {
00689 #       ifdef MERGE_SIZES
00690          lw = GC_size_map[lb];
00691 #      else
00692          lw = ALIGNED_WORDS(lb);
00693 #       endif
00694        opp = &(GC_eobjfreelist[lw]);
00695        FASTLOCK();
00696         if( !FASTLOCK_SUCCEEDED() || (op = *opp) == 0 ) {
00697             FASTUNLOCK();
00698             op = (ptr_t)GENERAL_MALLOC_IOP(lb, GC_explicit_kind);
00699 #          ifdef MERGE_SIZES
00700               lw = GC_size_map[lb];       /* May have been uninitialized.    */
00701 #          endif
00702         } else {
00703             *opp = obj_link(op);
00704            obj_link(op) = 0;
00705             GC_words_allocd += lw;
00706             FASTUNLOCK();
00707         }
00708    } else {
00709        op = (ptr_t)GENERAL_MALLOC_IOP(lb, GC_explicit_kind);
00710        if (op != NULL)
00711        lw = BYTES_TO_WORDS(GC_size(op));
00712    }
00713    if (op != NULL)
00714        ((word *)op)[lw - 1] = d;
00715    return((GC_PTR) op);
00716 }
00717 
00718 #if defined(__STDC__) || defined(__cplusplus)
00719   void * GC_calloc_explicitly_typed(size_t n,
00720                                 size_t lb,
00721                                 GC_descr d)
00722 #else
00723   char * GC_calloc_explicitly_typed(n, lb, d)
00724   size_t n;
00725   size_t lb;
00726   GC_descr d;
00727 #endif
00728 {
00729 register ptr_t op;
00730 register ptr_t * opp;
00731 register word lw;
00732 GC_descr simple_descr;
00733 complex_descriptor *complex_descr;
00734 register int descr_type;
00735 struct LeafDescriptor leaf;
00736 DCL_LOCK_STATE;
00737 
00738     descr_type = GC_make_array_descriptor((word)n, (word)lb, d,
00739                                      &simple_descr, &complex_descr, &leaf);
00740     switch(descr_type) {
00741        case NO_MEM: return(0);
00742        case SIMPLE: return(GC_malloc_explicitly_typed(n*lb, simple_descr));
00743        case LEAF:
00744            lb *= n;
00745            lb += sizeof(struct LeafDescriptor) + TYPD_EXTRA_BYTES;
00746            break;
00747        case COMPLEX:
00748            lb *= n;
00749            lb += TYPD_EXTRA_BYTES;
00750            break;
00751     }
00752     if( SMALL_OBJ(lb) ) {
00753 #       ifdef MERGE_SIZES
00754          lw = GC_size_map[lb];
00755 #      else
00756          lw = ALIGNED_WORDS(lb);
00757 #       endif
00758        opp = &(GC_arobjfreelist[lw]);
00759        FASTLOCK();
00760         if( !FASTLOCK_SUCCEEDED() || (op = *opp) == 0 ) {
00761             FASTUNLOCK();
00762             op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind);
00763            if (0 == op) return(0);
00764 #          ifdef MERGE_SIZES
00765               lw = GC_size_map[lb];       /* May have been uninitialized.    */            
00766 #          endif
00767         } else {
00768             *opp = obj_link(op);
00769            obj_link(op) = 0;
00770             GC_words_allocd += lw;
00771             FASTUNLOCK();
00772         }
00773    } else {
00774        op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind);
00775        if (0 == op) return(0);
00776        lw = BYTES_TO_WORDS(GC_size(op));
00777    }
00778    if (descr_type == LEAF) {
00779        /* Set up the descriptor inside the object itself. */
00780        VOLATILE struct LeafDescriptor * lp =
00781            (struct LeafDescriptor *)
00782                ((word *)op
00783                 + lw - (BYTES_TO_WORDS(sizeof(struct LeafDescriptor)) + 1));
00784                 
00785        lp -> ld_tag = LEAF_TAG;
00786        lp -> ld_size = leaf.ld_size;
00787        lp -> ld_nelements = leaf.ld_nelements;
00788        lp -> ld_descriptor = leaf.ld_descriptor;
00789        ((VOLATILE word *)op)[lw - 1] = (word)lp;
00790    } else {
00791        extern unsigned GC_finalization_failures;
00792        unsigned ff = GC_finalization_failures;
00793        
00794        ((word *)op)[lw - 1] = (word)complex_descr;
00795        /* Make sure the descriptor is cleared once there is any danger       */
00796        /* it may have been collected.                                 */
00797        (void)
00798          GC_general_register_disappearing_link((GC_PTR *)
00799                                             ((word *)op+lw-1),
00800                                                     (GC_PTR) op);
00801        if (ff != GC_finalization_failures) {
00802           /* Couldn't register it due to lack of memory.  Punt.       */
00803           /* This will probably fail too, but gives the recovery code  */
00804           /* a chance.                                                */
00805           return(GC_malloc(n*lb));
00806        }                              
00807    }
00808    return((GC_PTR) op);
00809 }