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 / bchpur.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  9KB  |  297 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bchpur.c,v 9.70 2000/12/05 21:34:56 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. /*
  23.  * This file contains the code for primitives dealing with pure
  24.  * and constant space.  Garbage collection to disk version.
  25.  *
  26.  * Poorly implemented:  If there is not enough space, instead of
  27.  * undoing the changes, it crashes.
  28.  * It should be changed to do the job in two passes like the
  29.  * "normal" version.
  30.  */
  31.  
  32. #include "scheme.h"
  33. #include "prims.h"
  34. #include "bchgcc.h"
  35. #include "zones.h"
  36.  
  37. static void EXFUN (purify, (SCHEME_OBJECT, Boolean));
  38. static SCHEME_OBJECT * EXFUN (purify_header_overflow, (SCHEME_OBJECT *));
  39.  
  40. /* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN)
  41.  
  42.    Copy an object from the heap into constant space.  It should only
  43.    be used through the wrapper provided in the Scheme runtime system.
  44.  
  45.    To purify an object we just copy it into Pure Space in two
  46.    parts with the appropriate headers and footers.  The actual
  47.    copying is done by gc_loop.
  48.  
  49.    Once the copy is complete we run a full GC which handles the
  50.    broken hearts which now point into pure space.
  51.  
  52.    This primitive does not return normally.  It always escapes into
  53.    the interpreter because some of its cached registers (eg. History)
  54.    have changed.  */
  55.  
  56. DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
  57. {
  58.   Boolean pure_p;
  59.   SCHEME_OBJECT object, result, daemon;
  60.   PRIMITIVE_HEADER (3);
  61.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  62.  
  63.   STACK_SANITY_CHECK ("PURIFY");
  64.   Save_Time_Zone (Zone_Purify);
  65.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  66.   CHECK_ARG (2, BOOLEAN_P);
  67.   pure_p = (BOOLEAN_ARG (2));
  68.   GC_Reserve = (arg_nonnegative_integer (3));
  69.  
  70.   POP_PRIMITIVE_FRAME (3);
  71.  
  72.   ENTER_CRITICAL_SECTION ("purify");
  73.   purify (object, pure_p);
  74.   result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  75.   Free += 2;
  76.   Free[-2] = SHARP_T;
  77.   Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
  78.  
  79.  Will_Push (CONTINUATION_SIZE);
  80.   Store_Return (RC_NORMAL_GC_DONE);
  81.   Store_Expression (result);
  82.   Save_Cont ();
  83.  Pushed ();
  84.  
  85.   RENAME_CRITICAL_SECTION ("purify daemon");
  86.   daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
  87.   if (daemon == SHARP_F)
  88.     {
  89.       PRIMITIVE_ABORT (PRIM_POP_RETURN);
  90.       /*NOTREACHED*/
  91.     }
  92.  
  93.  Will_Push (2);
  94.   STACK_PUSH (daemon);
  95.   STACK_PUSH (STACK_FRAME_HEADER);
  96.  Pushed ();
  97.   PRIMITIVE_ABORT (PRIM_APPLY);
  98.   /*NOTREACHED*/
  99.   return (UNSPECIFIC);
  100. }
  101.  
  102. static void
  103. DEFUN (purify, (object, pure_p), SCHEME_OBJECT object AND Boolean pure_p)
  104. {
  105.   long length;
  106.   long pure_length;
  107.   long delta;
  108.   SCHEME_OBJECT * free_buffer_ptr;
  109.   SCHEME_OBJECT * old_free_const;
  110.   SCHEME_OBJECT * block_start;
  111.   SCHEME_OBJECT * new_free_const;
  112.   SCHEME_OBJECT * pending_scan;
  113.   SCHEME_OBJECT * root;
  114.   SCHEME_OBJECT * root2;
  115.   SCHEME_OBJECT the_precious_objects;
  116.  
  117.   run_pre_gc_hooks ();
  118.   STACK_SANITY_CHECK ("PURIFY");
  119.   initialize_weak_pair_transport (Stack_Bottom);
  120.   free_buffer_ptr = (initialize_free_buffer ());
  121.   Terminate_Old_Stacklet ();
  122.   SEAL_CONSTANT_SPACE ();
  123.   the_precious_objects = (Get_Fixed_Obj_Slot (Precious_Objects));
  124.  
  125.   Constant_Top = Free_Constant;
  126.   old_free_const = Free_Constant;
  127.   new_free_const = old_free_const;
  128.   block_start = ((SCHEME_OBJECT *) (ALIGN_DOWN_TO_IO_PAGE (old_free_const)));
  129.   delta = (old_free_const - block_start);
  130.  
  131.   free_buffer_ptr += delta;
  132.   (*free_buffer_ptr++) = SHARP_F;    /* Pure block header. */
  133.   (*free_buffer_ptr++) = object;
  134.   new_free_const += 2;
  135.   if (free_buffer_ptr >= free_buffer_top)
  136.     free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
  137.  
  138.   if (pure_p)
  139.     {
  140.       gc_loop (((initialize_scan_buffer (block_start)) + delta),
  141.            (&free_buffer_ptr), (&new_free_const), Constant_Top,
  142.            PURE_COPY, 1);
  143.       pure_length = ((new_free_const - old_free_const) + 1);
  144.     }
  145.   else
  146.     pure_length = 3;
  147.  
  148.   (*free_buffer_ptr++)
  149.     = (pure_p
  150.        ? (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, new_free_const))
  151.        : (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1)));
  152.   (*free_buffer_ptr++) = (MAKE_OBJECT (CONSTANT_PART, pure_length));
  153.   new_free_const += 2;
  154.   if (free_buffer_ptr >= free_buffer_top)
  155.     free_buffer_ptr = (purify_header_overflow (free_buffer_ptr));
  156.  
  157.   {
  158.     SCHEME_OBJECT * scan_start
  159.       = ((initialize_scan_buffer (block_start)) + delta);
  160.     if (pure_p)
  161.       {
  162.     SCHEME_OBJECT * pure_area_limit = (new_free_const - 2);
  163.     SCHEME_OBJECT * result
  164.       = (gc_loop (scan_start, (&free_buffer_ptr), (&new_free_const),
  165.               Constant_Top, CONSTANT_COPY, 0));
  166.     if ((*result)
  167.         != (MAKE_POINTER_OBJECT (TC_BROKEN_HEART, pure_area_limit)))
  168.       {
  169.         gc_death (TERM_BROKEN_HEART, "gc_loop ended too early",
  170.               result, free_buffer_ptr);
  171.         /*NOTREACHED*/
  172.       }
  173.     (*result) = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  174.     scan_start = (result + 2);
  175.       }
  176.     pending_scan
  177.       = (gc_loop (scan_start, (&free_buffer_ptr), (&new_free_const),
  178.           Constant_Top, NORMAL_GC, 1));
  179.   }
  180.  
  181.   length = (new_free_const + 1 - old_free_const);
  182.   (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  183.   (*free_buffer_ptr++) = (MAKE_OBJECT (END_OF_BLOCK, length));
  184.   new_free_const += 2;
  185.   if (free_buffer_ptr >= free_buffer_top)
  186.     free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
  187.  
  188.   Free_Constant = new_free_const;
  189.   if (!update_allocator_parameters (Free_Constant))
  190.     {
  191.       gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL);
  192.       /*NOTREACHED*/
  193.     }
  194.   while (!FLOATING_ALIGNED_P (Free_Constant))
  195.     {
  196.       (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
  197.       Free_Constant += 1;
  198.     }
  199.   if (Constant_Top > Free_Constant)
  200.     {
  201.       /* This assumes that the distance between the new constant space
  202.      and the new free constant is smaller than a bufferful.  */
  203.       long bump = (Constant_Top - Free_Constant);
  204.       (*free_buffer_ptr)
  205.     = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, (bump - 1)));
  206.       free_buffer_ptr += bump;
  207.       if (free_buffer_ptr >= free_buffer_top)
  208.     free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
  209.     }
  210.   while (!FLOATING_ALIGNED_P (Free))
  211.     {
  212.       (*free_buffer_ptr++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0));
  213.       Free += 1;
  214.     }
  215.  
  216.   root = Free;
  217.   Free += (GC_relocate_root (&free_buffer_ptr));
  218.  
  219.   {
  220.     struct saved_scan_state scan_state;
  221.     save_scan_state ((&scan_state), pending_scan);
  222.     set_fixed_scan_area (0, Highest_Allocated_Address);
  223.     {
  224.       SCHEME_OBJECT * result
  225.     = (gc_loop ((CONSTANT_AREA_START ()), (&free_buffer_ptr), (&Free),
  226.             old_free_const, NORMAL_GC, 0));
  227.       if (result != old_free_const)
  228.     {
  229.       gc_death (TERM_EXIT, "gc_loop ended too early",
  230.             result, free_buffer_ptr);
  231.       /*NOTREACHED*/
  232.     }
  233.     }
  234.     pending_scan = (restore_scan_state (&scan_state));
  235.   }
  236.  
  237.   pending_scan
  238.     = (gc_loop (pending_scan, (&free_buffer_ptr), (&Free),
  239.         old_free_const, NORMAL_GC, 1));
  240.  
  241.   root2 = Free;
  242.   (*free_buffer_ptr++) = the_precious_objects;
  243.   Free += 1;
  244.   if (free_buffer_ptr >= free_buffer_top)
  245.     free_buffer_ptr = (dump_and_reset_free_buffer (free_buffer_ptr, 0));
  246.  
  247.   gc_loop (pending_scan, (&free_buffer_ptr), (&Free),
  248.        old_free_const, NORMAL_GC, 1);
  249.  
  250.   end_transport (0);
  251.   fix_weak_chain_1 (old_free_const);
  252.  
  253.   /* Load new space into memory carefully to prevent the shared
  254.      buffer from losing any values.  */
  255.   {
  256.     unsigned long counter;
  257.  
  258.     for (counter = 0; (counter < delta); counter += 1)
  259.       (scan_buffer_bottom[counter]) = (block_start[counter]);
  260.  
  261.     final_reload (block_start, (Free - block_start), "new space");
  262.  
  263.     for (counter = 0; (counter < delta); counter += 1)
  264.       (block_start[counter]) = (scan_buffer_bottom[counter]);
  265.   }
  266.  
  267.   fix_weak_chain_2 ();
  268.   GC_end_root_relocation (root, root2);
  269.  
  270.   (*old_free_const++)
  271.     = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length));
  272.   (*old_free_const) = (MAKE_OBJECT (PURE_PART, length));
  273.   SEAL_CONSTANT_SPACE ();
  274.   run_post_gc_hooks ();
  275. }
  276.  
  277. /* This is not paranoia!
  278.    The two words in the header may overflow the free buffer.  */
  279. static SCHEME_OBJECT *
  280. DEFUN (purify_header_overflow, (free_buffer), SCHEME_OBJECT * free_buffer)
  281. {
  282.   long delta = (free_buffer - free_buffer_top);
  283.   free_buffer = (dump_and_reset_free_buffer (free_buffer, 0));
  284.   {
  285.     SCHEME_OBJECT * scan_buffer
  286.       = (dump_and_reload_scan_buffer (scan_buffer_top, 0));
  287.     if ((scan_buffer + delta) != free_buffer)
  288.       {
  289.     gc_death (TERM_EXIT,
  290.           "purify: scan and free do not meet at the end",
  291.           (scan_buffer + delta), free_buffer);
  292.     /*NOTREACHED*/
  293.       }
  294.   }
  295.   return (free_buffer);
  296. }
  297.