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 / wabbit.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  28KB  |  1,019 lines
  1. /* -*-C-*-
  2.  
  3. $Id: wabbit.c,v 1.8 2000/12/05 21:23:49 cph Exp $
  4.  
  5. Copyright (c) 1994-2000 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. /* 
  23.  *
  24.  * What's opera, doc?!
  25.  * This file contains the wabbit-hunting garbage collector,
  26.  * by Ziggy and GJR.
  27.  *
  28.  */
  29.  
  30. #include "scheme.h"
  31. #include "gccode.h"
  32.  
  33. extern SCHEME_OBJECT Weak_Chain;
  34.  
  35. extern SCHEME_OBJECT *
  36.   EXFUN (wabbit_hunting_gcloop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
  37.  
  38. extern void
  39.   EXFUN (wabbit_season, (SCHEME_OBJECT));
  40.  
  41. extern void
  42.   EXFUN (duck_season, (SCHEME_OBJECT));
  43.  
  44. extern void
  45.   EXFUN (fix_weak_chain_and_hunt_wabbits, (void));
  46.  
  47. /* Wabbit hunting code */
  48. /* Be wary, wary, quiet... */
  49.  
  50. #define TC_HEADLESS_REFERENCE        TC_NULL
  51. #define TC_REFERENCE_TO_STACK        TC_STACK_ENVIRONMENT
  52. #define TC_REFERENCE_TO_CONSTANT_SPACE    TC_CHARACTER
  53.  
  54. Boolean
  55.   wabbit_holes_discarded_p,
  56.   wabbit_holes_overwritten_p,
  57.   wabbit_all_dead_p;  
  58.  
  59. SCHEME_OBJECT
  60.   * wabbit_holes,
  61.   * wabbit_holes_hi,
  62.   * wabbit_lo_address,
  63.   * wabbit_hi_address,
  64.   * wabbit_of_Seville,
  65.   * wabbit_buffer_lo,
  66.   * wabbit_buffer_ptr,
  67.   * wabbit_buffer_hi,
  68.   * old_wabbit_buffer,
  69.   * old_wabbit_buffer_end,
  70.   * hares_lo,
  71.   * hares_hi;
  72.  
  73. #define ELMER_FUDGE_FACTOR     4    /* Size of QUAD */
  74. #define ELMER_HUNG_FACTOR    20    /* 1 / (Sales tax in MA in 1994) */
  75. #define RAJIV_SURATI_FACTOR     -20     /* -1 * ELMER_HUNG_FACTOR */
  76.  
  77. void EXFUN (kill_da_wabbit, (SCHEME_OBJECT *, SCHEME_OBJECT));
  78. Boolean EXFUN (discard_wabbit_holes_p, (SCHEME_OBJECT *, SCHEME_OBJECT *));
  79.  
  80. /* We need not check wabbit_lo_address by construction:
  81.    wabbit_lo_address is Free at the beginning of the GC, and
  82.    all forwarded objects will point above that, except for
  83.    the wabbit of Seville, a.k.a. the wabbit vector.
  84.  */
  85.  
  86. #define WABBIT_P(addr)                            \
  87.   (((addr) < wabbit_hi_address)                        \
  88.    && ((addr) != wabbit_of_Seville))
  89.  
  90. #define HARE_P(addr)                            \
  91.   (((OBJECT_TYPE (* addr)) == TC_BROKEN_HEART)                \
  92.    && ((OBJECT_ADDRESS (* addr)) >= old_wabbit_buffer)            \
  93.    && ((OBJECT_ADDRESS (* addr)) < old_wabbit_buffer_end))
  94.  
  95. #define RECORD_WABBIT_HOLE(tag, address) do                \
  96. {                                    \
  97.   if ((wabbit_holes > (new_space_free + ELMER_FUDGE_FACTOR))        \
  98.       || (discard_wabbit_holes_p (scan, new_space_free)))        \
  99.     *--wabbit_holes = (MAKE_POINTER_OBJECT (tag, address));        \
  100. } while (0)
  101.  
  102. #define KILL_DA_WABBIT(where, last_object) do                \
  103. {                                    \
  104.   if ((wabbit_buffer_ptr + 2) <= wabbit_buffer_hi)            \
  105.     kill_da_wabbit (where, last_object);                    \
  106.   else                                    \
  107.     wabbit_all_dead_p = false;                        \
  108. } while (0)
  109.  
  110. /* Oh, what have I done!  I've killed the little bunny wabbit... */
  111.  
  112. #define COPY_CELL()                            \
  113. {                                    \
  114.   *new_space_free++ = *old_space_addr;                    \
  115. }
  116.  
  117. #define COPY_PAIR()                            \
  118. {                                    \
  119.   *new_space_free++ = *old_space_addr++;                \
  120.   *new_space_free++ = *old_space_addr;                    \
  121. }
  122.  
  123. #define COPY_TRIPLE()                            \
  124. {                                    \
  125.   *new_space_free++ = *old_space_addr++;                \
  126.   *new_space_free++ = *old_space_addr++;                \
  127.   *new_space_free++ = *old_space_addr;                    \
  128. }
  129.  
  130. #define COPY_QUADRUPLE()                        \
  131. {                                    \
  132.   *new_space_free++ = *old_space_addr++;                \
  133.   *new_space_free++ = *old_space_addr++;                \
  134.   *new_space_free++ = *old_space_addr++;                \
  135.   *new_space_free++ = *old_space_addr;                    \
  136. }
  137.  
  138. #define COPY_VECTOR()                            \
  139. {                                    \
  140.   long veclen = (1 + (OBJECT_DATUM (* old_space_addr)));        \
  141.   SCHEME_OBJECT * vecend = (new_space_free + veclen);            \
  142.                                     \
  143.   if (vecend > wabbit_holes)                        \
  144.     discard_wabbit_holes_p (scan, new_space_free);            \
  145.   while (new_space_free != vecend)                    \
  146.     *new_space_free++ = *old_space_addr++;                \
  147. }
  148.  
  149. #define COPY_WEAK_PAIR()                        \
  150. {                                    \
  151.   long car_tag = (OBJECT_TYPE (* old_space_addr));            \
  152.   (*new_space_free++)                            \
  153.     = (OBJECT_NEW_TYPE (TC_NULL, (* old_space_addr)));            \
  154.   *new_space_free++ = *++old_space_addr;                \
  155.   * old_space_addr = (OBJECT_NEW_TYPE (car_tag, Weak_Chain));        \
  156.   Weak_Chain = this_object;                        \
  157. }
  158.  
  159. #define RELOCATE_NORMAL_SETUP()                        \
  160. {                                    \
  161.   old_space_addr = (OBJECT_ADDRESS (this_object));            \
  162.   if (old_space_addr < low_heap)                    \
  163.   {                                    \
  164.     if (HARE_P (old_space_addr))                    \
  165.       KILL_DA_WABBIT (scan, SHARP_F);                    \
  166.     continue;                                \
  167.   }                                    \
  168.   if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)        \
  169.   {                                    \
  170.     new_space_addr = (OBJECT_ADDRESS (* old_space_addr));        \
  171.     if (WABBIT_P (new_space_addr))                    \
  172.       KILL_DA_WABBIT (scan, SHARP_F);                    \
  173.     * scan = (MAKE_OBJECT_FROM_OBJECTS (this_object,            \
  174.                     (* old_space_addr)));        \
  175.     continue;                                \
  176.   }                                    \
  177. }
  178.  
  179. #define RELOCATE_NORMAL_END()                        \
  180. {                                    \
  181.   (* (OBJECT_ADDRESS (this_object)))                    \
  182.     = (MAKE_BROKEN_HEART (new_space_addr));                \
  183.   (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)),        \
  184.                    new_space_addr));            \
  185.   continue;                                \
  186. }
  187.  
  188. #define RELOCATE_NORMAL_POINTER(copy_code)                \
  189. {                                    \
  190.   RELOCATE_NORMAL_SETUP ();                        \
  191.   new_space_addr = new_space_free;                    \
  192.   copy_code;                                \
  193.   RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr);    \
  194.   RELOCATE_NORMAL_END ();                        \
  195. }
  196.  
  197. #define RELOCATE_ALIGNED_POINTER(copy_code)                \
  198. {                                    \
  199.   RELOCATE_NORMAL_SETUP ();                        \
  200.   ALIGN_FLOAT (new_space_free);                        \
  201.   new_space_addr = new_space_free;                    \
  202.   copy_code;                                \
  203.   RECORD_WABBIT_HOLE ((OBJECT_TYPE (this_object)), new_space_addr);    \
  204.   RELOCATE_NORMAL_END ();                        \
  205. }
  206.  
  207. #define RELOCATE_RAW_POINTER(tag, copy_code, last_object)        \
  208. {                                    \
  209.   old_space_addr = ((SCHEME_OBJECT *) this_object);            \
  210.   if (old_space_addr < low_heap)                    \
  211.   {                                    \
  212.     if (HARE_P (old_space_addr))                    \
  213.       KILL_DA_WABBIT (scan, last_object);                \
  214.     continue;                                \
  215.   }                                    \
  216.   if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)        \
  217.   {                                    \
  218.     new_space_addr = (OBJECT_ADDRESS (* old_space_addr));        \
  219.     if (WABBIT_P (new_space_addr))                    \
  220.       KILL_DA_WABBIT (scan, last_object);                \
  221.     * scan = ((SCHEME_OBJECT) new_space_addr);                \
  222.     continue;                                \
  223.   }                                    \
  224.   {                                    \
  225.     SCHEME_OBJECT * saved_old_addr = old_space_addr;            \
  226.                                     \
  227.     new_space_addr = new_space_free;                    \
  228.     copy_code;                                \
  229.     RECORD_WABBIT_HOLE (tag, new_space_addr);                \
  230.     (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr));        \
  231.     (* scan) = ((SCHEME_OBJECT) new_space_addr);            \
  232.     continue;                                \
  233.   }                                    \
  234. }
  235.  
  236. #define RELOCATE_COMPILED_ENTRY(last_object)                \
  237. {                                    \
  238.   Get_Compiled_Block (old_space_addr,                    \
  239.               ((SCHEME_OBJECT *) this_entry));            \
  240.   if (old_space_addr < low_heap)                    \
  241.   {                                    \
  242.     if (HARE_P (old_space_addr))                    \
  243.       KILL_DA_WABBIT (scan, last_object);                \
  244.     new_entry = this_entry;                        \
  245.   }                                    \
  246.   else if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)        \
  247.   {                                    \
  248.     new_space_addr = (OBJECT_ADDRESS (* old_space_addr));        \
  249.     if (WABBIT_P (new_space_addr))                    \
  250.       KILL_DA_WABBIT (scan, last_object);                \
  251.     new_entry =                                \
  252.       ((SCHEME_OBJECT)                            \
  253.        (RELOCATE_COMPILED_INTERNAL (this_entry,                \
  254.                     new_space_addr,            \
  255.                     old_space_addr)));            \
  256.   }                                    \
  257.   else                                    \
  258.   {                                    \
  259.     SCHEME_OBJECT * saved_old_addr = old_space_addr;            \
  260.                                     \
  261.     ALIGN_FLOAT (new_space_free);                    \
  262.     new_space_addr = new_space_free;                    \
  263.     new_entry =                                \
  264.       ((SCHEME_OBJECT)                            \
  265.        (RELOCATE_COMPILED_INTERNAL (this_entry,                \
  266.                     new_space_addr,            \
  267.                     old_space_addr)));            \
  268.     COPY_VECTOR ();                            \
  269.     RECORD_WABBIT_HOLE (TC_COMPILED_CODE_BLOCK, new_space_addr);    \
  270.     (* saved_old_addr) = (MAKE_BROKEN_HEART (new_space_addr));        \
  271.   }                                    \
  272. }
  273.  
  274. SCHEME_OBJECT *
  275. DEFUN (wabbit_hunting_gcloop, (scan, new_space_free_loc),
  276.        fast SCHEME_OBJECT * scan
  277.        AND SCHEME_OBJECT ** new_space_free_loc)
  278. {
  279.   long last_nmv_length;
  280.   fast SCHEME_OBJECT
  281.     * new_space_free, * old_space_addr, this_object,
  282.     * low_heap, * new_space_addr, this_entry, new_entry;
  283.   SCHEME_OBJECT
  284.     last_object, * last_object_end, * last_nmv, * last_hare, last_hare_head,
  285.     magic_cookie, saved_cookie, * saved_addr;
  286.  
  287.   last_object = SHARP_F;
  288.   last_object_end = 0;
  289.   last_nmv = (scan - 2);    /* Make comparison fail until */
  290.   last_nmv_length = 0;        /* an NMV is found. */
  291.   last_hare = (scan - 2);    /* Same here */
  292.   last_hare_head = SHARP_F;
  293.   magic_cookie = SHARP_F;
  294.   saved_cookie = SHARP_F;
  295.   saved_addr = 0;
  296.   new_space_free = * new_space_free_loc;
  297.   low_heap = Constant_Top;
  298.   for ( ; scan != new_space_free; scan++)
  299.   {
  300.     this_object = * scan;
  301.  
  302. repeat_dispatch:
  303.     Switch_by_GC_Type (this_object)
  304.     {
  305.       case TC_BROKEN_HEART:
  306.         old_space_addr = (OBJECT_ADDRESS (this_object));
  307.         if (scan == old_space_addr)
  308.     {
  309.       if (this_object == magic_cookie)
  310.       {
  311.         magic_cookie = SHARP_F;
  312.         last_hare = (scan - 1);
  313.         last_hare_head = scan[-1];
  314.         saved_addr[0] = scan[-1];
  315.         scan[-1] = (MAKE_BROKEN_HEART (saved_addr));
  316.         *scan = saved_cookie;
  317.         this_object = saved_cookie;
  318.         goto repeat_dispatch;
  319.       }
  320.       else
  321.       {
  322.         * new_space_free_loc = new_space_free;
  323.         return (scan);
  324.       }
  325.     }
  326.     else if ((old_space_addr < old_wabbit_buffer)
  327.          || (old_space_addr >= old_wabbit_buffer_end))
  328.     {
  329.       sprintf (gc_death_message_buffer,
  330.            "wabbit_hunting_gcloop: broken heart (0x%lx) in scan",
  331.            this_object);
  332.       gc_death (TERM_BROKEN_HEART, gc_death_message_buffer,
  333.             scan, new_space_free);
  334.       /*NOTREACHED*/
  335.     }
  336.     else
  337.         {
  338.       SCHEME_OBJECT old_head = old_space_addr[0];
  339.  
  340.       switch (GC_Type_Map [(OBJECT_TYPE (old_head))])
  341.       {
  342.         default:
  343.         case GC_Non_Pointer:
  344.           last_hare = scan;
  345.           last_hare_head = old_head;
  346.           break;
  347.  
  348.         case GC_Special:
  349.           if (((OBJECT_TYPE (old_head)) != TC_REFERENCE_TRAP)
  350.           || ((OBJECT_DATUM (old_head)) <= TRAP_MAX_IMMEDIATE))
  351.           {
  352.         this_object = old_head;
  353.         last_hare = scan;
  354.         last_hare_head = old_head;
  355.         goto repeat_dispatch;
  356.           }
  357.           /* fall through */
  358.  
  359.         case GC_Cell:
  360.         case GC_Pair:
  361.         case GC_Triple:
  362.         case GC_Quadruple:
  363.         case GC_Vector:
  364.           if ((OBJECT_ADDRESS (old_head)) == scan)
  365.           {
  366.         last_hare = scan;
  367.         last_hare_head = old_head;
  368.         KILL_DA_WABBIT (scan, old_head);
  369.         break;
  370.           }
  371.           /* fall through */
  372.  
  373.         case GC_Compiled:
  374.           saved_addr = old_space_addr;
  375.           saved_cookie = scan[1];
  376.           magic_cookie = (MAKE_BROKEN_HEART (scan + 1));
  377.           scan[1] = magic_cookie;
  378.           this_object = old_head;
  379.           *scan = old_head;
  380.           goto repeat_dispatch;
  381.       }
  382.     }
  383.     break;
  384.  
  385.       case TC_MANIFEST_NM_VECTOR:
  386.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  387.     if ((last_nmv + (1 + last_nmv_length)) == scan)
  388.       last_object = SHARP_F;
  389.     else if ((OBJECT_TYPE (scan[-1])) == TC_MANIFEST_VECTOR)
  390.     {
  391.       last_object
  392.         = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1)));
  393.       last_object_end = (scan + (OBJECT_DATUM (scan [-1])));
  394.     }
  395.     else if (((scan - 1) == last_hare)
  396.          && ((OBJECT_TYPE (last_hare_head)) == TC_MANIFEST_VECTOR))
  397.     {
  398.       last_object
  399.         = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, (scan - 1)));
  400.       last_object_end = (scan + (OBJECT_DATUM (last_hare_head)));
  401.     }
  402.     else
  403.       last_object = SHARP_F;
  404.  
  405.     last_nmv = scan;
  406.     last_nmv_length = (OBJECT_DATUM (this_object));
  407.     scan += last_nmv_length;
  408.     break;
  409.  
  410.       /* Compiled code relocation. */
  411.  
  412.       case TC_LINKAGE_SECTION:
  413.       {
  414.     SCHEME_OBJECT saved_last_object, * saved_last_object_end;
  415.  
  416.     saved_last_object = last_object;
  417.     saved_last_object_end = last_object_end;
  418.     if ((last_object == SHARP_F) || (last_object_end < scan))
  419.     {
  420.       last_object = (MAKE_POINTER_OBJECT (TC_HEADLESS_REFERENCE, scan));
  421.       last_object_end
  422.         = (scan + (1 + (READ_CACHE_LINKAGE_COUNT (this_object))));
  423.     }
  424.  
  425.     switch (READ_LINKAGE_KIND (this_object))
  426.     {
  427.       case REFERENCE_LINKAGE_KIND:
  428.       case ASSIGNMENT_LINKAGE_KIND:
  429.       {
  430.         /* Assumes that all others are objects of type TC_QUAD without
  431.            their type codes.
  432.            */
  433.  
  434.         fast long count;
  435.  
  436.         scan++;
  437.         for (count = (READ_CACHE_LINKAGE_COUNT (this_object));
  438.          --count >= 0;
  439.          scan += 1)
  440.         {
  441.           this_object = (* scan);
  442.           RELOCATE_RAW_POINTER (TC_QUAD, COPY_QUADRUPLE (), last_object);
  443.         }
  444.         scan -= 1;
  445.         break;
  446.       }
  447.  
  448.       case OPERATOR_LINKAGE_KIND:
  449.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  450.       {
  451.         fast long count;
  452.         fast char * word_ptr;
  453.         SCHEME_OBJECT * end_scan;
  454.  
  455.         START_OPERATOR_RELOCATION (scan);
  456.         count = (READ_OPERATOR_LINKAGE_COUNT (this_object));
  457.         word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (scan));
  458.         end_scan = (END_OPERATOR_LINKAGE_AREA (scan, count));
  459.  
  460.         while (--count >= 0)
  461.         {
  462.           scan = ((SCHEME_OBJECT *) word_ptr);
  463.           word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  464.           EXTRACT_OPERATOR_LINKAGE_ADDRESS (this_entry, scan);
  465.           RELOCATE_COMPILED_ENTRY (last_object);
  466.           STORE_OPERATOR_LINKAGE_ADDRESS (new_entry, scan);
  467.         }
  468.         scan = end_scan;
  469.         END_OPERATOR_RELOCATION (scan);
  470.         break;
  471.       }
  472.  
  473.       case CLOSURE_PATTERN_LINKAGE_KIND:
  474.         scan += (READ_CACHE_LINKAGE_COUNT (this_object));
  475.         break;
  476.  
  477.       default:
  478.       {
  479.         gc_death (TERM_EXIT,
  480.               "GC: Unknown compiler linkage kind.",
  481.               scan, Free);
  482.         /*NOTREACHED*/
  483.       }
  484.     }
  485.     last_object = saved_last_object;
  486.     last_object_end = saved_last_object_end;
  487.     break;
  488.       }
  489.  
  490.       case TC_MANIFEST_CLOSURE:
  491.       {
  492.     fast long count;
  493.     fast char * word_ptr;
  494.     SCHEME_OBJECT * area_end;
  495.     SCHEME_OBJECT saved_last_object, * saved_last_object_end;
  496.  
  497.     saved_last_object = last_object;
  498.     saved_last_object_end = last_object_end;
  499.     if ((last_object == SHARP_F) || (last_object_end < scan))
  500.     {
  501.       last_object = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, scan));
  502.       last_object_end = (scan + (1 + (OBJECT_DATUM (this_object))));
  503.     }
  504.     START_CLOSURE_RELOCATION (scan);
  505.     scan += 1;
  506.     count = (MANIFEST_CLOSURE_COUNT (scan));
  507.     word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (scan));
  508.     area_end = (MANIFEST_CLOSURE_END (scan, count));
  509.  
  510.     while ((--count) >= 0)
  511.     {
  512.       scan = ((SCHEME_OBJECT *) (word_ptr));
  513.       word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  514.       EXTRACT_CLOSURE_ENTRY_ADDRESS (this_entry, scan);
  515.       RELOCATE_COMPILED_ENTRY (last_object);
  516.       STORE_CLOSURE_ENTRY_ADDRESS (new_entry, scan);
  517.     }
  518.  
  519.     scan = area_end;
  520.     END_CLOSURE_RELOCATION (scan);
  521.     last_object = saved_last_object;
  522.     last_object_end = saved_last_object_end;
  523.     break;
  524.       }
  525.  
  526.       case_compiled_entry_point:
  527.       {
  528.     this_entry = ((SCHEME_OBJECT) (OBJECT_ADDRESS (this_object)));
  529.     RELOCATE_COMPILED_ENTRY (SHARP_F);
  530.     (* scan) = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (this_object)),
  531.                      ((SCHEME_OBJECT *) new_entry)));
  532.     continue;
  533.       }
  534.  
  535.       case_Cell:
  536.     RELOCATE_NORMAL_POINTER (COPY_CELL ());
  537.     break;
  538.  
  539.       case TC_REFERENCE_TRAP:
  540.     if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE)
  541.     {
  542.       /* It is a non pointer. */
  543.       break;
  544.     }
  545.     /* Fall Through. */
  546.  
  547.       case_Pair:
  548.     RELOCATE_NORMAL_POINTER (COPY_PAIR ());
  549.     break;
  550.  
  551.       case TC_VARIABLE:
  552.       case_Triple:
  553.     RELOCATE_NORMAL_POINTER (COPY_TRIPLE ());
  554.     break;
  555.  
  556.       case_Quadruple:
  557.     RELOCATE_NORMAL_POINTER (COPY_QUADRUPLE ());
  558.     break;
  559.  
  560.       case_Aligned_Vector:
  561.     RELOCATE_ALIGNED_POINTER (COPY_VECTOR ());
  562.     break;
  563.  
  564.       case TC_FUTURE:
  565.     if (Future_Spliceable (this_object))
  566.     {
  567.       * scan = (Future_Value (this_object));
  568.       scan -= 1;
  569.       continue;
  570.     }
  571.     /* fall through */
  572.  
  573.       case_Vector:
  574.     RELOCATE_NORMAL_POINTER (COPY_VECTOR ());
  575.     break;
  576.  
  577.       case TC_WEAK_CONS:
  578.     RELOCATE_NORMAL_POINTER (COPY_WEAK_PAIR ());
  579.     break;
  580.  
  581.       default:
  582.     sprintf (gc_death_message_buffer,
  583.          "wabbit_hunting_gcloop: bad type code (0x%02x)",
  584.          ((unsigned int) (OBJECT_TYPE (this_object))));
  585.     gc_death (TERM_INVALID_TYPE_CODE,
  586.           gc_death_message_buffer,
  587.           scan, new_space_free);
  588.     /*NOTREACHED*/
  589.  
  590.       case_Non_Pointer:
  591.     break;
  592.  
  593.       }    /* Switch_by_GC_Type */
  594.   } /* For loop */
  595.  
  596.   * new_space_free_loc = new_space_free;
  597.   return (new_space_free);
  598.  
  599. } /* wabbit_hunting_gcloop */
  600.  
  601. void
  602. DEFUN (wabbit_season, (wabbit_descriptor),
  603.        SCHEME_OBJECT wabbit_descriptor)
  604. {
  605.   long n_wabbits, buf_len, ctr;
  606.   SCHEME_OBJECT
  607.     * result, * area, * saved_area,
  608.     wabbit_buffer, wabbit_vector, * wabbit_vector_ptr;
  609.  
  610.   wabbit_vector = (VECTOR_REF (wabbit_descriptor, 1));
  611.   wabbit_buffer = (VECTOR_REF (wabbit_descriptor, 2));
  612.     
  613.   buf_len = (VECTOR_LENGTH (wabbit_buffer));
  614.   n_wabbits = (VECTOR_LENGTH (wabbit_vector));
  615.  
  616.   wabbit_all_dead_p = true;
  617.   wabbit_holes_overwritten_p = false;
  618.   wabbit_holes_discarded_p = false;
  619.   wabbit_holes_hi = Heap_Top;
  620.   wabbit_holes = wabbit_holes_hi;
  621.  
  622.   saved_area = area = Free;
  623.   wabbit_lo_address = saved_area;
  624.   wabbit_hi_address = saved_area;
  625.   wabbit_of_Seville = saved_area;
  626.  
  627.   wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 0));
  628.   for (ctr = n_wabbits; ctr >= 0; ctr -= 1)
  629.     *area++ = *wabbit_vector_ptr++;
  630.  
  631.   MEMORY_SET (wabbit_vector, 0, (MAKE_BROKEN_HEART (saved_area)));
  632.   *area = (MAKE_BROKEN_HEART (area));
  633.   Free = (area + 1);
  634.   
  635.   result = (wabbit_hunting_gcloop (saved_area, &Free));
  636.   if (result != area)
  637.   {
  638.     outf_fatal ("\nwabbit_hunt Wabbit scan ended too early.\n");
  639.     Microcode_Termination (TERM_BROKEN_HEART);
  640.   }
  641.  
  642.   *area = SHARP_F;        /* Remove broken heart on Valentine's day */
  643.   wabbit_lo_address = (area + 1);
  644.   wabbit_hi_address = Free;
  645.  
  646.   if (BROKEN_HEART_P (MEMORY_REF (wabbit_buffer, 0)))
  647.     /* One of the wabbits is the wabbit buffer itself! */
  648.     wabbit_buffer_lo = (OBJECT_ADDRESS (MEMORY_REF (wabbit_buffer, 0)));
  649.   else
  650.   {
  651.     wabbit_buffer_lo = Free;
  652.     MEMORY_SET (wabbit_buffer, 0, (MAKE_BROKEN_HEART (wabbit_buffer_lo)));
  653.     Free += (1 + buf_len);
  654.   }
  655.   wabbit_buffer_hi = (wabbit_buffer_lo + (1 + buf_len));
  656.   * wabbit_buffer_lo = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, buf_len));
  657.   wabbit_buffer_ptr = (wabbit_buffer_lo + 3);
  658.  
  659.   /* Check whether any wabbits are hares, and if so, mark them so. */
  660.  
  661.   old_wabbit_buffer = ((OBJECT_ADDRESS (wabbit_buffer)) + 3);
  662.   old_wabbit_buffer[-1] = (MAKE_BROKEN_HEART (old_wabbit_buffer - 1));
  663.  
  664.   wabbit_vector_ptr = (MEMORY_LOC (wabbit_vector, 1));
  665.   
  666.   for (area = old_wabbit_buffer, ctr = n_wabbits; --ctr >= 0; )
  667.   {
  668.     SCHEME_OBJECT wabbit = *wabbit_vector_ptr++;
  669.     SCHEME_OBJECT old_head;
  670.  
  671.     switch (GC_Type_Map [(OBJECT_TYPE (wabbit))])
  672.     {
  673.       case GC_Non_Pointer:
  674.         /* Sucker -- should crash his scheme */
  675.         break;
  676.  
  677.       case GC_Special:
  678.     if (((OBJECT_TYPE (wabbit)) != TC_REFERENCE_TRAP)
  679.         || ((OBJECT_DATUM (wabbit)) <= TRAP_MAX_IMMEDIATE))
  680.       break;
  681.     /* fall through */
  682.  
  683.       case GC_Cell:
  684.       case GC_Pair:
  685.       case GC_Triple:
  686.       case GC_Quadruple:
  687.       case GC_Vector:
  688.     if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top)
  689.       break;
  690.     old_head = (MEMORY_REF (wabbit, 0));
  691.     MEMORY_SET (wabbit, 0, (MAKE_BROKEN_HEART (area)));
  692.     *area++ = old_head;
  693.     *area++ = wabbit;
  694.     break;
  695.  
  696.       case GC_Compiled:
  697.       {
  698.     SCHEME_OBJECT * block;
  699.  
  700.     if ((OBJECT_ADDRESS (wabbit)) >= Constant_Top)
  701.       break;
  702.  
  703.     Get_Compiled_Block (block, (OBJECT_ADDRESS (wabbit)));
  704.     old_head = *block;
  705.     *block = (MAKE_BROKEN_HEART (area));
  706.     *area++ = old_head;
  707.     *area++ = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block));
  708.     break;
  709.       }
  710.  
  711.       default:
  712.     /* Loser -- shouldn't happen */
  713.     break;
  714.     }
  715.   }
  716.   old_wabbit_buffer_end = area;
  717.  
  718.   result = (wabbit_hunting_gcloop (wabbit_lo_address, &Free));
  719.   if (Free != result)
  720.   {
  721.     outf_fatal ("\nwabbit_hunt: heap scan ended too early.\n");
  722.     Microcode_Termination (TERM_BROKEN_HEART);
  723.   }
  724.   return;
  725. }
  726.  
  727. void
  728. DEFUN (duck_season, (wabbit_descriptor),
  729.        SCHEME_OBJECT wabbit_descriptor)
  730. {
  731.   SCHEME_OBJECT * ptr;
  732.  
  733.   /* Restore hares' heads */
  734.  
  735.   for (ptr = old_wabbit_buffer; ptr < old_wabbit_buffer_end; ptr += 2)
  736.     MEMORY_SET (ptr[1], 0, ptr[0]);
  737.  
  738.   wabbit_buffer_lo[2] =
  739.     (LONG_TO_UNSIGNED_FIXNUM (wabbit_buffer_ptr - (wabbit_buffer_lo + 1)));
  740.   while (wabbit_buffer_ptr < wabbit_buffer_hi)
  741.     *wabbit_buffer_ptr++ = SHARP_F;
  742.   wabbit_buffer_lo[1] = (BOOLEAN_TO_OBJECT (wabbit_all_dead_p));
  743.   wabbit_buffer_lo[0]
  744.     = (MAKE_OBJECT (TC_MANIFEST_VECTOR,
  745.             (wabbit_buffer_hi - (wabbit_buffer_lo + 1))));
  746.  
  747.   if ((VECTOR_REF (wabbit_descriptor, 3)) == SHARP_T)
  748.   {
  749.     SCHEME_OBJECT * guaranteed_free = (Free + (GC_Reserve + 2));
  750.     SCHEME_OBJECT * source, * dest, result;
  751.     long len;
  752.  
  753.     if (guaranteed_free > wabbit_holes)
  754.     {
  755.       wabbit_holes_discarded_p = true;
  756.       wabbit_holes = guaranteed_free;
  757.     }
  758.     dest = Free;
  759.     result = (MAKE_POINTER_OBJECT (TC_VECTOR, dest));
  760.     source = wabbit_holes;
  761.     len = (wabbit_holes_hi - source);
  762.     *dest++ = (MAKE_OBJECT (TC_MANIFEST_VECTOR, (len + 1)));
  763.     *dest++ = (BOOLEAN_TO_OBJECT (! (wabbit_holes_discarded_p
  764.                      || wabbit_holes_overwritten_p)));
  765.     while (--len >= 0)
  766.       *dest++ = *source++;
  767.     Free = dest;
  768.     VECTOR_SET (wabbit_descriptor, 3, result);
  769.   }
  770.  
  771.   VECTOR_SET (wabbit_descriptor, 0, SHARP_T);
  772.   return;
  773. }
  774.  
  775. SCHEME_OBJECT *
  776. DEFUN (hunt_wabbit, (where), SCHEME_OBJECT * where)
  777. {
  778.   SCHEME_OBJECT * ptr_lo, * ptr_hi, * ptr_mid, * hole;
  779.  
  780.   ptr_lo = wabbit_holes;
  781.   ptr_hi = (wabbit_holes_hi - 1);
  782.  
  783.   while (ptr_lo < ptr_hi)
  784.   {
  785.     ptr_mid = (ptr_lo + ((ptr_hi - ptr_lo) / 2));
  786.     hole = (OBJECT_ADDRESS (* ptr_mid));
  787.     if (where < hole)
  788.       ptr_lo = (ptr_mid + 1);
  789.     else if (where > hole)
  790.       ptr_hi = ptr_mid;
  791.     else
  792.     {
  793.       ptr_hi = ptr_mid;
  794.       ptr_lo = ptr_mid;
  795.       break;
  796.     }
  797.   }
  798.   return (ptr_lo);
  799. }
  800.  
  801. Boolean
  802. DEFUN (discard_wabbit_holes_p, (scan, free),
  803.        SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
  804. {
  805.   SCHEME_OBJECT * hole, * new_hole;
  806.   long keep_index;
  807.  
  808.   if (free > wabbit_holes)
  809.   {
  810.     wabbit_holes_overwritten_p = true;
  811.     wabbit_holes = free;    
  812.   }
  813.   if (scan < Constant_Top)
  814.     return (free < wabbit_holes);
  815.  
  816.   hole = ((hunt_wabbit (scan)) + 1);
  817.  
  818.   /* This guarantees that we don't get into quadratic copying:
  819.      We discard only if the fraction of holes being discarded
  820.      is at least 1/ELMER_HUNG_FACTOR of the total number of holes.
  821.    */
  822.  
  823.   if ((ELMER_HUNG_FACTOR * (wabbit_holes_hi - hole))
  824.       < (wabbit_holes_hi - wabbit_holes))
  825.     return (free < wabbit_holes);
  826.  
  827.   keep_index = (hole - wabbit_holes);
  828.   new_hole = wabbit_holes_hi;
  829.  
  830.   while (--keep_index >= 0)
  831.     *--new_hole = *--hole;
  832.  
  833.   wabbit_holes = new_hole;
  834.   wabbit_holes_discarded_p = true;
  835.   return (free < wabbit_holes);
  836. }
  837.  
  838. void
  839. DEFUN (kill_da_wabbit, (where, current_object),
  840.        SCHEME_OBJECT * where AND SCHEME_OBJECT current_object)
  841. {
  842.   SCHEME_OBJECT * hole, wabbit, * wabbit_addr;
  843.   long offset, max_offset;
  844.  
  845.   /* With my sword and magic helmet... */
  846.  
  847.   if (where < Constant_Top)
  848.   {
  849.     SCHEME_OBJECT head;
  850.  
  851.     if (current_object != SHARP_F)
  852.     {
  853.       offset = (where - (OBJECT_ADDRESS (current_object)));
  854.       head = current_object;
  855.     }
  856.     else
  857.     {
  858.       /* If we do cwcc before calling the special garbage collector,
  859.      there should be no references to the stack.
  860.        */
  861.       offset = 0;
  862.       if (where < Stack_Top)
  863.     head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_STACK, where));
  864.       else
  865.     head = (MAKE_POINTER_OBJECT (TC_REFERENCE_TO_CONSTANT_SPACE, where));
  866.     }
  867.  
  868.     *wabbit_buffer_ptr++ = head;
  869.     *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset));
  870.     return;
  871.   }
  872.   if (wabbit_holes >= wabbit_holes_hi)
  873.     return;
  874.  
  875.   hole = (hunt_wabbit (where));
  876.   wabbit = (* hole);
  877.   wabbit_addr = (OBJECT_ADDRESS (wabbit));
  878.   offset = (where - wabbit_addr);
  879.   *wabbit_buffer_ptr++ = wabbit;
  880.   *wabbit_buffer_ptr++ = (LONG_TO_UNSIGNED_FIXNUM (offset));
  881.  
  882.   if ((hole == wabbit_holes)
  883.       && wabbit_holes_overwritten_p && (where != wabbit_addr))
  884.   {
  885.     switch (GC_Type_Map[(OBJECT_TYPE (wabbit))])
  886.     {
  887.       case GC_Pair:
  888.         max_offset = 2;
  889.     break;
  890.  
  891.       case GC_Triple:
  892.         max_offset = 3;
  893.     break;
  894.  
  895.       case GC_Quadruple:
  896.         max_offset = 4;
  897.     break;
  898.  
  899.       case GC_Vector:
  900.     max_offset = (1 + (OBJECT_DATUM (* wabbit_addr)));
  901.     break;
  902.     
  903.       case GC_Special:
  904.         if ((OBJECT_TYPE (* hole)) == TC_REFERENCE_TRAP)
  905.     {
  906.       max_offset = 2;
  907.       break;
  908.     }
  909.     /* fall through */
  910.  
  911.       case GC_Cell:    /* => (where == wabbit_addr), already tested */
  912.       default:
  913.     max_offset = -1;
  914.     }
  915.     if ((max_offset == -1) || (where > (wabbit_addr + max_offset)))
  916.     {
  917.       wabbit_buffer_ptr -= 2;
  918.       wabbit_all_dead_p = false;
  919.     }
  920.   }
  921.   return;
  922. }
  923.  
  924. /* Alternate version of Fix_Weak_Chain that hunts wabbits. */
  925.  
  926. #ifndef EMPTY_WEAK_CHAIN
  927. #define EMPTY_WEAK_CHAIN EMPTY_LIST
  928. #endif
  929.  
  930. void
  931. DEFUN_VOID (fix_weak_chain_and_hunt_wabbits)
  932. {
  933.   fast SCHEME_OBJECT
  934.     * old_weak_pair, * scan, nulled_car, * new_space_addr,
  935.     this_object, * old_space_addr, * low_heap;
  936.  
  937.   low_heap = Constant_Top;
  938.   while (Weak_Chain != EMPTY_WEAK_CHAIN)
  939.   {
  940.     old_weak_pair = (OBJECT_ADDRESS (Weak_Chain));
  941.     scan = (OBJECT_ADDRESS (*old_weak_pair++));
  942.     Weak_Chain = * old_weak_pair;
  943.     nulled_car = * scan;
  944.     this_object = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, nulled_car));
  945.     Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
  946.  
  947.     switch (GC_Type (this_object))
  948.     {
  949.       case GC_Non_Pointer:
  950.         *scan = this_object;
  951.     continue;
  952.  
  953.       case GC_Special:
  954.     if ((OBJECT_TYPE (this_object)) != TC_REFERENCE_TRAP)
  955.     {
  956.       /* No other special type makes sense here. */
  957.       goto fail;
  958.     }
  959.     if ((OBJECT_DATUM (this_object)) <= TRAP_MAX_IMMEDIATE)
  960.     {
  961.       * scan = this_object;
  962.       continue;
  963.     }
  964.     /* Otherwise, it is a pointer.  Fall through */
  965.  
  966.       /* Normal pointer types, the broken heart is in the first word.
  967.          Note that most special types are treated normally here.
  968.        */
  969.       case GC_Cell:
  970.       case GC_Pair:
  971.       case GC_Triple:
  972.       case GC_Quadruple:
  973.       case GC_Vector:
  974.     * scan = this_object;    /* In case it points to constant space */
  975.     RELOCATE_NORMAL_SETUP ();
  976.     * scan = SHARP_F;
  977.     continue;
  978.  
  979.       case GC_Compiled:
  980.     * scan = this_object;
  981.     old_space_addr = (OBJECT_ADDRESS (this_object));
  982.     if (old_space_addr < low_heap)
  983.       continue;
  984.     Get_Compiled_Block (old_space_addr, old_space_addr);
  985.     if ((OBJECT_TYPE (* old_space_addr)) == TC_BROKEN_HEART)
  986.     {
  987.       new_space_addr = (OBJECT_ADDRESS (* old_space_addr));
  988.       if (WABBIT_P (new_space_addr))
  989.         KILL_DA_WABBIT (scan, (MAKE_POINTER_OBJECT (TC_WEAK_CONS, scan)));
  990.         
  991.       * scan = (RELOCATE_COMPILED (this_object,
  992.                        new_space_addr,
  993.                        old_space_addr));
  994.       continue;
  995.     }
  996.     * scan = SHARP_F;
  997.     continue;
  998.  
  999.       case GC_Undefined:
  1000.     outf_error
  1001.       ("\nfix_weak_chain_and_hunt_wabbits: Clearing bad object 0x%08lx.\n",
  1002.        this_object);
  1003.     * scan = SHARP_F;
  1004.     continue;
  1005.  
  1006.       default:            /* Non Marked Headers and Broken Hearts */
  1007.       fail:
  1008.         outf_fatal
  1009.       ("\nfix_weak_chain_and_hunt_wabbits: Bad Object: 0x%08lx.\n",
  1010.        this_object);
  1011.     * scan = SHARP_F;
  1012.     /*NOTREACHED*/
  1013.     }
  1014.   }
  1015.   return;
  1016. }
  1017.  
  1018. /* What did you expect from opera, a happy ending? */
  1019.