home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sa104os2.zip / SATHR104.ZIP / SATHER / SYSTEM / GC / TYPD_MLC.C < prev   
C/C++ Source or Header  |  1994-07-13  |  26KB  |  764 lines
  1. /*
  2.  * Copyright (c) 1991-1994 by Xerox Corporation.  All rights reserved.
  3.  *
  4.  * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
  5.  * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
  6.  *
  7.  * Permission is hereby granted to use or copy this program
  8.  * for any purpose,  provided the above notices are retained on all copies.
  9.  * Permission to modify the code and to distribute modified code is granted,
  10.  * provided the above notices are retained, and a notice that the code was
  11.  * modified is included with the above copyright notice.
  12.  *
  13.  */
  14. /* Boehm, July 13, 1994 12:34 pm PDT */
  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 "gc_priv.h"
  40. #include "gc_mark.h"
  41. #include "gc_typed.h"
  42.  
  43. # ifdef ADD_BYTE_AT_END
  44. #   define EXTRA_BYTES (sizeof(word) - 1)
  45. # else
  46. #   define EXTRA_BYTES (sizeof(word))
  47. # endif
  48.  
  49. bool GC_explicit_typing_initialized = FALSE;
  50.  
  51. int GC_explicit_kind;    /* Object kind for objects with indirect    */
  52.             /* (possibly extended) descriptors.        */
  53.  
  54. int GC_array_kind;    /* Object kind for objects with complex        */
  55.             /* descriptors and GC_array_mark_proc.        */
  56.  
  57. /* Extended descriptors.  GC_typed_mark_proc understands these.    */
  58. /* These are used for simple objects that are larger than what    */
  59. /* can be described by a BITMAP_BITS sized bitmap.        */
  60. typedef struct {
  61.     word ed_bitmap;    /* lsb corresponds to first word.    */
  62.     bool ed_continued;    /* next entry is continuation.    */
  63. } ext_descr;
  64.  
  65. /* Array descriptors.  GC_array_mark_proc understands these.    */
  66. /* We may eventually need to add provisions for headers and    */
  67. /* trailers.  Hence we provide for tree structured descriptors, */
  68. /* though we don't really use them currently.            */
  69. typedef union ComplexDescriptor {
  70.     struct LeafDescriptor {    /* Describes simple array    */
  71.         word ld_tag;
  72. #    define LEAF_TAG 1
  73.     word ld_size;        /* bytes per element    */
  74.                 /* multiple of ALIGNMENT    */
  75.     word ld_nelements;    /* Number of elements.    */
  76.     GC_descr ld_descriptor; /* A simple length, bitmap,    */
  77.                 /* or procedure descriptor.    */
  78.     } ld;
  79.     struct ComplexArrayDescriptor {
  80.         word ad_tag;
  81. #    define ARRAY_TAG 2
  82.     word ad_nelements;
  83.     union ComplexDescriptor * ad_element_descr;
  84.     } ad;
  85.     struct SequenceDescriptor {
  86.         word sd_tag;
  87. #    define SEQUENCE_TAG 3
  88.     union ComplexDescriptor * sd_first;
  89.     union ComplexDescriptor * sd_second;
  90.     } sd;
  91. } complex_descriptor;
  92. #define TAG ld.ld_tag
  93.  
  94. ext_descr * GC_ext_descriptors;    /* Points to array of extended     */
  95.                 /* descriptors.            */
  96.  
  97. word GC_ed_size = 0;    /* Current size of above arrays.    */
  98. # define ED_INITIAL_SIZE 100;
  99.  
  100. word GC_avail_descr = 0;    /* Next available slot.        */
  101.  
  102. int GC_typed_mark_proc_index;    /* Indices of my mark        */
  103. int GC_array_mark_proc_index;    /* procedures.            */
  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(bm, nbits)
  110. GC_bitmap bm;
  111. word nbits;
  112. {
  113.     register size_t nwords = divWORDSZ(nbits + WORDSZ-1);
  114.     register signed_word result;
  115.     register word i;
  116.     register word last_part;
  117.     register int extra_bits;
  118.     DCL_LOCK_STATE;
  119.  
  120.     DISABLE_SIGNALS();
  121.     LOCK();
  122.     while (GC_avail_descr + nwords >= GC_ed_size) {
  123.         ext_descr * new;
  124.         size_t new_size;
  125.         word ed_size = GC_ed_size;
  126.         
  127.         UNLOCK();
  128.         ENABLE_SIGNALS();
  129.         if (ed_size == 0) {
  130.             new_size = ED_INITIAL_SIZE;
  131.         } else {
  132.             new_size = 2 * ed_size;
  133.             if (new_size > MAX_ENV) return(-1);
  134.         } 
  135.         new = (ext_descr *) GC_malloc_atomic(new_size * sizeof(ext_descr));
  136.         if (new == 0) return(-1);
  137.         DISABLE_SIGNALS();
  138.         LOCK();
  139.         if (ed_size == GC_ed_size) {
  140.             if (GC_avail_descr != 0) {
  141.                 BCOPY(GC_ext_descriptors, new,
  142.                       GC_avail_descr * sizeof(ext_descr));
  143.             }
  144.             GC_ed_size = new_size;
  145.             GC_ext_descriptors = new;
  146.         }  /* else another thread already resized it in the meantime */
  147.     }
  148.     result = GC_avail_descr;
  149.     for (i = 0; i < nwords-1; i++) {
  150.         GC_ext_descriptors[result + i].ed_bitmap = bm[i];
  151.         GC_ext_descriptors[result + i].ed_continued = TRUE;
  152.     }
  153.     last_part = bm[i];
  154.     /* Clear irrelevant bits. */
  155.     extra_bits = nwords * WORDSZ - nbits;
  156.     last_part <<= extra_bits;
  157.     last_part >>= extra_bits;
  158.     GC_ext_descriptors[result + i].ed_bitmap = last_part;
  159.     GC_ext_descriptors[result + i].ed_continued = FALSE;
  160.     GC_avail_descr += nwords;
  161.     UNLOCK();
  162.     ENABLE_SIGNALS();
  163.     return(result);
  164. }
  165.  
  166. /* Table of bitmap descriptors for n word long all pointer objects.    */
  167. 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 DS_LENGTH or DS_BITMAP descriptor.            */
  174. GC_descr GC_double_descr(descriptor, nwords)
  175. register GC_descr descriptor;
  176. register word nwords;
  177. {
  178.     if (descriptor && DS_TAGS == DS_LENGTH) {
  179.         descriptor = GC_bm_table[BYTES_TO_WORDS((word)descriptor)];
  180.     };
  181.     descriptor |= (descriptor & ~DS_TAGS) >> nwords;
  182.     return(descriptor);
  183. }
  184.  
  185. complex_descriptor * GC_make_sequence_descriptor();
  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 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. int GC_make_array_descriptor(nelements, size, descriptor,
  207.                  simple_d, complex_d, leaf)
  208. word size;
  209. word nelements;
  210. GC_descr descriptor;
  211. GC_descr *simple_d;
  212. complex_descriptor **complex_d;
  213. struct LeafDescriptor * leaf;
  214. {
  215. #   define OPT_THRESHOLD 50
  216.     /* For larger arrays, we try to combine descriptors of adjacent    */
  217.     /* descriptors to speed up marking, and to reduce the amount    */
  218.     /* of space needed on the mark stack.                */
  219.     if ((descriptor & DS_TAGS) == DS_LENGTH) {
  220.       if ((word)descriptor == size) {
  221.         *simple_d = nelements * descriptor;
  222.         return(SIMPLE);
  223.       } else if ((word)descriptor == 0) {
  224.         *simple_d = (GC_descr)0;
  225.         return(SIMPLE);
  226.       }
  227.     }
  228.     if (nelements <= OPT_THRESHOLD) {
  229.       if (nelements <= 1) {
  230.         if (nelements == 1) {
  231.             *simple_d = descriptor;
  232.             return(SIMPLE);
  233.         } else {
  234.             *simple_d = (GC_descr)0;
  235.             return(SIMPLE);
  236.         }
  237.       }
  238.     } else if (size <= BITMAP_BITS/2
  239.                && (descriptor & DS_TAGS) != DS_PROC
  240.                && (size & (sizeof(word)-1)) == 0) {
  241.       int result =      
  242.           GC_make_array_descriptor(nelements/2, 2*size,
  243.                          GC_double_descr(descriptor,
  244.                                     BYTES_TO_WORDS(size)),
  245.                          simple_d, complex_d, leaf);
  246.       if ((nelements & 1) == 0) {
  247.           return(result);
  248.       } else {
  249.           struct LeafDescriptor * one_element =
  250.               (struct LeafDescriptor *)
  251.             GC_malloc_atomic(sizeof(struct LeafDescriptor));
  252.           
  253.           if (result == NO_MEM || one_element == 0) return(NO_MEM);
  254.           one_element -> ld_tag = LEAF_TAG;
  255.           one_element -> ld_size = size;
  256.           one_element -> ld_nelements = 1;
  257.           one_element -> ld_descriptor = descriptor;
  258.           switch(result) {
  259.             case SIMPLE:
  260.             {
  261.               struct LeafDescriptor * beginning =
  262.                 (struct LeafDescriptor *)
  263.               GC_malloc_atomic(sizeof(struct LeafDescriptor));
  264.               if (beginning == 0) return(NO_MEM);
  265.               beginning -> ld_tag = LEAF_TAG;
  266.               beginning -> ld_size = size;
  267.               beginning -> ld_nelements = 1;
  268.               beginning -> ld_descriptor = *simple_d;
  269.               *complex_d = GC_make_sequence_descriptor(
  270.                           (complex_descriptor *)beginning,
  271.                           (complex_descriptor *)one_element);
  272.               break;
  273.             }
  274.             case LEAF:
  275.             {
  276.               struct LeafDescriptor * beginning =
  277.                 (struct LeafDescriptor *)
  278.               GC_malloc_atomic(sizeof(struct LeafDescriptor));
  279.               if (beginning == 0) return(NO_MEM);
  280.               beginning -> ld_tag = LEAF_TAG;
  281.               beginning -> ld_size = leaf -> ld_size;
  282.               beginning -> ld_nelements = leaf -> ld_nelements;
  283.               beginning -> ld_descriptor = leaf -> ld_descriptor;
  284.               *complex_d = GC_make_sequence_descriptor(
  285.                           (complex_descriptor *)beginning,
  286.                           (complex_descriptor *)one_element);
  287.               break;
  288.             }
  289.             case COMPLEX:
  290.               *complex_d = GC_make_sequence_descriptor(
  291.                           *complex_d,
  292.                           (complex_descriptor *)one_element);
  293.               break;
  294.           }
  295.           return(COMPLEX);
  296.       }
  297.     }
  298.     {
  299.         leaf -> ld_size = size;
  300.         leaf -> ld_nelements = nelements;
  301.         leaf -> ld_descriptor = descriptor;
  302.         return(LEAF);
  303.     }
  304. }
  305.  
  306. complex_descriptor * GC_make_sequence_descriptor(first, second)
  307. complex_descriptor * first;
  308. complex_descriptor * second;
  309. {
  310.     struct SequenceDescriptor * result =
  311.         (struct SequenceDescriptor *)
  312.             GC_malloc(sizeof(struct SequenceDescriptor));
  313.     /* Can't result in overly conservative marking, since tags are    */
  314.     /* very small integers. Probably faster than maintaining type    */
  315.     /* info.                                */    
  316.     if (result != 0) {
  317.         result -> sd_tag = SEQUENCE_TAG;
  318.         result -> sd_first = first;
  319.         result -> sd_second = second;
  320.     }
  321.     return((complex_descriptor *)result);
  322. }
  323.  
  324. #ifdef UNDEFINED
  325. complex_descriptor * GC_make_complex_array_descriptor(nelements, descr)
  326. word nelements;
  327. complex_descriptor * descr;
  328. {
  329.     struct ComplexArrayDescriptor * result =
  330.         (struct ComplexArrayDescriptor *)
  331.             GC_malloc(sizeof(struct ComplexArrayDescriptor));
  332.     
  333.     if (result != 0) {
  334.         result -> ad_tag = ARRAY_TAG;
  335.         result -> ad_nelements = nelements;
  336.         result -> ad_element_descr = descr;
  337.     }
  338.     return((complex_descriptor *)result);
  339. }
  340. #endif
  341.  
  342. ptr_t * GC_eobjfreelist;
  343.  
  344. ptr_t * GC_arobjfreelist;
  345.  
  346. mse * GC_typed_mark_proc();
  347.  
  348. mse * GC_array_mark_proc();
  349.  
  350. GC_descr GC_generic_array_descr;
  351.  
  352. /* Caller does not hold allocation lock. */
  353. void GC_init_explicit_typing()
  354. {
  355.     register int i;
  356.     DCL_LOCK_STATE;
  357.  
  358.     
  359. #   ifdef PRINTSTATS
  360.          if (sizeof(struct LeafDescriptor) % sizeof(word) != 0)
  361.              ABORT("Bad leaf descriptor size");
  362. #   endif
  363.     DISABLE_SIGNALS();
  364.     LOCK();
  365.     if (GC_explicit_typing_initialized) {
  366.       UNLOCK();
  367.       ENABLE_SIGNALS();
  368.       return;
  369.     }
  370.     GC_explicit_typing_initialized = TRUE;
  371.     /* Set up object kind with simple indirect descriptor. */
  372.       GC_eobjfreelist = (ptr_t *)
  373.           GC_generic_malloc_inner((MAXOBJSZ+1)*sizeof(ptr_t), PTRFREE);
  374.       if (GC_eobjfreelist == 0) ABORT("Couldn't allocate GC_eobjfreelist");
  375.       BZERO(GC_eobjfreelist, (MAXOBJSZ+1)*sizeof(ptr_t));
  376.       GC_explicit_kind = GC_n_kinds++;
  377.       GC_obj_kinds[GC_explicit_kind].ok_freelist = GC_eobjfreelist;
  378.       GC_obj_kinds[GC_explicit_kind].ok_reclaim_list = 0;
  379.       GC_obj_kinds[GC_explicit_kind].ok_descriptor =
  380.             (((word)WORDS_TO_BYTES(-1)) | DS_PER_OBJECT);
  381.       GC_obj_kinds[GC_explicit_kind].ok_relocate_descr = TRUE;
  382.       GC_obj_kinds[GC_explicit_kind].ok_init = TRUE;
  383.             /* Descriptors are in the last word of the object. */
  384.       GC_typed_mark_proc_index = GC_n_mark_procs;
  385.       GC_mark_procs[GC_typed_mark_proc_index] = GC_typed_mark_proc;
  386.       GC_n_mark_procs++;
  387.         /* Moving this up breaks DEC AXP compiler.      */
  388.     /* Set up object kind with array descriptor. */
  389.       GC_arobjfreelist = (ptr_t *)
  390.           GC_generic_malloc_inner((MAXOBJSZ+1)*sizeof(ptr_t), PTRFREE);
  391.       if (GC_arobjfreelist == 0) ABORT("Couldn't allocate GC_arobjfreelist");
  392.       BZERO(GC_arobjfreelist, (MAXOBJSZ+1)*sizeof(ptr_t));
  393.       if (GC_n_mark_procs >= MAX_MARK_PROCS)
  394.               ABORT("No slot for array mark proc");
  395.       GC_array_mark_proc_index = GC_n_mark_procs++;
  396.       if (GC_n_kinds >= MAXOBJKINDS)
  397.               ABORT("No kind available for array objects");
  398.       GC_array_kind = GC_n_kinds++;
  399.       GC_obj_kinds[GC_array_kind].ok_freelist = GC_arobjfreelist;
  400.       GC_obj_kinds[GC_array_kind].ok_reclaim_list = 0;
  401.       GC_obj_kinds[GC_array_kind].ok_descriptor =
  402.             MAKE_PROC(GC_array_mark_proc_index, 0);;
  403.       GC_obj_kinds[GC_array_kind].ok_relocate_descr = FALSE;
  404.       GC_obj_kinds[GC_array_kind].ok_init = TRUE;
  405.             /* Descriptors are in the last word of the object. */
  406.             GC_mark_procs[GC_array_mark_proc_index] = GC_array_mark_proc;
  407.       for (i = 0; i < WORDSZ/2; i++) {
  408.           GC_descr d = (((word)(-1)) >> (WORDSZ - i)) << (WORDSZ - i);
  409.           d |= DS_BITMAP;
  410.           GC_bm_table[i] = d;
  411.       }
  412.       GC_generic_array_descr = MAKE_PROC(GC_array_mark_proc_index, 0); 
  413.     UNLOCK();
  414.     ENABLE_SIGNALS();
  415. }
  416.  
  417. mse * GC_typed_mark_proc(addr, mark_stack_ptr, mark_stack_limit, env)
  418. register word * addr;
  419. register mse * mark_stack_ptr;
  420. mse * mark_stack_limit;
  421. word env;
  422. {
  423.     register word bm = GC_ext_descriptors[env].ed_bitmap;
  424.     register word * current_p = addr;
  425.     register word current;
  426.     register ptr_t greatest_ha = GC_greatest_plausible_heap_addr;
  427.     register ptr_t least_ha = GC_least_plausible_heap_addr;
  428.     
  429.     for (; bm != 0; bm >>= 1, current_p++) {
  430.         if (bm & 1) {
  431.             current = *current_p;
  432.             if ((ptr_t)current >= least_ha && (ptr_t)current <= greatest_ha) {
  433.                 PUSH_CONTENTS(current, mark_stack_ptr, mark_stack_limit);
  434.             }
  435.         }
  436.     }
  437.     if (GC_ext_descriptors[env].ed_continued) {
  438.         /* Push an entry with the rest of the descriptor back onto the    */
  439.         /* stack.  Thus we never do too much work at once.  Note that    */
  440.         /* we also can't overflow the mark stack unless we actually     */
  441.         /* mark something.                        */
  442.         mark_stack_ptr++;
  443.         if (mark_stack_ptr >= mark_stack_limit) {
  444.             mark_stack_ptr = GC_signal_mark_stack_overflow(mark_stack_ptr);
  445.         }
  446.         mark_stack_ptr -> mse_start = addr + WORDSZ;
  447.         mark_stack_ptr -> mse_descr =
  448.             MAKE_PROC(GC_typed_mark_proc_index, env+1);
  449.     }
  450.     return(mark_stack_ptr);
  451. }
  452.  
  453. /* Return the size of the object described by d.  It would be faster to    */
  454. /* store this directly, or to compute it as part of            */
  455. /* GC_push_complex_descriptor, but hopefully it doesn't matter.        */
  456. word GC_descr_obj_size(d)
  457. register complex_descriptor *d;
  458. {
  459.     switch(d -> TAG) {
  460.       case LEAF_TAG:
  461.           return(d -> ld.ld_nelements * d -> ld.ld_size);
  462.       case ARRAY_TAG:
  463.         return(d -> ad.ad_nelements
  464.                * GC_descr_obj_size(d -> ad.ad_element_descr));
  465.       case SEQUENCE_TAG:
  466.         return(GC_descr_obj_size(d -> sd.sd_first)
  467.                + GC_descr_obj_size(d -> sd.sd_second));
  468.       default:
  469.         ABORT("Bad complex descriptor");
  470.         /*NOTREACHED*/
  471.     }
  472. }
  473.  
  474. /* Push descriptors for the object at addr with complex descriptor d    */
  475. /* onto the mark stack.  Return 0 if the mark stack overflowed.      */
  476. mse * GC_push_complex_descriptor(addr, d, msp, msl)
  477. word * addr;
  478. register complex_descriptor *d;
  479. register mse * msp;
  480. mse * msl;
  481. {
  482.     register ptr_t current = (ptr_t) addr;
  483.     register word nelements;
  484.     register word sz;
  485.     register word i;
  486.     
  487.     switch(d -> TAG) {
  488.       case LEAF_TAG:
  489.         {
  490.           register GC_descr descr = d -> ld.ld_descriptor;
  491.           
  492.           nelements = d -> ld.ld_nelements;
  493.           if (msl - msp <= (ptrdiff_t)nelements) return(0);
  494.           sz = d -> ld.ld_size;
  495.           for (i = 0; i < nelements; i++) {
  496.               msp++;
  497.               msp -> mse_start = (word *)current;
  498.               msp -> mse_descr = descr;
  499.               current += sz;
  500.           }
  501.           return(msp);
  502.         }
  503.       case ARRAY_TAG:
  504.         {
  505.           register complex_descriptor *descr = d -> ad.ad_element_descr;
  506.           
  507.           nelements = d -> ad.ad_nelements;
  508.           sz = GC_descr_obj_size(descr);
  509.           for (i = 0; i < nelements; i++) {
  510.               msp = GC_push_complex_descriptor((word *)current, descr,
  511.                                   msp, msl);
  512.               if (msp == 0) return(0);
  513.               current += sz;
  514.           }
  515.           return(msp);
  516.         }
  517.       case SEQUENCE_TAG:
  518.         {
  519.           sz = GC_descr_obj_size(d -> sd.sd_first);
  520.           msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_first,
  521.                              msp, msl);
  522.           if (msp == 0) return(0);
  523.           current += sz;
  524.           msp = GC_push_complex_descriptor((word *)current, d -> sd.sd_second,
  525.                              msp, msl);
  526.           return(msp);
  527.         }
  528.       default:
  529.         ABORT("Bad complex descriptor");
  530.         /*NOTREACHED*/
  531.     }
  532. }
  533.  
  534. /*ARGSUSED*/
  535. mse * GC_array_mark_proc(addr, mark_stack_ptr, mark_stack_limit, env)
  536. register word * addr;
  537. register mse * mark_stack_ptr;
  538. mse * mark_stack_limit;
  539. word env;
  540. {
  541.     register hdr * hhdr = HDR(addr);
  542.     register word sz = hhdr -> hb_sz;
  543.     register complex_descriptor * descr = (complex_descriptor *)(addr[sz-1]);
  544.     mse * orig_mark_stack_ptr = mark_stack_ptr;
  545.     mse * new_mark_stack_ptr;
  546.     
  547.     if (descr == 0) {
  548.         /* Found a reference to a free list entry.  Ignore it. */
  549.         return(orig_mark_stack_ptr);
  550.     }
  551.     /* In use counts were already updated when array descriptor was    */
  552.     /* pushed.  Here we only replace it by subobject descriptors, so     */
  553.     /* no update is necessary.                        */
  554.     new_mark_stack_ptr = GC_push_complex_descriptor(addr, descr,
  555.                                 mark_stack_ptr,
  556.                                 mark_stack_limit-1);
  557.     if (new_mark_stack_ptr == 0) {
  558.         /* Doesn't fit.  Conservatively push the whole array as a unit    */
  559.         /* and request a mark stack expansion.                */
  560.         /* This cannot cause a mark stack overflow, since it replaces    */
  561.         /* the original array entry.                    */
  562.         GC_mark_stack_too_small = TRUE;
  563.         new_mark_stack_ptr = orig_mark_stack_ptr + 1;
  564.         new_mark_stack_ptr -> mse_start = addr;
  565.         new_mark_stack_ptr -> mse_descr = WORDS_TO_BYTES(sz) | DS_LENGTH;
  566.     } else {
  567.         /* Push descriptor itself */
  568.         new_mark_stack_ptr++;
  569.         new_mark_stack_ptr -> mse_start = addr + sz - 1;
  570.         new_mark_stack_ptr -> mse_descr = sizeof(word) | DS_LENGTH;
  571.     }
  572.     return(new_mark_stack_ptr);
  573. }
  574.  
  575. #if defined(__STDC__) || defined(__cplusplus)
  576.   GC_descr GC_make_descriptor(GC_bitmap bm, size_t len)
  577. #else
  578.   GC_descr GC_make_descriptor(bm, len)
  579.   GC_bitmap bm;
  580.   size_t len;
  581. #endif
  582. {
  583.     register signed_word last_set_bit = len - 1;
  584.     register word result;
  585.     register int i;
  586. #   define HIGH_BIT (((word)1) << (WORDSZ - 1))
  587.     
  588.     if (!GC_explicit_typing_initialized) GC_init_explicit_typing();
  589.     while (last_set_bit >= 0 && !GC_get_bit(bm, last_set_bit)) last_set_bit --;
  590.     if (last_set_bit < 0) return(0 /* no pointers */);
  591. #   if ALIGNMENT == CPP_WORDSZ/8
  592.     {
  593.       register bool all_bits_set = TRUE;
  594.       for (i = 0; i < last_set_bit; i++) {
  595.         if (!GC_get_bit(bm, i)) {
  596.             all_bits_set = FALSE;
  597.             break;
  598.         }
  599.       }
  600.       if (all_bits_set) {
  601.         /* An initial section contains all pointers.  Use length descriptor. */
  602.         return(WORDS_TO_BYTES(last_set_bit+1) | DS_LENGTH);
  603.       }
  604.     }
  605. #   endif
  606.     if (last_set_bit < BITMAP_BITS) {
  607.         /* Hopefully the common case.            */
  608.         /* Build bitmap descriptor (with bits reversed)    */
  609.         result = HIGH_BIT;
  610.         for (i = last_set_bit - 1; i >= 0; i--) {
  611.             result >>= 1;
  612.             if (GC_get_bit(bm, i)) result |= HIGH_BIT;
  613.         }
  614.         result |= DS_BITMAP;
  615.         return(result);
  616.     } else {
  617.         signed_word index;
  618.         
  619.         index = GC_add_ext_descriptor(bm, (word)last_set_bit+1);
  620.         if (index == -1) return(WORDS_TO_BYTES(last_set_bit+1) | DS_LENGTH);
  621.                     /* Out of memory: use conservative    */
  622.                     /* approximation.            */
  623.         result = MAKE_PROC(GC_typed_mark_proc_index, (word)index);
  624.         return(result);
  625.     }
  626. }
  627.  
  628. ptr_t GC_clear_stack();
  629.  
  630. #define GENERAL_MALLOC(lb,k) \
  631.     (extern_ptr_t)GC_clear_stack(GC_generic_malloc((word)lb, k))
  632.     
  633. #if defined(__STDC__) || defined(__cplusplus)
  634.   extern void * GC_malloc_explicitly_typed(size_t lb, GC_descr d)
  635. #else
  636.   extern char * GC_malloc_explicitly_typed(lb, d)
  637.   size_t lb;
  638.   GC_descr d;
  639. #endif
  640. {
  641. register ptr_t op;
  642. register ptr_t * opp;
  643. register word lw;
  644. DCL_LOCK_STATE;
  645.  
  646.     lb += EXTRA_BYTES;
  647.     if( SMALL_OBJ(lb) ) {
  648. #       ifdef MERGE_SIZES
  649.       lw = GC_size_map[lb];
  650. #    else
  651.       lw = ALIGNED_WORDS(lb);
  652. #       endif
  653.     opp = &(GC_eobjfreelist[lw]);
  654.     FASTLOCK();
  655.         if( !FASTLOCK_SUCCEEDED() || (op = *opp) == 0 ) {
  656.             FASTUNLOCK();
  657.             op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind);
  658. #        ifdef MERGE_SIZES
  659.         lw = GC_size_map[lb];    /* May have been uninitialized.    */            
  660. #        endif
  661.         } else {
  662.             *opp = obj_link(op);
  663.             GC_words_allocd += lw;
  664.             FASTUNLOCK();
  665.         }
  666.    } else {
  667.        op = (ptr_t)GENERAL_MALLOC((word)lb, GC_explicit_kind);
  668.        lw = BYTES_TO_WORDS(GC_size(op));
  669.    }
  670.    ((word *)op)[lw - 1] = d;
  671.    return((extern_ptr_t) op);
  672. }
  673.  
  674. #if defined(__STDC__) || defined(__cplusplus)
  675.   void * GC_calloc_explicitly_typed(size_t n,
  676.                       size_t lb,
  677.                       GC_descr d)
  678. #else
  679.   char * GC_calloc_explicitly_typed(n, lb, d)
  680.   size_t n;
  681.   size_t lb;
  682.   GC_descr d;
  683. #endif
  684. {
  685. register ptr_t op;
  686. register ptr_t * opp;
  687. register word lw;
  688. GC_descr simple_descr;
  689. complex_descriptor *complex_descr;
  690. register int descr_type;
  691. struct LeafDescriptor leaf;
  692. DCL_LOCK_STATE;
  693.  
  694.     descr_type = GC_make_array_descriptor((word)n, (word)lb, d,
  695.                           &simple_descr, &complex_descr, &leaf);
  696.     switch(descr_type) {
  697.         case NO_MEM: return(0);
  698.         case SIMPLE: return(GC_malloc_explicitly_typed(n*lb, simple_descr));
  699.         case LEAF:
  700.             lb *= n;
  701.             lb += sizeof(struct LeafDescriptor) + EXTRA_BYTES;
  702.             break;
  703.         case COMPLEX:
  704.             lb *= n;
  705.             lb += EXTRA_BYTES;
  706.             break;
  707.     }
  708.     if( SMALL_OBJ(lb) ) {
  709. #       ifdef MERGE_SIZES
  710.       lw = GC_size_map[lb];
  711. #    else
  712.       lw = ALIGNED_WORDS(lb);
  713. #       endif
  714.     opp = &(GC_arobjfreelist[lw]);
  715.     FASTLOCK();
  716.         if( !FASTLOCK_SUCCEEDED() || (op = *opp) == 0 ) {
  717.             FASTUNLOCK();
  718.             op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind);
  719. #        ifdef MERGE_SIZES
  720.         lw = GC_size_map[lb];    /* May have been uninitialized.    */            
  721. #        endif
  722.         } else {
  723.             *opp = obj_link(op);
  724.             GC_words_allocd += lw;
  725.             FASTUNLOCK();
  726.         }
  727.    } else {
  728.        op = (ptr_t)GENERAL_MALLOC((word)lb, GC_array_kind);
  729.        lw = BYTES_TO_WORDS(GC_size(op));
  730.    }
  731.    if (descr_type == LEAF) {
  732.        /* Set up the descriptor inside the object itself. */
  733.        VOLATILE struct LeafDescriptor * lp =
  734.            (struct LeafDescriptor *)
  735.                ((word *)op
  736.                 + lw - (BYTES_TO_WORDS(sizeof(struct LeafDescriptor)) + 1));
  737.                 
  738.        lp -> ld_tag = LEAF_TAG;
  739.        lp -> ld_size = leaf.ld_size;
  740.        lp -> ld_nelements = leaf.ld_nelements;
  741.        lp -> ld_descriptor = leaf.ld_descriptor;
  742.        ((VOLATILE word *)op)[lw - 1] = (word)lp;
  743.    } else {
  744.        extern unsigned GC_finalization_failures;
  745.        unsigned ff = GC_finalization_failures;
  746.        
  747.        ((word *)op)[lw - 1] = (word)complex_descr;
  748.        /* Make sure the descriptor is cleared once there is any danger    */
  749.        /* it may have been collected.                    */
  750.        (void)
  751.          GC_general_register_disappearing_link((extern_ptr_t *)
  752.                                ((word *)op+lw-1),
  753.                                      (extern_ptr_t) op);
  754.        if (ff != GC_finalization_failures) {
  755.            /* We may have failed to register op due to lack of memory.    */
  756.            /* We were out of memory very recently, so we can safely     */
  757.            /* punt.                            */
  758.            ((word *)op)[lw - 1] = 0;
  759.            return(0);
  760.        }                      
  761.    }
  762.    return((extern_ptr_t) op);
  763. }
  764.