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 / memmag.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  20KB  |  698 lines
  1. /* -*-C-*-
  2.  
  3. $Id: memmag.c,v 9.66 2000/12/05 21:23:45 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* Memory management top level.
  23.  
  24.    The memory management code is spread over 4 files:
  25.    - memmag.c: initialization.
  26.    - gcloop.c: main garbage collector loop.
  27.    - purify.c: constant/pure space hacking.
  28.    - wabbit.c: alternate garbage collector loop that collects references.
  29.    There is also a relevant header file, gccode.h.
  30.  
  31.    The object dumper, fasdump, shares properties and code with the
  32.    memory management utilities.
  33.  */
  34.  
  35. #include "scheme.h"
  36. #include "prims.h"
  37. #include "memmag.h"
  38. #include "gccode.h"
  39.  
  40. /* Imports */
  41.  
  42. extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
  43. extern SCHEME_OBJECT * EXFUN
  44.   (wabbit_hunting_gcloop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
  45. extern void EXFUN (wabbit_season, (SCHEME_OBJECT));
  46. extern void EXFUN (duck_season, (SCHEME_OBJECT));
  47. extern void EXFUN (fix_weak_chain_and_hunt_wabbits, (void));
  48. extern void EXFUN (error_unimplemented_primitive, (void));
  49.  
  50.  
  51. /* Exports */
  52.  
  53. extern void
  54.   EXFUN (GCFlip, (void)),
  55.   EXFUN (GC, (void));
  56.  
  57. extern void
  58.   EXFUN (Clear_Memory, (int, int, int)),
  59.   EXFUN (Setup_Memory, (int, int, int)),
  60.   EXFUN (Reset_Memory, (void));
  61.  
  62. /*     Memory Allocation, sequential processor:
  63.  
  64. oo
  65.    ------------------------------------------ <- fixed boundary (currently)
  66.    |           Heap 2                |
  67.    |                                        |
  68.    ------------------------------------------ <- boundary moved by purify
  69.    |           Heap 1                |
  70.    |                                        |
  71.    ------------------------------------------ <- boundary moved by purify
  72.    |     Constant + Pure Space    /\        |
  73.    |                              ||        |
  74.    ------------------------------------------ <- fixed boundary (currently)
  75.    |         Control Stack        ||        |
  76.    |                              \/        |
  77.    ------------------------------------------ <- fixed boundary (currently)
  78. 0
  79.  
  80.    Each area has a pointer to its starting address and a pointer to
  81.    the next free cell (for the stack, it is a pointer to the last cell
  82.    in use).  In addition, there is a pointer to the top of the
  83.    useable area of the heap (the heap is subdivided into two areas for
  84.    the purposes of GC, and this pointer indicates the top of the half
  85.    currently in use).
  86.  
  87. */
  88.  
  89. #define CONSTANT_SPACE_FUDGE    128
  90.  
  91. /* Initialize free pointers within areas. Stack_Pointer is
  92.    special: it always points to a cell which is in use.
  93.  */
  94.  
  95. static long saved_heap_size, saved_constant_size, saved_stack_size;
  96. extern void EXFUN (reset_allocator_parameters, (void));
  97. extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
  98.  
  99. Boolean
  100. DEFUN (update_allocator_parameters, (ctop), SCHEME_OBJECT * ctop)
  101. {
  102.   /* buffer for impurify, etc. */
  103.   SCHEME_OBJECT * nctop = (ctop + CONSTANT_SPACE_FUDGE);
  104.   unsigned long temp;
  105.  
  106.   if (nctop >= (Highest_Allocated_Address + 1))
  107.     return (FALSE);
  108.  
  109.   Constant_Top = nctop;
  110.   temp = ((Highest_Allocated_Address - Constant_Top) / 2);
  111.   Heap_Bottom = Constant_Top;
  112.   Heap_Top = (Heap_Bottom + temp);
  113.   Local_Heap_Base = Heap_Bottom;
  114.   Unused_Heap_Bottom = Heap_Top;
  115.   Unused_Heap_Top = Highest_Allocated_Address;
  116.   Free = Heap_Bottom;
  117.   return (TRUE);
  118. }
  119.  
  120. void
  121. DEFUN_VOID (reset_allocator_parameters)
  122. {
  123.   GC_Reserve = 4500;
  124.   GC_Space_Needed = 0;
  125.   Stack_Bottom = Lowest_Allocated_Address;
  126.   Stack_Top = (Stack_Bottom + (STACK_ALLOCATION_SIZE (saved_stack_size)));
  127.   Constant_Space = Stack_Top;
  128.   Free_Constant = Constant_Space;
  129.   ALIGN_FLOAT (Free_Constant);
  130.   (void) update_allocator_parameters (Free_Constant);
  131.   SET_CONSTANT_TOP ();
  132.   ALIGN_FLOAT (Free);
  133.   SET_MEMTOP (Heap_Top - GC_Reserve);
  134.   INITIALIZE_STACK ();
  135.   STACK_RESET ();
  136.   return;
  137. }
  138.  
  139. void
  140. DEFUN (Clear_Memory,
  141.        (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
  142.        int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size)
  143. {
  144.   saved_heap_size = Our_Heap_Size;
  145.   saved_constant_size = Our_Constant_Size;
  146.   saved_stack_size = Our_Stack_Size;
  147.   reset_allocator_parameters ();
  148. }
  149.  
  150. static void 
  151. DEFUN_VOID (failed_consistency_check)
  152. {
  153.   outf_flush_fatal ();
  154.   exit (1);
  155. }
  156.  
  157. void
  158. DEFUN_VOID (Reset_Memory)
  159. {
  160.   HEAP_FREE (Lowest_Allocated_Address);
  161.   DEALLOCATE_REGISTERS ();
  162.   return;
  163. }
  164.  
  165. /* This procedure allocates and divides the total memory. */
  166.  
  167. void
  168. DEFUN (Setup_Memory,
  169.        (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size),
  170.        int Our_Heap_Size AND int Our_Stack_Size AND int Our_Constant_Size)
  171. {
  172.   SCHEME_OBJECT test_value;
  173.  
  174.   ALLOCATE_REGISTERS ();
  175.  
  176.   /* Consistency check 1 */
  177.   if (Our_Heap_Size == 0)
  178.   {
  179.     outf_fatal ("Configuration won't hold initial data.\n");
  180.     failed_consistency_check ();
  181.   }
  182.  
  183.   /* Allocate */
  184.   
  185.   ALLOCATE_HEAP_SPACE (((STACK_ALLOCATION_SIZE (Our_Stack_Size))
  186.             + (2 * Our_Heap_Size)
  187.             + Our_Constant_Size),
  188.                Lowest_Allocated_Address,
  189.                Highest_Allocated_Address);
  190.  
  191.   /* Consistency check 2 */
  192.   if (Lowest_Allocated_Address == NULL)
  193.   {
  194.     outf_fatal ("Not enough memory for this configuration.\n");
  195.     failed_consistency_check ();
  196.   }
  197.  
  198.   /* Consistency check 3 */
  199.  
  200.   test_value = (MAKE_POINTER_OBJECT (LAST_TYPE_CODE,
  201.                      Highest_Allocated_Address));
  202.  
  203.   if (((OBJECT_TYPE (test_value)) != LAST_TYPE_CODE) ||
  204.       ((OBJECT_ADDRESS (test_value)) != Highest_Allocated_Address))
  205.   {
  206.     outf_fatal (
  207.         "Largest address does not fit in datum field of object.\n");
  208.     outf_fatal (
  209.         "Allocate less space or re-configure without HEAP_IN_LOW_MEMORY.\n");
  210.     Reset_Memory ();
  211.     failed_consistency_check ();
  212.   }
  213.  
  214.   Clear_Memory (Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
  215.   return;
  216. }
  217.  
  218. /* Utilities for the garbage collector top level.
  219.    The main garbage collector loop is in gcloop.c
  220. */
  221.  
  222. /* Flip into unused heap, extending constant space if we are flipping
  223.    to the low heap, and the fudge area has shrunk.
  224.  */
  225.  
  226. void
  227. DEFUN_VOID (GCFlip)
  228. {
  229.   if (((Constant_Top - Free_Constant) < CONSTANT_SPACE_FUDGE)
  230.       && (Unused_Heap_Bottom < Heap_Bottom)
  231.       && (update_allocator_parameters (Free_Constant)))
  232.     SET_CONSTANT_TOP ();
  233.   else
  234.   {
  235.     SCHEME_OBJECT * temp_bottom, * temp_top;
  236.  
  237.     temp_bottom = Unused_Heap_Bottom;
  238.     temp_top = Unused_Heap_Top;
  239.  
  240.     Unused_Heap_Bottom = Heap_Bottom;
  241.     Unused_Heap_Top = Heap_Top;
  242.  
  243.     Heap_Bottom = temp_bottom;
  244.     Heap_Top = temp_top;
  245.  
  246.     Free = Heap_Bottom;
  247.   }
  248.  
  249.   ALIGN_FLOAT (Free);
  250.   SET_MEMTOP (Heap_Top - GC_Reserve);
  251.  
  252.   Weak_Chain = EMPTY_WEAK_CHAIN;
  253.   return;
  254. }
  255.  
  256. /* Here is the code which "prunes" objects from weak cons cells.  See
  257.    the picture in gccode.h for a description of the structure built by
  258.    the GC.  This code follows the chain of weak cells (in old space) and
  259.    either updates the new copy's CAR with the relocated version of the
  260.    object, or replaces it with SHARP_F.
  261.  
  262.    Note that this is the only code in the system, besides the inner garbage
  263.    collector, which looks at both old and new space.
  264. */
  265.  
  266. SCHEME_OBJECT Weak_Chain;
  267.  
  268. void
  269. DEFUN_VOID (Fix_Weak_Chain)
  270. {
  271.   fast SCHEME_OBJECT
  272.     * Old_Weak_Cell, * Scan, Old_Car,
  273.     Temp, * Old, * low_heap;
  274.  
  275.   low_heap = Constant_Top;
  276.   while (Weak_Chain != EMPTY_WEAK_CHAIN)
  277.   {
  278.     Old_Weak_Cell = (OBJECT_ADDRESS (Weak_Chain));
  279.     Scan = (OBJECT_ADDRESS (*Old_Weak_Cell++));
  280.     Weak_Chain = * Old_Weak_Cell;
  281.     Old_Car = * Scan;
  282.     Temp = (MAKE_OBJECT_FROM_OBJECTS (Weak_Chain, Old_Car));
  283.     Weak_Chain = (OBJECT_NEW_TYPE (TC_NULL, Weak_Chain));
  284.  
  285.     switch (GC_Type (Temp))
  286.     { case GC_Non_Pointer:
  287.         *Scan = Temp;
  288.     continue;
  289.  
  290.       case GC_Special:
  291.     if ((OBJECT_TYPE (Temp)) != TC_REFERENCE_TRAP)
  292.     {
  293.       /* No other special type makes sense here. */
  294.       goto fail;
  295.     }
  296.     if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  297.     {
  298.       *Scan = Temp;
  299.       continue;
  300.     }
  301.     /* Otherwise, it is a pointer.  Fall through */
  302.  
  303.       /* Normal pointer types, the broken heart is in the first word.
  304.          Note that most special types are treated normally here.
  305.      The BH code updates *Scan if the object has been relocated.
  306.      Otherwise it falls through and we replace it with a full SHARP_F.
  307.      Eliminating this assignment would keep old data (pl. of datum).
  308.        */
  309.       case GC_Cell:
  310.       case GC_Pair:
  311.       case GC_Triple:
  312.       case GC_Quadruple:
  313.       case GC_Vector:
  314.     Old = (OBJECT_ADDRESS (Old_Car));
  315.     if (Old < low_heap)
  316.     {
  317.       *Scan = Temp;
  318.       continue;
  319.     }
  320.     Normal_BH (false, continue);
  321.     *Scan = SHARP_F;
  322.     continue;
  323.  
  324.       case GC_Compiled:
  325.     Old = (OBJECT_ADDRESS (Old_Car));
  326.     if (Old < low_heap)
  327.     {
  328.       *Scan = Temp;
  329.       continue;
  330.     }
  331.     Compiled_BH (false, { *Scan = Temp; continue; });
  332.     *Scan = SHARP_F;
  333.     continue;
  334.  
  335.       case GC_Undefined:
  336.     outf_error ("\nFix_Weak_Chain: Clearing bad object 0x%08lx.\n",
  337.             Temp);
  338.     *Scan = SHARP_F;
  339.     continue;
  340.  
  341.       default:            /* Non Marked Headers and Broken Hearts */
  342.       fail:
  343.         outf_fatal ("\nFix_Weak_Chain: Bad Object: 0x%08lx.\n",
  344.             Temp);
  345.     *Scan = SHARP_F;
  346.     }
  347.   }
  348.   return;
  349. }
  350.  
  351. #ifdef __WIN32__
  352.  
  353. static void
  354. win32_flush_old_halfspace ()
  355. {
  356.   /* Since we allocated the heap with VirtualAlloc, we can decommit the old
  357.      half-space to tell the VM system that it contains trash.
  358.      Immediately recommitting the region allows the old half-space to be used
  359.      for temporary storage (e.g. by fasdump).
  360.      Note that this is only a win when it prevents paging.  When no paging
  361.      would have happened, we incur the cost of zero-filling the recommitted
  362.      pages.  This can be significant - up to 50% of the time taken to GC, but
  363.      usually somewhat less.
  364.  
  365.      We are careful to play with pages that are strictly within the old
  366.      half-space, hence the `pagesize' arithmetic.
  367.      */
  368.   long pagesize = 4096;
  369.   void *base =
  370.     ((void*)
  371.      (((DWORD)((char*)Unused_Heap_Bottom + pagesize)) & ~(pagesize-1)));
  372.   DWORD  len =
  373.     ((DWORD)(((char*)Unused_Heap_Top) - ((char*)base))) & ~(pagesize-1);
  374.   VirtualFree (base, len, MEM_DECOMMIT);
  375.   VirtualAlloc (base, len, MEM_COMMIT, PAGE_READWRITE);
  376. }
  377.  
  378.  
  379. static BOOL win32_flush_old_halfspace_p = FALSE;
  380.  
  381. void
  382. win32_advise_end_GC ()
  383. {
  384.   if (win32_flush_old_halfspace_p)
  385.     win32_flush_old_halfspace ();
  386. }
  387. #endif /* __WIN32__ */
  388.  
  389. DEFINE_PRIMITIVE ("WIN32-FLUSH-OLD-HALFSPACE-AFTER-GC?!", Prim_win32_flush_old_halfspace_after_gc, 1, 1,
  390.           "(boolean)")
  391. {
  392.   PRIMITIVE_HEADER (1);
  393. #ifdef __WIN32__
  394.   {
  395.     BOOL old = win32_flush_old_halfspace_p;
  396.     win32_flush_old_halfspace_p = (OBJECT_TO_BOOLEAN (ARG_REF (1)));
  397.     PRIMITIVE_RETURN (old ? SHARP_T : SHARP_F);
  398.   }
  399. #else
  400.   error_unimplemented_primitive ();
  401.   PRIMITIVE_RETURN (SHARP_F);
  402. #endif
  403. }
  404.  
  405. DEFINE_PRIMITIVE ("WIN32-FLUSH-OLD-HALFSPACE!", Prim_win32_flush_old_halfspace, 0, 0,
  406.           "()")
  407. {
  408.   PRIMITIVE_HEADER (0);
  409. #ifdef __WIN32__
  410.   win32_flush_old_halfspace ();
  411. #else
  412.   error_unimplemented_primitive ();
  413. #endif
  414.   PRIMITIVE_RETURN (UNSPECIFIC);
  415. }
  416.  
  417. /* Here is the set up for the full garbage collection:
  418.  
  419.    - First it saves away all the relevant microcode registers into new
  420.    space, making this the root for garbage collection.
  421.  
  422.    - Then it does the actual garbage collection in 4 steps:
  423.      1) Trace the stack and constant space (contiguous).
  424.      2) Trace objects pointed out by the root and constant space.
  425.      3) Trace the precious objects, remembering where consing started.
  426.      4) Update all weak pointers.
  427.  
  428.    - Finally it restores the microcode registers from the copies in
  429.    new space.
  430. */
  431.  
  432. void
  433. DEFUN_VOID (GC)
  434. {
  435.   Boolean hunting_wabbits_p;
  436.   SCHEME_OBJECT
  437.     * Root, * Result, * Check_Value,
  438.     The_Precious_Objects, * Root2;
  439.   SCHEME_OBJECT wabbit_descriptor;
  440.   SCHEME_OBJECT *
  441.     EXFUN ((* transport_loop), (SCHEME_OBJECT *, SCHEME_OBJECT **));
  442.  
  443.   wabbit_descriptor = (Get_Fixed_Obj_Slot (GC_WABBIT_DESCRIPTOR));
  444.   if ((! (VECTOR_P (wabbit_descriptor)))
  445.       || ((VECTOR_LENGTH (wabbit_descriptor)) != 4)
  446.       || ((VECTOR_REF (wabbit_descriptor, 0)) != SHARP_F)
  447.       || (! (VECTOR_P (VECTOR_REF (wabbit_descriptor, 1))))
  448.       || ((OBJECT_ADDRESS (VECTOR_REF (wabbit_descriptor, 1))) < Constant_Top)
  449.       || (! (VECTOR_P (VECTOR_REF (wabbit_descriptor, 2))))
  450.       || ((OBJECT_ADDRESS (VECTOR_REF (wabbit_descriptor, 2))) < Constant_Top)
  451.       || ((VECTOR_LENGTH (VECTOR_REF (wabbit_descriptor, 2)))
  452.       < (2 + (2 * (VECTOR_LENGTH (VECTOR_REF (wabbit_descriptor, 1)))))))
  453.   {
  454.     hunting_wabbits_p = false;
  455.     transport_loop = GCLoop;
  456.   }
  457.   else
  458.   {
  459.     hunting_wabbits_p = true;
  460.     transport_loop = wabbit_hunting_gcloop;
  461.   }
  462.  
  463.   /* Save the microcode registers so that they can be relocated */
  464.  
  465.   Terminate_Old_Stacklet ();
  466.   SEAL_CONSTANT_SPACE ();
  467.   Check_Value = (CONSTANT_AREA_END ());
  468.   The_Precious_Objects = (Get_Fixed_Obj_Slot (Precious_Objects));
  469.   Set_Fixed_Obj_Slot (Precious_Objects, SHARP_F);
  470.   Set_Fixed_Obj_Slot (Lost_Objects_Base, SHARP_F);
  471.  
  472.   if (hunting_wabbits_p)
  473.     wabbit_season (wabbit_descriptor);
  474.  
  475.   Root = Free;
  476.   *Free++ = Fixed_Objects;
  477.   *Free++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History));
  478.   *Free++ = Get_Current_Stacklet ();
  479.   *Free++ =
  480.     ((Prev_Restore_History_Stacklet == NULL)
  481.      ? SHARP_F
  482.      : (MAKE_POINTER_OBJECT (TC_CONTROL_POINT,
  483.                  Prev_Restore_History_Stacklet)));
  484.   *Free++ = Current_State_Point;
  485.   *Free++ = Fluid_Bindings;
  486.  
  487. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  488.   if (gc_objects_referencing != SHARP_F)
  489.     {
  490.       MEMORY_SET
  491.     (gc_objects_referencing, 0,
  492.      (MAKE_OBJECT
  493.       (TC_MANIFEST_NM_VECTOR,
  494.        (OBJECT_DATUM (MEMORY_REF (gc_objects_referencing, 0))))));
  495.       {
  496.     SCHEME_OBJECT * scan = (VECTOR_LOC (gc_objects_referencing, 0));
  497.     SCHEME_OBJECT * end =
  498.       (VECTOR_LOC (gc_objects_referencing,
  499.                (VECTOR_LENGTH (gc_objects_referencing))));
  500.     while (scan < end)
  501.       (*scan++) = SHARP_F;
  502.       }
  503.       *Free++ = gc_objects_referencing;
  504.       gc_objects_referencing_count = 0;
  505.       gc_objects_referencing_scan =
  506.     (VECTOR_LOC (gc_objects_referencing, 1));
  507.       gc_objects_referencing_end =
  508.     (VECTOR_LOC (gc_objects_referencing,
  509.              (VECTOR_LENGTH (gc_objects_referencing))));
  510.     }
  511. #endif
  512.  
  513.   /* The 4 step GC */
  514.  
  515.   Result = ((* transport_loop) ((CONSTANT_AREA_START ()), &Free));
  516.   if (Result != Check_Value)
  517.   {
  518.     outf_fatal ("\nGC: Constant Scan ended too early.\n");
  519.     Microcode_Termination (TERM_BROKEN_HEART);
  520.   }
  521.  
  522.   Result = ((* transport_loop) (Root, &Free));
  523.   if (Free != Result)
  524.   {
  525.     outf_fatal ("\nGC-1: Heap Scan ended too early.\n");
  526.     Microcode_Termination (TERM_BROKEN_HEART);
  527.   }
  528.  
  529.   Root2 = Free;
  530.   *Free++ = The_Precious_Objects;
  531.   Result = ((* transport_loop) (Root2, &Free));
  532.   if (Free != Result)
  533.   {
  534.     outf_fatal ("\nGC-2: Heap Scan ended too early.\n");
  535.     Microcode_Termination (TERM_BROKEN_HEART);
  536.   }
  537.  
  538. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  539.   if (gc_objects_referencing != SHARP_F)
  540.     {
  541.       UPDATE_GC_OBJECTS_REFERENCING ();
  542.       MEMORY_SET
  543.     (gc_objects_referencing, 0,
  544.      (MAKE_OBJECT
  545.       (TC_MANIFEST_VECTOR,
  546.        (OBJECT_DATUM (MEMORY_REF (gc_objects_referencing, 0))))));
  547.       VECTOR_SET (gc_objects_referencing, 0,
  548.           (LONG_TO_UNSIGNED_FIXNUM (gc_objects_referencing_count)));
  549.       {
  550.     SCHEME_OBJECT * end = gc_objects_referencing_scan;
  551.     Result = (GCLoop ((VECTOR_LOC (gc_objects_referencing, 1)), (&end)));
  552.     if ((end != Result) || (end != gc_objects_referencing_scan))
  553.       {
  554.         outf_fatal ("\nGC-3: Heap Scan ended too early.\n");
  555.         Microcode_Termination (TERM_BROKEN_HEART);
  556.       }
  557.       }
  558.       gc_objects_referencing = SHARP_F;
  559.       gc_object_referenced = SHARP_F;
  560.     }
  561. #endif
  562.  
  563.   if (hunting_wabbits_p)
  564.     fix_weak_chain_and_hunt_wabbits ();
  565.   else
  566.     Fix_Weak_Chain ();
  567.  
  568.   /* Make the microcode registers point to the copies in new-space. */
  569.  
  570.   Fixed_Objects = *Root++;
  571.   Set_Fixed_Obj_Slot (Precious_Objects, *Root2);
  572.   Set_Fixed_Obj_Slot
  573.     (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2))));
  574.  
  575.   History = (OBJECT_ADDRESS (*Root++));
  576.  
  577.   Set_Current_Stacklet (*Root);
  578.   Root += 1;
  579.   if (*Root == SHARP_F)
  580.   {
  581.     Prev_Restore_History_Stacklet = NULL;
  582.     Root += 1;
  583.   }
  584.   else
  585.     Prev_Restore_History_Stacklet = (OBJECT_ADDRESS (*Root++));
  586.   Current_State_Point = *Root++;
  587.   Fluid_Bindings = *Root++;
  588.   Free_Stacklets = NULL;
  589.  
  590.   if (hunting_wabbits_p)
  591.   {
  592.     wabbit_descriptor = (Get_Fixed_Obj_Slot (GC_WABBIT_DESCRIPTOR));
  593.     duck_season (wabbit_descriptor);
  594.   }
  595.  
  596.   COMPILER_TRANSPORT_END ();
  597.  
  598. #ifdef __WIN32__
  599.   {
  600.     extern void win32_advise_end_GC ();
  601.     win32_advise_end_GC ();
  602.   }
  603. #endif
  604.  
  605.   CLEAR_INTERRUPT (INT_GC);
  606.   return;
  607. }
  608.  
  609. /* (GARBAGE-COLLECT SLACK)
  610.    Requests a garbage collection leaving the specified amount of slack
  611.    for the top of heap check on the next GC.  The primitive ends by invoking
  612.    the GC daemon if there is one.
  613.  
  614.    This primitive never returns normally.  It always escapes into
  615.    the interpreter because some of its cached registers (eg. History)
  616.    have changed.
  617. */
  618.  
  619. DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0)
  620. {
  621.   extern unsigned long gc_counter;
  622.   SCHEME_OBJECT daemon;
  623.   PRIMITIVE_HEADER (1);
  624.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  625.  
  626.   STACK_SANITY_CHECK ("GC");
  627.   if (Free > Heap_Top)
  628.   {
  629.     outf_fatal ("\nGARBAGE-COLLECT: GC has been delayed too long!\n");
  630.     outf_fatal ("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
  631.             Free, MemTop, Heap_Top);
  632.     Microcode_Termination (TERM_NO_SPACE);
  633.   }
  634.  
  635.   GC_Reserve = (arg_nonnegative_integer (1));
  636.   POP_PRIMITIVE_FRAME (1);
  637.  
  638.   ENTER_CRITICAL_SECTION ("garbage collector");
  639.   run_pre_gc_hooks ();
  640.   gc_counter += 1;
  641.   GCFlip ();
  642.   GC ();
  643.   run_post_gc_hooks ();
  644.   daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
  645.  
  646.  Will_Push (CONTINUATION_SIZE);
  647.   Store_Return (RC_NORMAL_GC_DONE);
  648.   Store_Expression (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
  649.   Save_Cont ();
  650.  Pushed ();
  651.  
  652.   RENAME_CRITICAL_SECTION ("garbage collector daemon");
  653.   if (daemon == SHARP_F)
  654.     PRIMITIVE_ABORT (PRIM_POP_RETURN);
  655.     /*NOTREACHED*/
  656.  
  657.  Will_Push (2);
  658.   STACK_PUSH (daemon);
  659.   STACK_PUSH (STACK_FRAME_HEADER);
  660.  Pushed ();
  661.   PRIMITIVE_ABORT (PRIM_APPLY);
  662.   /*NOTREACHED*/
  663.   PRIMITIVE_RETURN (UNSPECIFIC);
  664. }
  665.  
  666. DEFINE_PRIMITIVE ("GC-TRACE-REFERENCES", Prim_gc_trace_references, 2, 2, 0)
  667. {
  668.   PRIMITIVE_HEADER (2);
  669.   {
  670.     SCHEME_OBJECT objects_referencing = (ARG_REF (2));
  671.     if (! ((objects_referencing == SHARP_F)
  672.        || ((VECTOR_P (objects_referencing))
  673.            && ((VECTOR_LENGTH (objects_referencing)) >= 1))))
  674.       error_wrong_type_arg (2);
  675. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  676.     gc_object_referenced = (ARG_REF (1));
  677.     gc_objects_referencing = objects_referencing;
  678. #else /* not ENABLE_GC_DEBUGGING_TOOLS */
  679.     error_external_return ();
  680. #endif /* not ENABLE_GC_DEBUGGING_TOOLS */
  681.   }
  682.   PRIMITIVE_RETURN (UNSPECIFIC);
  683. }
  684.  
  685. void
  686. DEFUN (check_transport_vector_lossage, (Scan, Saved_Scan, To),
  687.        SCHEME_OBJECT * Scan
  688.        AND SCHEME_OBJECT * Saved_Scan
  689.        AND SCHEME_OBJECT * To)
  690. {
  691.   outf_fatal ("\nBad transport_vector limit:\n");
  692.   outf_fatal ("  limit = 0x%lx\n", ((long) Scan));
  693.   outf_fatal ("  Scan = 0x%lx\n", ((long) Saved_Scan));
  694.   outf_fatal ("  To = 0x%lx\n", ((long) To));
  695.   outf_flush_fatal ();
  696.   abort ();
  697. }
  698.