home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / bchgcl.c < prev    next >
C/C++ Source or Header  |  2001-02-12  |  20KB  |  738 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bchgcl.c,v 9.52 2001/02/12 22:32:20 cph Exp $
  4.  
  5. Copyright (c) 1987-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* This is the main GC loop for bchscheme.  */
  23.  
  24. #include "scheme.h"
  25. #include "bchgcc.h"
  26.  
  27. #define MAYBE_DUMP_FREE(free)                        \
  28. {                                    \
  29.   if (free >= free_buffer_top)                        \
  30.     DUMP_FREE (free);                            \
  31. }
  32.  
  33. #define DUMP_FREE(free)                            \
  34.   free = (dump_and_reset_free_buffer (free, 0))
  35.  
  36. #define MAYBE_DUMP_SCAN(scan)                        \
  37. {                                    \
  38.   if (scan >= scan_buffer_top)                        \
  39.     DUMP_SCAN (scan);                            \
  40. }
  41.  
  42. #define DUMP_SCAN(scan)                            \
  43.   scan = (dump_and_reload_scan_buffer (scan, 0))
  44.  
  45. #define TRANSPORT_VECTOR(new_address, free, old_start, n_words)        \
  46. {                                    \
  47.   SCHEME_OBJECT * old_ptr = old_start;                    \
  48.   SCHEME_OBJECT * free_end = (free + n_words);                \
  49.   if (free_end < free_buffer_top)                    \
  50.     while (free < free_end)                        \
  51.       (*free++) = (*old_ptr++);                        \
  52.   else                                    \
  53.     {                                    \
  54.       while (free < free_buffer_top)                    \
  55.     (*free++) = (*old_ptr++);                    \
  56.       free = (transport_vector_tail (free, free_end, old_ptr));        \
  57.     }                                    \
  58. }
  59.  
  60. static SCHEME_OBJECT *
  61. DEFUN (transport_vector_tail, (free, free_end, tail),
  62.        SCHEME_OBJECT * free AND
  63.        SCHEME_OBJECT * free_end AND
  64.        SCHEME_OBJECT * tail)
  65. {
  66.   unsigned long n_words = (free_end - free);
  67.   DUMP_FREE (free);
  68.   {
  69.     unsigned long n_blocks = (n_words >> gc_buffer_shift);
  70.     if (n_blocks > 0)
  71.       {
  72.     free = (dump_free_directly (tail, n_blocks, 0));
  73.     tail += (n_blocks << gc_buffer_shift);
  74.       }
  75.   }
  76.   {
  77.     SCHEME_OBJECT * free_end = (free + (n_words & gc_buffer_mask));
  78.     while (free < free_end)
  79.       (*free++) = (*tail++);
  80.   }
  81.   return (free);
  82. }
  83.  
  84. SCHEME_OBJECT *
  85. DEFUN (gc_loop,
  86.        (scan, free_ptr, new_address_ptr, low_heap, gc_mode,
  87.     require_normal_end),
  88.        SCHEME_OBJECT * scan AND
  89.        SCHEME_OBJECT ** free_ptr AND
  90.        SCHEME_OBJECT ** new_address_ptr AND
  91.        SCHEME_OBJECT * low_heap AND
  92.        gc_mode_t gc_mode AND
  93.        int require_normal_end)
  94. {
  95.   SCHEME_OBJECT * free = (*free_ptr);
  96.   SCHEME_OBJECT * new_address = (*new_address_ptr);
  97.   while (scan != free)
  98.     {
  99.       SCHEME_OBJECT object;
  100.       if (scan >= scan_buffer_top)
  101.     {
  102.       if (scan == scan_buffer_top)
  103.         DUMP_SCAN (scan);
  104.       else
  105.         {
  106.           sprintf
  107.         (gc_death_message_buffer,
  108.          "gc_loop: scan (0x%lx) > scan_buffer_top (0x%lx)",
  109.          ((unsigned long) scan),
  110.          ((unsigned long) scan_buffer_top));
  111.           gc_death (TERM_EXIT, gc_death_message_buffer, scan, free);
  112.           /*NOTREACHED*/
  113.         }
  114.     }
  115.       object = (*scan);
  116.       switch (OBJECT_TYPE (object))
  117.     {
  118.     case TC_BROKEN_HEART:
  119.       if (gc_mode != NORMAL_GC)
  120.         goto end_gc_loop;
  121.       if (object == (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, scan)))
  122.         /* Does this ever happen?  */
  123.         goto end_gc_loop;
  124.       sprintf (gc_death_message_buffer,
  125.            "gc_loop: broken heart (0x%lx) in scan",
  126.            object);
  127.       gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, scan, free);
  128.       /*NOTREACHED*/
  129.       break;
  130.  
  131.     case TC_CHARACTER:
  132.     case TC_CONSTANT:
  133.     case TC_FIXNUM:
  134.     case TC_NULL:
  135.     case TC_PCOMB0:
  136.     case TC_PRIMITIVE:
  137.     case TC_RETURN_CODE:
  138.     case TC_STACK_ENVIRONMENT:
  139.     case TC_THE_ENVIRONMENT:
  140.       scan += 1;
  141.       break;
  142.  
  143.     case TC_CELL:
  144.       if (gc_mode == CONSTANT_COPY)
  145.         {
  146.           scan += 1;
  147.           break;
  148.         }
  149.       {
  150.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  151.         if (old_start < low_heap)
  152.           scan += 1;
  153.         else if (BROKEN_HEART_P (*old_start))
  154.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  155.         else
  156.           {
  157.         (*free++) = (old_start[0]);
  158.         MAYBE_DUMP_FREE (free);
  159.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  160.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  161.         new_address += 1;
  162.           }
  163.       }
  164.       break;
  165.  
  166.     case TC_ACCESS:
  167.     case TC_ASSIGNMENT:
  168.     case TC_COMBINATION_1:
  169.     case TC_COMMENT:
  170.     case TC_COMPLEX:
  171.     case TC_DEFINITION:
  172.     case TC_DELAY:
  173.     case TC_DELAYED:
  174.     case TC_DISJUNCTION:
  175.     case TC_ENTITY:
  176.     case TC_EXTENDED_PROCEDURE:
  177.     case TC_IN_PACKAGE:
  178.     case TC_LAMBDA:
  179.     case TC_LEXPR:
  180.     case TC_LIST:
  181.     case TC_PCOMB1:
  182.     case TC_PROCEDURE:
  183.     case TC_RATNUM:
  184.     case TC_SCODE_QUOTE:
  185.     case TC_SEQUENCE_2:
  186.     transport_pair:
  187.       if (gc_mode == CONSTANT_COPY)
  188.         {
  189.           scan += 1;
  190.           break;
  191.         }
  192.       goto really_transport_pair;
  193.  
  194.     case TC_INTERNED_SYMBOL:
  195.     case TC_UNINTERNED_SYMBOL:
  196.       if (gc_mode == PURE_COPY)
  197.         {
  198.           SCHEME_OBJECT name = (MEMORY_REF (object, SYMBOL_NAME));
  199.           SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (name));
  200.           if ((old_start < low_heap)
  201.           || (BROKEN_HEART_P (*old_start)))
  202.         scan += 1;
  203.           else
  204.         {
  205.           unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  206.           TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  207.           (*scan++) = (OBJECT_NEW_ADDRESS (name, new_address));
  208.           (*old_start) = (MAKE_BROKEN_HEART (new_address));
  209.           new_address += n_words;
  210.         }
  211.           break;
  212.         }
  213.     really_transport_pair:
  214.       {
  215.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  216.         if (old_start < low_heap)
  217.           scan += 1;
  218.         else if (BROKEN_HEART_P (*old_start))
  219.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  220.         else
  221.           {
  222.         (*free++) = (old_start[0]);
  223.         (*free++) = (old_start[1]);
  224.         MAYBE_DUMP_FREE (free);
  225.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  226.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  227.         new_address += 2;
  228.           }
  229.       }
  230.       break;
  231.  
  232.     case TC_COMBINATION_2:
  233.     case TC_CONDITIONAL:
  234.     case TC_EXTENDED_LAMBDA:
  235.     case TC_HUNK3_A:
  236.     case TC_HUNK3_B:
  237.     case TC_PCOMB2:
  238.     case TC_SEQUENCE_3:
  239.     case TC_VARIABLE:
  240.       if (gc_mode == CONSTANT_COPY)
  241.         {
  242.           scan += 1;
  243.           break;
  244.         }
  245.       {
  246.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  247.         if (old_start < low_heap)
  248.           scan += 1;
  249.         else if (BROKEN_HEART_P (*old_start))
  250.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  251.         else
  252.           {
  253.         (*free++) = (old_start[0]);
  254.         (*free++) = (old_start[1]);
  255.         (*free++) = (old_start[2]);
  256.         MAYBE_DUMP_FREE (free);
  257.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  258.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  259.         new_address += 3;
  260.           }
  261.       }
  262.       break;
  263.  
  264.     case TC_QUAD:
  265.       if (gc_mode == CONSTANT_COPY)
  266.         {
  267.           scan += 1;
  268.           break;
  269.         }
  270.       {
  271.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  272.         if (old_start < low_heap)
  273.           scan += 1;
  274.         else if (BROKEN_HEART_P (*old_start))
  275.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  276.         else
  277.           {
  278.         (*free++) = (old_start[0]);
  279.         (*free++) = (old_start[1]);
  280.         (*free++) = (old_start[2]);
  281.         (*free++) = (old_start[3]);
  282.         MAYBE_DUMP_FREE (free);
  283.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  284.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  285.         new_address += 4;
  286.           }
  287.       }
  288.       break;
  289.  
  290.     case TC_BIG_FIXNUM:
  291.     case TC_CHARACTER_STRING:
  292.     case TC_COMBINATION:
  293.     case TC_CONTROL_POINT:
  294.     case TC_NON_MARKED_VECTOR:
  295.     case TC_PCOMB3:
  296.     case TC_RECORD:
  297.     case TC_VECTOR:
  298.     case TC_VECTOR_16B:
  299.     case TC_VECTOR_1B:
  300.       if (gc_mode == CONSTANT_COPY)
  301.         {
  302.           scan += 1;
  303.           break;
  304.         }
  305.       goto transport_vector;
  306.  
  307.     case TC_ENVIRONMENT:
  308.       if (gc_mode == PURE_COPY)
  309.         {
  310.           scan += 1;
  311.           break;
  312.         }
  313.     transport_vector:
  314.       {
  315.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  316.         if (old_start < low_heap)
  317.           scan += 1;
  318.         else if (BROKEN_HEART_P (*old_start))
  319.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  320.         else
  321.           {
  322.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  323.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  324.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  325.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  326.         new_address += n_words;
  327.           }
  328.       }
  329.       break;
  330.  
  331.     case TC_BIG_FLONUM:
  332.       if (gc_mode == CONSTANT_COPY)
  333.         {
  334.           scan += 1;
  335.           break;
  336.         }
  337.       goto transport_aligned_vector;
  338.  
  339.     case TC_COMPILED_CODE_BLOCK:
  340.       if (gc_mode == PURE_COPY)
  341.         {
  342.           scan += 1;
  343.           break;
  344.         }
  345.     transport_aligned_vector:
  346.       {
  347.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  348.         if (old_start < low_heap)
  349.           scan += 1;
  350.         else if (BROKEN_HEART_P (*old_start))
  351.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  352.         else
  353.           {
  354.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  355.         BCH_ALIGN_FLOAT (new_address, free);
  356.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  357.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  358.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  359.         new_address += n_words;
  360.           }
  361.       }
  362.       break;
  363.  
  364.     case TC_WEAK_CONS:
  365.       if (gc_mode == PURE_COPY)
  366.         {
  367.           scan += 1;
  368.           break;
  369.         }
  370.       {
  371.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  372.         if (old_start < low_heap)
  373.           scan += 1;
  374.         else if (BROKEN_HEART_P (*old_start))
  375.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  376.         else
  377.           {
  378.         SCHEME_OBJECT weak_car = (old_start[0]);
  379.         if (((OBJECT_TYPE (weak_car)) == TC_NULL)
  380.             || ((OBJECT_ADDRESS (weak_car)) < low_heap))
  381.           {
  382.             (*free++) = weak_car;
  383.             (*free++) = (old_start[1]);
  384.           }
  385.         else if (weak_pair_stack_ptr > weak_pair_stack_limit)
  386.           {
  387.             (*--weak_pair_stack_ptr) = ((SCHEME_OBJECT) new_address);
  388.             (*--weak_pair_stack_ptr) = weak_car;
  389.             (*free++) = SHARP_F;
  390.             (*free++) = (old_start[1]);
  391.           }
  392.         else
  393.           {
  394.             (*free++) = (OBJECT_NEW_TYPE (TC_NULL, weak_car));
  395.             (*free++) = (old_start[1]);
  396.             (old_start[1])
  397.               = (MAKE_OBJECT_FROM_OBJECTS (weak_car, Weak_Chain));
  398.             Weak_Chain = object;
  399.           }
  400.         MAYBE_DUMP_FREE (free);
  401.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  402.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  403.         new_address += 2;
  404.           }
  405.       }
  406.       break;
  407.  
  408.     case TC_MANIFEST_NM_VECTOR:
  409.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  410.       scan += (1 + (OBJECT_DATUM (object)));
  411.       MAYBE_DUMP_SCAN (scan);
  412.       break;
  413.  
  414.     case TC_REFERENCE_TRAP:
  415.       if ((OBJECT_DATUM (object)) > TRAP_MAX_IMMEDIATE)
  416.         goto transport_pair;
  417.       /* Otherwise it's a non-pointer.  */
  418.       scan += 1;
  419.       break;
  420.  
  421.     case TC_COMPILED_ENTRY:
  422.       if (gc_mode == PURE_COPY)
  423.         {
  424.           scan += 1;
  425.           break;
  426.         }
  427.       {
  428.         SCHEME_OBJECT * old_start;
  429.         Get_Compiled_Block (old_start, (OBJECT_ADDRESS (object)));
  430.         if (old_start < low_heap)
  431.           scan += 1;
  432.         else if (BROKEN_HEART_P (*old_start))
  433.           (*scan++)
  434.         = (RELOCATE_COMPILED (object,
  435.                       (OBJECT_ADDRESS (*old_start)),
  436.                       old_start));
  437.         else
  438.           {
  439.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  440.         BCH_ALIGN_FLOAT (new_address, free);
  441.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  442.         (*scan++)
  443.           = (RELOCATE_COMPILED (object, new_address, old_start));
  444.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  445.         new_address += n_words;
  446.           }
  447.       }
  448.       break;
  449.  
  450.     case TC_LINKAGE_SECTION:
  451.       if (gc_mode == PURE_COPY)
  452.         {
  453.           gc_death (TERM_COMPILER_DEATH,
  454.             "gc_loop: linkage section in pure area",
  455.             scan, free);
  456.           /*NOTREACHED*/
  457.         }
  458.       switch (READ_LINKAGE_KIND (object))
  459.         {
  460.         case REFERENCE_LINKAGE_KIND:
  461.         case ASSIGNMENT_LINKAGE_KIND:
  462.           {
  463.         /* `count' typeless pointers to quads follow. */
  464.         unsigned long count = (READ_CACHE_LINKAGE_COUNT (object));
  465.         scan += 1;
  466.         while (count > 0)
  467.           {
  468.             SCHEME_OBJECT * old_start;
  469.             MAYBE_DUMP_SCAN (scan);
  470.             old_start = (SCHEME_ADDR_TO_ADDR (*scan));
  471.             if (old_start < low_heap)
  472.               scan += 1;
  473.             else if (BROKEN_HEART_P (*old_start))
  474.               (*scan++)
  475.             = (ADDR_TO_SCHEME_ADDR (OBJECT_ADDRESS (*old_start)));
  476.             else
  477.               {
  478.             (*free++) = (old_start[0]);
  479.             (*free++) = (old_start[1]);
  480.             (*free++) = (old_start[2]);
  481.             (*free++) = (old_start[3]);
  482.             MAYBE_DUMP_FREE (free);
  483.             (*scan++) = (ADDR_TO_SCHEME_ADDR (new_address));
  484.             (*old_start) = (MAKE_BROKEN_HEART (new_address));
  485.             new_address += 4;
  486.               }
  487.             count -= 1;
  488.           }
  489.           }
  490.           break;
  491.  
  492.         case OPERATOR_LINKAGE_KIND:
  493.         case GLOBAL_OPERATOR_LINKAGE_KIND:
  494.           {
  495.         unsigned long count = (READ_OPERATOR_LINKAGE_COUNT (object));
  496.         char * entry = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
  497.         long delta;
  498.  
  499.         {
  500.           int extend_p = (entry >= ((char *) scan_buffer_top));
  501.           long delta1 = (((char *) scan) - entry);
  502.           if (extend_p)
  503.             extend_scan_buffer (entry, free);
  504.           BCH_START_OPERATOR_RELOCATION (scan);
  505.           if (extend_p)
  506.             {
  507.               entry = (end_scan_buffer_extension (entry));
  508.               scan = ((SCHEME_OBJECT *) (entry + delta1));
  509.             }
  510.         }
  511.  
  512.         /* END_OPERATOR_LINKAGE_AREA assumes that we will add
  513.            one to the result, so do that now.  */
  514.         delta
  515.           = (((END_OPERATOR_LINKAGE_AREA (scan, count)) + 1)
  516.              - scan_buffer_top);
  517.  
  518.         /* The operator entries are copied sequentially, but
  519.            extra hair is required because the entry addresses
  520.            are encoded.  */
  521.         while (count > 0)
  522.           {
  523.             char * next_entry = (NEXT_LINKAGE_OPERATOR_ENTRY (entry));
  524.             int extend_p = (next_entry >= ((char *) scan_buffer_top));
  525.             SCHEME_OBJECT esaddr;
  526.             SCHEME_OBJECT * old_start;
  527.  
  528.             /* Guarantee that the scan buffer is large enough
  529.                to hold the entry.  */
  530.             if (extend_p)
  531.               extend_scan_buffer (next_entry, free);
  532.  
  533.             /* Get the entry address.  */
  534.             BCH_EXTRACT_OPERATOR_LINKAGE_ADDRESS (esaddr, entry);
  535.  
  536.             /* Get the code-block pointer for this entry.  */
  537.             Get_Compiled_Block
  538.               (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
  539.  
  540.             /* Copy the block.  */
  541.             if (old_start < low_heap)
  542.               ;
  543.             else if (BROKEN_HEART_P (*old_start))
  544.               {
  545.             BCH_STORE_OPERATOR_LINKAGE_ADDRESS
  546.               ((RELOCATE_COMPILED_RAW_ADDRESS
  547.                 (esaddr,
  548.                  (OBJECT_ADDRESS (*old_start)),
  549.                  old_start)),
  550.                entry);
  551.               }
  552.             else
  553.               {
  554.             unsigned long n_words
  555.               = (1 + (OBJECT_DATUM (*old_start)));
  556.             BCH_ALIGN_FLOAT (new_address, free);
  557.             TRANSPORT_VECTOR
  558.               (new_address, free, old_start, n_words);
  559.             BCH_STORE_OPERATOR_LINKAGE_ADDRESS
  560.               ((RELOCATE_COMPILED_RAW_ADDRESS
  561.                 (esaddr, new_address, old_start)),
  562.                entry);
  563.             (*old_start) = (MAKE_BROKEN_HEART (new_address));
  564.             new_address += n_words;
  565.               }
  566.  
  567.             if (extend_p)
  568.               {
  569.             entry = (end_scan_buffer_extension (next_entry));
  570.             delta -= gc_buffer_size;
  571.               }
  572.             else
  573.               entry = next_entry;
  574.  
  575.             count -= 1;
  576.           }
  577.         scan = (scan_buffer_top + delta);
  578.         MAYBE_DUMP_SCAN (scan);
  579.         BCH_END_OPERATOR_RELOCATION (scan);
  580.           }
  581.           break;
  582.  
  583.         case CLOSURE_PATTERN_LINKAGE_KIND:
  584.           scan += (1 + (READ_CACHE_LINKAGE_COUNT (object)));
  585.           MAYBE_DUMP_SCAN (scan);
  586.           break;
  587.  
  588.         default:
  589.           gc_death (TERM_EXIT, "gc_loop: Unknown compiler linkage kind.",
  590.             scan, free);
  591.           /*NOTREACHED*/
  592.           break;
  593.         }
  594.       break;
  595.  
  596.     case TC_MANIFEST_CLOSURE:
  597.       if (gc_mode == PURE_COPY)
  598.         {
  599.           gc_death (TERM_COMPILER_DEATH,
  600.             "gc_loop: manifest closure in pure area",
  601.             scan, free);
  602.           /*NOTREACHED*/
  603.         }
  604.       {
  605.         unsigned long count;
  606.         char * entry;
  607.         char * closure_end;
  608.  
  609.         {
  610.           unsigned long delta = (2 * (sizeof (format_word)));
  611.           char * count_end = (((char *) (scan + 1)) + delta);
  612.           int extend_p = (count_end >= ((char *) scan_buffer_top));
  613.  
  614.           /* Guarantee that the scan buffer is large enough to
  615.          hold the count field.  */
  616.           if (extend_p)
  617.         extend_scan_buffer (count_end, free);
  618.  
  619.           BCH_START_CLOSURE_RELOCATION (scan);
  620.           count = (MANIFEST_CLOSURE_COUNT (scan + 1));
  621.           entry = (FIRST_MANIFEST_CLOSURE_ENTRY (scan + 1));
  622.  
  623.           if (extend_p)
  624.         {
  625.           long dw = (entry - count_end);
  626.           count_end = (end_scan_buffer_extension (count_end));
  627.           entry = (count_end + dw);
  628.         }
  629.           scan = ((SCHEME_OBJECT *) (count_end - delta));
  630.         }
  631.  
  632.         /* MANIFEST_CLOSURE_END assumes that one will be added to
  633.            result, so do that now.  */
  634.         closure_end
  635.           = ((char *) ((MANIFEST_CLOSURE_END (scan, count)) + 1));
  636.  
  637.         /* The closures are copied sequentially, but extra hair is
  638.            required because the code-entry pointers are encoded as
  639.            machine instructions.  */
  640.         while (count > 0)
  641.           {
  642.         char * entry_end = (CLOSURE_ENTRY_END (entry));
  643.         int extend_p = (entry_end >= ((char *) scan_buffer_top));
  644.         SCHEME_OBJECT esaddr;
  645.         SCHEME_OBJECT * old_start;
  646.         long delta1 = (entry - entry_end);
  647.         long delta2 = (closure_end - entry_end);
  648.  
  649.         /* If the closure overflows the scan buffer, extend
  650.            the buffer to the end of the closure.  */
  651.         if (extend_p)
  652.           extend_scan_buffer (entry_end, free);
  653.  
  654.         /* Extract the code-entry pointer and convert it to a
  655.            C pointer.  */
  656.         BCH_EXTRACT_CLOSURE_ENTRY_ADDRESS (esaddr, entry);
  657.         Get_Compiled_Block (old_start, (SCHEME_ADDR_TO_ADDR (esaddr)));
  658.  
  659.         /* Copy the code entry.  Use machine-specific macro to
  660.            update the pointer. */
  661.         if (old_start < low_heap)
  662.           ;
  663.         else if (BROKEN_HEART_P (*old_start))
  664.           BCH_STORE_CLOSURE_ENTRY_ADDRESS
  665.             ((RELOCATE_COMPILED_RAW_ADDRESS
  666.               (esaddr, (OBJECT_ADDRESS (*old_start)), old_start)),
  667.              entry);
  668.         else
  669.           {
  670.             unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  671.             BCH_ALIGN_FLOAT (new_address, free);
  672.             TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  673.             BCH_STORE_CLOSURE_ENTRY_ADDRESS
  674.               ((RELOCATE_COMPILED_RAW_ADDRESS
  675.             (esaddr, new_address, old_start)),
  676.                entry);
  677.             (*old_start) = (MAKE_BROKEN_HEART (new_address));
  678.             new_address += n_words;
  679.           }
  680.  
  681.         if (extend_p)
  682.           {
  683.             entry_end = (end_scan_buffer_extension (entry_end));
  684.             entry = (entry_end + delta1);
  685.             closure_end = (entry_end + delta2);
  686.           }
  687.  
  688.         entry = (NEXT_MANIFEST_CLOSURE_ENTRY (entry));
  689.         count -= 1;
  690.           }
  691.         scan = ((SCHEME_OBJECT *) closure_end);
  692.         MAYBE_DUMP_SCAN (scan);
  693.         BCH_END_CLOSURE_RELOCATION (scan);
  694.       }
  695.       break;
  696.  
  697.     case TC_FUTURE:
  698.       if (gc_mode == CONSTANT_COPY)
  699.         {
  700.           scan += 1;
  701.           break;
  702.         }
  703.       {
  704.         SCHEME_OBJECT * old_start = (OBJECT_ADDRESS (object));
  705.         if (old_start < low_heap)
  706.           scan += 1;
  707.         else if (BROKEN_HEART_P (*old_start))
  708.           (*scan++) = (MAKE_OBJECT_FROM_OBJECTS (object, (*old_start)));
  709.         else if (Future_Spliceable (object))
  710.           (*scan) = (Future_Value (object));
  711.         else
  712.           {
  713.         unsigned long n_words = (1 + (OBJECT_DATUM (*old_start)));
  714.         TRANSPORT_VECTOR (new_address, free, old_start, n_words);
  715.         (*scan++) = (OBJECT_NEW_ADDRESS (object, new_address));
  716.         (*old_start) = (MAKE_BROKEN_HEART (new_address));
  717.         new_address += n_words;
  718.           }
  719.       }
  720.       break;
  721.  
  722.     default:
  723.       GC_BAD_TYPE ("gc_loop", object);
  724.       scan += 1;
  725.       break;
  726.     }
  727.     }
  728.  end_gc_loop:
  729.   (*free_ptr) = free;
  730.   (*new_address_ptr) = new_address;
  731.   if (require_normal_end && (scan != free))
  732.     {
  733.       gc_death (TERM_BROKEN_HEART, "gc_loop ended too early", scan, free);
  734.       /*NOTREACHED*/
  735.     }
  736.   return (scan);
  737. }
  738.