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 / purify.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  15KB  |  537 lines
  1. /* -*-C-*-
  2.  
  3. $Id: purify.c,v 9.59 2000/12/05 21:23:48 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 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 file contains the code that copies objects into pure
  23.    and constant space. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "gccode.h"
  28. #include "zones.h"
  29.  
  30. /* Imports */
  31.  
  32. extern void EXFUN (GC, (void));
  33. extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
  34.  
  35. /* This is a copy of GCLoop, with mode handling added, and
  36.    debugging printout removed.
  37. */
  38.  
  39. /* Purify modes */
  40.  
  41. #define    NORMAL_GC    0
  42. #define PURE_COPY    1
  43. #define CONSTANT_COPY    2
  44.  
  45. #define Purify_Pointer(Code)                        \
  46. {                                    \
  47.   Old = (OBJECT_ADDRESS (Temp));                    \
  48.   if ((GC_Mode == CONSTANT_COPY)                    \
  49.       && (Old < low_heap))                        \
  50.     continue;                                \
  51.   Code;                                    \
  52. }
  53.  
  54. #define PURIFY_RAW_POINTER(Code)                    \
  55. {                                    \
  56.   Old = (SCHEME_ADDR_TO_ADDR (Temp));                    \
  57.   if ((GC_Mode == CONSTANT_COPY)                    \
  58.       && (Old < low_heap))                        \
  59.     continue;                                \
  60.   Code;                                    \
  61. }
  62.  
  63. #define Setup_Pointer_for_Purify(Extra_Code)                \
  64. {                                    \
  65.   Purify_Pointer (Setup_Pointer (false, Extra_Code));            \
  66. }
  67.  
  68. #define Indirect_BH(In_GC)                        \
  69. {                                    \
  70.   if ((OBJECT_TYPE (* Old)) == TC_BROKEN_HEART)                \
  71.     continue;                                \
  72. }
  73.  
  74. #define Transport_Vector_Indirect()                    \
  75. {                                    \
  76.   Real_Transport_Vector ();                        \
  77.   *(OBJECT_ADDRESS (Temp)) = New_Address;                \
  78. }
  79.  
  80. SCHEME_OBJECT *
  81. DEFUN (purifyloop, (Scan, To_Pointer, GC_Mode),
  82.        fast SCHEME_OBJECT *Scan AND
  83.        SCHEME_OBJECT **To_Pointer AND
  84.        int GC_Mode)
  85. {
  86.   fast SCHEME_OBJECT
  87.     * To, * Old, Temp,
  88.     * low_heap, New_Address;
  89. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  90.   SCHEME_OBJECT object_referencing;
  91. #endif
  92.  
  93.   To = * To_Pointer;
  94.   low_heap = Constant_Top;
  95.   for ( ; Scan != To; Scan++)
  96.   {
  97.     Temp = * Scan;
  98. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  99.     object_referencing = Temp;
  100. #endif
  101.     Switch_by_GC_Type(Temp)
  102.     {
  103.       case TC_BROKEN_HEART:
  104.         if (Scan == (OBJECT_ADDRESS (Temp)))
  105.     {
  106.       *To_Pointer = To;
  107.       return Scan;
  108.     }
  109.     sprintf(gc_death_message_buffer,
  110.         "purifyloop: broken heart (0x%lx) in scan",
  111.         Temp);
  112.     gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
  113.     /*NOTREACHED*/
  114.  
  115.       case TC_MANIFEST_NM_VECTOR:
  116.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  117.     Scan += OBJECT_DATUM (Temp);
  118.     break;
  119.  
  120.       /* Compiled code relocation. */
  121.  
  122.       case TC_LINKAGE_SECTION:
  123.       {
  124.     if (GC_Mode == PURE_COPY)
  125.     {
  126.       gc_death (TERM_COMPILER_DEATH,
  127.             "purifyloop: linkage section in pure area",
  128.             Scan, To);
  129.       /*NOTREACHED*/
  130.     }
  131.  
  132.     switch (READ_LINKAGE_KIND (Temp))
  133.     {
  134.       case REFERENCE_LINKAGE_KIND:
  135.       case ASSIGNMENT_LINKAGE_KIND:
  136.       {
  137.         /* Assumes that all others are objects of type TC_QUAD without
  138.            their type codes.
  139.          */
  140.  
  141.         fast long count;
  142.  
  143.         Scan++;
  144.         for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
  145.          --count >= 0;
  146.          Scan += 1)
  147.         {
  148.           Temp = (* Scan);
  149.           PURIFY_RAW_POINTER (Setup_Internal (false,
  150.                           TRANSPORT_RAW_QUADRUPLE (),
  151.                           RAW_BH (false, continue)));
  152.         }
  153.         Scan -= 1;
  154.         break;
  155.       }
  156.  
  157.       case OPERATOR_LINKAGE_KIND:
  158.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  159.       {
  160.         fast long count;
  161.         fast char * word_ptr;
  162.         SCHEME_OBJECT * end_scan;
  163.  
  164.         START_OPERATOR_RELOCATION (Scan);
  165.         count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
  166.         word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
  167.         end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
  168.  
  169.         while(--count >= 0)
  170.         {
  171.           Scan = ((SCHEME_OBJECT *) word_ptr);
  172.           word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  173.           EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
  174.           PURIFY_RAW_POINTER (Setup_Aligned
  175.                   (false,
  176.                    TRANSPORT_RAW_COMPILED (),
  177.                    RAW_COMPILED_BH (false,
  178.                             goto next_operator)));
  179.         next_operator:
  180.           STORE_OPERATOR_LINKAGE_ADDRESS(Temp, Scan);
  181.         }
  182.         Scan = end_scan;
  183.         END_OPERATOR_RELOCATION (Scan);
  184.         break;
  185.       }
  186.  
  187.       case CLOSURE_PATTERN_LINKAGE_KIND:
  188.         Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
  189.         break;
  190.  
  191.       default:
  192.       {
  193.         gc_death (TERM_EXIT,
  194.               "purifyloop: Unknown compiler linkage kind.",
  195.               Scan, Free);
  196.         /*NOTREACHED*/
  197.       }
  198.     }
  199.     break;
  200.       }
  201.  
  202.       case TC_MANIFEST_CLOSURE:
  203.       {
  204.     fast long count;
  205.     fast char * word_ptr;
  206.     SCHEME_OBJECT * area_end;
  207.  
  208.     if (GC_Mode == PURE_COPY)
  209.     {
  210.       gc_death (TERM_COMPILER_DEATH,
  211.             "purifyloop: manifest closure in pure area",
  212.             Scan, To);
  213.       /*NOTREACHED*/
  214.     }
  215.  
  216.     START_CLOSURE_RELOCATION (Scan);
  217.     Scan += 1;
  218.     count = (MANIFEST_CLOSURE_COUNT (Scan));
  219.     word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
  220.     area_end = (MANIFEST_CLOSURE_END (Scan, count));
  221.  
  222.     while ((--count) >= 0)
  223.     {
  224.       Scan = ((SCHEME_OBJECT *) (word_ptr));
  225.       word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  226.       EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
  227.       PURIFY_RAW_POINTER (Setup_Aligned
  228.                   (false,
  229.                    TRANSPORT_RAW_COMPILED (),
  230.                    RAW_COMPILED_BH (false,
  231.                         goto next_closure)));
  232.     next_closure:
  233.       STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
  234.     }
  235.     Scan = area_end;
  236.     END_CLOSURE_RELOCATION (Scan);
  237.     break;
  238.       }
  239.  
  240.       case_compiled_entry_point:
  241.     if (GC_Mode != PURE_COPY)
  242.     {
  243.       Purify_Pointer (Setup_Aligned (false,
  244.                      Transport_Compiled (),
  245.                      Compiled_BH (false,
  246.                               goto after_entry)));
  247.         after_entry:
  248.       *Scan = Temp;
  249.     }
  250.     break;
  251.  
  252.       case_Cell:
  253.     Setup_Pointer_for_Purify (Transport_Cell ());
  254.     break;
  255.  
  256.       case TC_WEAK_CONS:
  257.     Setup_Pointer_for_Purify (Transport_Weak_Cons ());
  258.     break;
  259.  
  260.       /*
  261.     Symbols, variables, and reference traps cannot be put into
  262.     pure space.  The strings contained in the first two can, on the
  263.     other hand.
  264.        */
  265.  
  266.       case TC_REFERENCE_TRAP:
  267.     if (((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  268.         || (GC_Mode == PURE_COPY))
  269.     {
  270.       /* It is a non pointer. */
  271.       break;
  272.     }
  273.     goto purify_pair;
  274.  
  275.       case TC_INTERNED_SYMBOL:
  276.       case TC_UNINTERNED_SYMBOL:
  277.     if (GC_Mode == PURE_COPY)
  278.         {
  279.       Temp = MEMORY_REF (Temp, SYMBOL_NAME);
  280.       Purify_Pointer (Setup_Internal (false,
  281.                       Transport_Vector_Indirect (),
  282.                       Indirect_BH (false)));
  283.       break;
  284.     }
  285.  
  286.     /* Fall through */
  287.  
  288.       case_Fasdump_Pair:
  289.       purify_pair:
  290.     Setup_Pointer_for_Purify (Transport_Pair ());
  291.     break;
  292.  
  293.       case TC_VARIABLE:
  294.       case_Triple:
  295.     Setup_Pointer_for_Purify (Transport_Triple ());
  296.     break;
  297.  
  298.       case_Quadruple:
  299.     Setup_Pointer_for_Purify (Transport_Quadruple ());
  300.     break;
  301.  
  302.       case TC_COMPILED_CODE_BLOCK:
  303.     if (GC_Mode == PURE_COPY)
  304.       break;
  305.     /* fall through */
  306.     
  307.       case TC_BIG_FLONUM:
  308.     Purify_Pointer (Setup_Aligned (false,
  309.                        goto Move_Vector,
  310.                        Normal_BH (false, continue)));
  311.     break;
  312.  
  313.     /* No need to handle futures specially here, since purifyloop
  314.        is always invoked after running GCLoop, which will have
  315.        spliced all spliceable futures unless the GC itself of the
  316.        GC dameons spliced them, but this should not occur.
  317.      */
  318.  
  319.       case TC_FUTURE:
  320.       case TC_ENVIRONMENT:
  321.     if (GC_Mode == PURE_COPY)
  322.     {
  323.       /* For environments, this should actually do an indirect pair
  324.          transport of the procedure, at least.
  325.        */
  326.       break;
  327.     }
  328.     /* Fall through */
  329.  
  330.       case_Purify_Vector:
  331.     Setup_Pointer_for_Purify (Transport_Vector ());
  332.     break;
  333.  
  334.       default:
  335.     GC_BAD_TYPE ("purifyloop", Temp);
  336.     /* Fall Through */
  337.  
  338.       case_Non_Pointer:
  339.     break;
  340.  
  341.       } /* Switch_by_GC_Type */
  342.   } /* For loop */
  343.  
  344.   *To_Pointer = To;
  345.   return (To);
  346.  
  347. } /* purifyloop */
  348.  
  349. /* Description of the algorithm for PURIFY:
  350.  
  351.    Purify increases the size of constant space at the expense of both
  352.    heaps.  A GC-like relocation is performed with the object being
  353.    purified as the root.  The object is copied and relocated from the
  354.    high heap to the area adjacent to constant space.  Then the GC is
  355.    finished after changing the end of constant-space marker.
  356.  
  357.    In order to make a pure object, the copy process proceeds in two
  358.    halves.  During the first half (which collects the pure part)
  359.    Compiled Code, Environments, Symbols, and Variables (i.e.  things
  360.    whose contents change) are NOT copied.  Then a header is put down
  361.    indicating constant (not pure) area, and then they ARE copied.
  362.  
  363.    The constant area contains a contiguous set of blocks of the
  364.    following format:
  365.  
  366.   >>Heap above here<<
  367.  
  368.                    . (direction of growth)
  369.                    .  ^
  370.                    . / \
  371.                    .  |
  372.                    .  |
  373.         |----------------------|...
  374.         | END   | Total Size M |   . Where END   = TC_FIXNUM
  375.         |----------------------|    .      SNMH  = TC_MANIFEST_SPECIAL_...
  376.         | SNMH  |      1       |    |      CONST = TC_CONSTANT
  377.         |----------------------|    |      PURE  = TC_NULL
  378.         |                      |    |
  379.         |                      |    |
  380.         |    CONSTANT AREA     |    |
  381.         |                      |    |
  382.         |                      |     .
  383.      ...|----------------------|      >  M
  384.     .   | CONST | Pure Size N  |     .
  385.    .    |----------------------|    |
  386.    |    | SNMH  |      1       |    |
  387.    |    |----------------------|    |
  388.    |    |                      |    |
  389. N <     |                      |    |
  390.    |    |      PURE AREA       |    |
  391.    |    |                      |    |
  392.    .    |                      |    .
  393.     .   |----------------------|   .
  394.      ...| PURE  | Total Size M |...
  395.         |----------------------|
  396.         | SNMH  | Pure Size N  |
  397.         |----------------------|
  398.  
  399.   >>Top of Stack (Stack below here)<<
  400.  
  401. */
  402.  
  403. static void
  404. DEFUN (purify, (object, purify_mode),
  405.        SCHEME_OBJECT object AND Boolean purify_mode)
  406. {
  407.   long length, pure_length;
  408.   SCHEME_OBJECT * new_object, * result;
  409.   extern Boolean EXFUN (update_allocator_parameters, (SCHEME_OBJECT *));
  410.  
  411.   run_pre_gc_hooks ();
  412.   STACK_SANITY_CHECK ("PURIFY");
  413.   Weak_Chain = EMPTY_WEAK_CHAIN;
  414.   Constant_Top = Free_Constant; 
  415.   new_object = Free_Constant;
  416.   *Free_Constant++ = SHARP_F;    /* Will hold pure space header */
  417.   *Free_Constant++ = object;
  418.   if (! (purify_mode))
  419.     pure_length = 3;
  420.   else
  421.   {
  422.     result = (purifyloop ((new_object + 1), &Free_Constant, PURE_COPY));
  423.  
  424.     if (result != Free_Constant)
  425.     {
  426. purification_failure:
  427.       outf_fatal ("\nPurify: Pure Copy ended too early.\n");
  428.       Microcode_Termination (TERM_BROKEN_HEART);
  429.     }
  430.     pure_length = ((Free_Constant - new_object) + 1);
  431.   }
  432.   *Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  433.   *Free_Constant++ = (MAKE_OBJECT (CONSTANT_PART, pure_length));
  434.   Constant_Top = Free_Constant;
  435.   if (purify_mode)
  436.   {
  437.     result = (purifyloop ((new_object + 1), &Free_Constant, CONSTANT_COPY));
  438.     if (result != Free_Constant)
  439.     {
  440.       outf_fatal ("\nPurify: Pure Copy ended too early.\n");
  441.       Microcode_Termination (TERM_BROKEN_HEART);
  442.     }
  443.   }
  444.   else
  445.   {
  446.     result = (GCLoop ((new_object + 1), &Free_Constant));
  447.     if (result != Free_Constant)
  448.       goto purification_failure;
  449.   }
  450.  
  451.   length = ((Free_Constant - new_object) - 4);
  452.   *Free_Constant++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  453.   *Free_Constant++ = (MAKE_OBJECT (END_OF_BLOCK, (length + 5)));
  454.   *new_object++ =
  455.     (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, pure_length));
  456.   *new_object = (MAKE_OBJECT (PURE_PART, (length + 5)));
  457.   if (! (update_allocator_parameters (Free_Constant)))
  458.     gc_death (TERM_NO_SPACE, "purify: object too large", NULL, NULL);
  459.     /*NOTREACHED*/
  460.  
  461.   SET_CONSTANT_TOP ();
  462.   ALIGN_FLOAT (Free);
  463.   SET_MEMTOP (Heap_Top - GC_Reserve);
  464.   GC ();
  465.   run_post_gc_hooks ();
  466. }
  467.  
  468. /* (PRIMITIVE-PURIFY OBJECT PURE? SAFETY-MARGIN)
  469.    Copy an object from the heap into constant space.  This requires
  470.    a spare heap, and is tricky to use -- it should only be used
  471.    through the wrapper provided in the Scheme runtime system.
  472.  
  473.    To purify an object we just copy it into Pure Space in two
  474.    parts with the appropriate headers and footers.  The actual
  475.    copying is done by purifyloop above.
  476.  
  477.    Once the copy is complete we run a full GC which handles the
  478.    broken hearts which now point into pure space.  On a
  479.    multiprocessor, this primitive uses the master-gc-loop and it
  480.    should only be used as one would use master-gc-loop i.e. with
  481.    everyone else halted.
  482.  
  483.    This primitive always "returns" by escaping to the interpreter
  484.    because some of its cached registers (eg. History) have changed.
  485. */
  486.  
  487. DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0)
  488. {
  489.   Boolean purify_mode;
  490.   SCHEME_OBJECT object, result, daemon;
  491.   PRIMITIVE_HEADER (3);
  492.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  493.  
  494.   STACK_SANITY_CHECK ("PURIFY");
  495.   Save_Time_Zone (Zone_Purify);
  496.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  497.   CHECK_ARG (2, BOOLEAN_P);
  498.   purify_mode = (BOOLEAN_ARG (2));
  499.   GC_Reserve = (arg_nonnegative_integer (3));
  500.  
  501.   /* Purify only works from the high heap.
  502.      If in the low heap, tell the runtime system.
  503.    */
  504.  
  505.   if (Heap_Bottom < Unused_Heap_Bottom)
  506.     PRIMITIVE_RETURN (SHARP_F);
  507.  
  508.   POP_PRIMITIVE_FRAME (3);
  509.  
  510.   ENTER_CRITICAL_SECTION ("purify");
  511.   purify (object, purify_mode);
  512.   result = (MAKE_POINTER_OBJECT (TC_LIST, Free));
  513.   Free += 2;
  514.   Free[-2] = SHARP_T;
  515.   Free[-1] = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));
  516.  
  517.  Will_Push (CONTINUATION_SIZE);
  518.   Store_Return (RC_NORMAL_GC_DONE);
  519.   Store_Expression (result);
  520.   Save_Cont ();
  521.  Pushed ();
  522.  
  523.   RENAME_CRITICAL_SECTION ("purify daemon");
  524.   daemon = (Get_Fixed_Obj_Slot (GC_Daemon));
  525.   if (daemon == SHARP_F)
  526.     PRIMITIVE_ABORT (PRIM_POP_RETURN);
  527.     /*NOTREACHED*/
  528.  
  529.  Will_Push (2);
  530.   STACK_PUSH (daemon);
  531.   STACK_PUSH (STACK_FRAME_HEADER);
  532.  Pushed ();
  533.   PRIMITIVE_ABORT (PRIM_APPLY);
  534.   /*NOTREACHED*/
  535.   return (0);
  536. }
  537.