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 / purutl.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  12KB  |  457 lines

  1. /* -*-C-*-
  2.  
  3. $Id: purutl.c,v 9.51 2000/12/05 21:23:48 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. /* Pure/Constant space utilities. */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "gccode.h"
  27. #include "zones.h"
  28. #include "cmpint.h"
  29.  
  30. #ifdef STDC_HEADERS
  31. #  include <stdlib.h>
  32. #endif
  33.  
  34. static void
  35. DEFUN (update, (From, To, Was, Will_Be),
  36.        fast SCHEME_OBJECT * From
  37.        AND fast SCHEME_OBJECT * To
  38.        AND fast SCHEME_OBJECT * Was
  39.        AND fast SCHEME_OBJECT * Will_Be)
  40. {
  41.   fast long count;
  42.  
  43.   for (; From < To; From++)
  44.   {
  45.     if (GC_Type_Special (* From))
  46.     {
  47.       switch (OBJECT_TYPE (* From))
  48.       {
  49.     case TC_MANIFEST_NM_VECTOR:
  50.       From += (OBJECT_DATUM (* From));
  51.       break;
  52.  
  53.       /* The following two type codes assume that none of the protected
  54.          objects can be updated.
  55.          This may be seriously wrong!
  56.        */
  57.     case TC_LINKAGE_SECTION:
  58.       switch (READ_LINKAGE_KIND (* From))
  59.       {
  60.         case ASSIGNMENT_LINKAGE_KIND:
  61.         case CLOSURE_PATTERN_LINKAGE_KIND:
  62.         case REFERENCE_LINKAGE_KIND:
  63.         {
  64.           From += (READ_CACHE_LINKAGE_COUNT (* From));
  65.           break;
  66.         }
  67.  
  68.         case GLOBAL_OPERATOR_LINKAGE_KIND:
  69.         case OPERATOR_LINKAGE_KIND:
  70.         {
  71.           count = (READ_OPERATOR_LINKAGE_COUNT (* From));
  72.           From = (END_OPERATOR_LINKAGE_AREA (From, count));
  73.           break;
  74.         }
  75.  
  76.         default:
  77. #ifdef BAD_TYPES_LETHAL
  78.         {
  79.           gc_death (TERM_EXIT,
  80.             "Impurify: Unknown compiler linkage kind.",
  81.             From, NULL);
  82.           /*NOTREACHED*/
  83.         }
  84. #else /* not BAD_TYPES_LETHAL */
  85.         outf_error ("\nImpurify: Bad linkage section (0x%lx).\n",
  86.             (* From));
  87. #endif /* BAD_TYPES_LETHAL */
  88.       }
  89.       break;
  90.  
  91.     case TC_MANIFEST_CLOSURE:
  92.     {
  93.       fast long count;
  94.  
  95.       From += 1;
  96.       count = (MANIFEST_CLOSURE_COUNT (From));
  97.       From = (MANIFEST_CLOSURE_END (From, count));
  98.       break;
  99.     }
  100.  
  101.     default:
  102.       break;
  103.       }
  104.     }
  105.     else if ((! (GC_Type_Non_Pointer (* From)))
  106.          && ((OBJECT_ADDRESS (* From)) == Was))
  107.       * From = (MAKE_POINTER_OBJECT (OBJECT_TYPE (* From), Will_Be));
  108.   }
  109.   return;
  110. }
  111.  
  112. extern SCHEME_OBJECT * EXFUN (find_constant_space_block, (SCHEME_OBJECT *));
  113.  
  114. long
  115. DEFUN (make_impure, (Object, New_Object),
  116.        SCHEME_OBJECT Object AND SCHEME_OBJECT * New_Object)
  117. {
  118.   fast SCHEME_OBJECT * Obj_Address, * Constant_Address;
  119.   SCHEME_OBJECT * New_Address, * End_Of_Area;
  120.   long Length, Block_Length;
  121.   fast long i;
  122.  
  123.   /* Calculate size of object to be "impurified".
  124.      Note that this depends on the fact that Compiled Entries CANNOT
  125.      be pure.
  126.    */
  127.  
  128.   Switch_by_GC_Type (Object)
  129.   {
  130.     case TC_BROKEN_HEART:
  131.     case TC_MANIFEST_NM_VECTOR:
  132.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  133.     case_Non_Pointer:
  134. #if FALSE
  135.       outf_fatal ("\nImpurify Non-Pointer (0x%lx)\n", Object);
  136.       Microcode_Termination (TERM_NON_POINTER_RELOCATION);
  137.       /* fall through */
  138. #endif
  139.     case TC_BIG_FLONUM:
  140.       return (ERR_ARG_1_WRONG_TYPE);
  141.  
  142.     case TC_FUTURE:
  143.     case_Vector:
  144.       Length = ((VECTOR_LENGTH (Object)) + 1);
  145.       break;
  146.  
  147.     case_Quadruple:
  148.       Length = 4;
  149.       break;
  150.  
  151.     case TC_VARIABLE:
  152.     case_Triple:
  153.       Length = 3;
  154.       break;
  155.  
  156.     case TC_WEAK_CONS:
  157.     case_Pair:
  158.       Length = 2;
  159.       break;
  160.  
  161.     case_Cell:
  162.       Length = 1;
  163.       break;
  164.  
  165.     case TC_LINKAGE_SECTION:
  166.     case TC_MANIFEST_CLOSURE:
  167.     case_compiled_entry_point:
  168.     default:
  169. #ifdef BAD_TYPES_LETHAL
  170.       outf_fatal ("\nImpurify: Bad type code = 0x%02x.\n",
  171.               OBJECT_TYPE (Object));
  172.       Microcode_Termination (TERM_INVALID_TYPE_CODE);
  173.       /*NOTREACHED*/
  174. #else /* not BAD_TYPES_LETHAL */
  175.       outf_error ("\nImpurify: Bad type code = 0x%02x.\n",
  176.               OBJECT_TYPE (Object));
  177.       return (ERR_ARG_1_WRONG_TYPE);
  178. #endif /* BAD_TYPES_LETHAL */
  179.   }
  180.  
  181.   Constant_Address = Free_Constant;
  182.  
  183. #ifdef FLOATING_ALIGNMENT
  184.  
  185.   /* Undo ALIGN_FLOAT(Free_Constant) in SET_CONSTANT_TOP (). */
  186.  
  187.   while ((* (Constant_Address - 1))
  188.      == (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)))
  189.     Constant_Address -= 1;
  190.  
  191. #endif /* FLOATING_ALIGNMENT */
  192.  
  193.   Obj_Address = (OBJECT_ADDRESS (Object));
  194.  
  195.   if (! (TEST_CONSTANT_TOP (Constant_Address + Length)))
  196.   {
  197.     /* Make the whole block impure! */
  198.  
  199.     SCHEME_OBJECT * block = (find_constant_space_block (Obj_Address));
  200.  
  201.     if (block == ((SCHEME_OBJECT *) NULL))
  202.       return (ERR_IMPURIFY_OUT_OF_SPACE);
  203.  
  204.     * block = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  205.     * New_Object = Object;
  206.     return (PRIM_DONE);
  207.   }
  208.  
  209.   /*
  210.     Add a copy of the object to the last constant block in memory.
  211.    */
  212.  
  213.   Block_Length = (OBJECT_DATUM (* (Constant_Address - 1)));
  214.   Constant_Address -= 2;
  215.   New_Address = Constant_Address;
  216.  
  217.   for (i = Length; --i >= 0; )
  218.   {
  219.     *Constant_Address++ = *Obj_Address;
  220.     *Obj_Address++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, i));
  221.   }
  222.  
  223.   *Constant_Address++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  224.   *Constant_Address++ = (MAKE_OBJECT (END_OF_BLOCK, Block_Length + Length));
  225.   *(New_Address + 2 - Block_Length) =
  226.     (MAKE_OBJECT (PURE_PART, Block_Length + Length));
  227.   Obj_Address -= Length;
  228.   Free_Constant = Constant_Address;
  229.   SET_CONSTANT_TOP ();
  230.  
  231.   /* Run through memory relocating pointers to this object, including
  232.    * those in pure areas.
  233.    */
  234.  
  235.   Terminate_Old_Stacklet ();
  236.   SEAL_CONSTANT_SPACE ();
  237.   End_Of_Area = (CONSTANT_AREA_END ());
  238.  
  239.   ENTER_CRITICAL_SECTION ("impurify");
  240.  
  241.   update (Heap_Bottom, Free, Obj_Address, New_Address);
  242.   update ((CONSTANT_AREA_START ()), End_Of_Area, Obj_Address, New_Address);
  243.  
  244.   EXIT_CRITICAL_SECTION ({});
  245.  
  246.   * New_Object = (MAKE_POINTER_OBJECT (OBJECT_TYPE (Object), New_Address));
  247.   return (PRIM_DONE);
  248. }
  249.  
  250. DEFINE_PRIMITIVE ("PRIMITIVE-IMPURIFY", Prim_impurify, 1, 1,
  251.   "(object)\n\
  252. Remove OBJECT from pure space so it can be side effected.\n\
  253. The object is placed in constant space instead if it fits,\n\
  254. otherwise the whole block where it lives in pure space is marked\n\
  255. as being in constant space.")
  256. {
  257.   PRIMITIVE_HEADER (1);
  258.   {
  259.     fast SCHEME_OBJECT old_object;
  260.     SCHEME_OBJECT new_object;
  261.     TOUCH_IN_PRIMITIVE ((ARG_REF (1)), old_object);
  262.     {
  263.       long result = (make_impure (old_object, (&new_object)));
  264.       if (result != PRIM_DONE)
  265.     signal_error_from_primitive (result);
  266.     }
  267.     PRIMITIVE_RETURN (new_object);
  268.   }
  269. }
  270.  
  271. SCHEME_OBJECT *
  272. DEFUN (find_constant_space_block, (obj_address),
  273.        fast SCHEME_OBJECT * obj_address)
  274. {
  275.   fast SCHEME_OBJECT * where, * low_constant;
  276.  
  277.   low_constant = Constant_Space;
  278.   where = (Free_Constant - 1);
  279.  
  280.   while (where >= low_constant)
  281.   {
  282. #if FALSE
  283.     /* Skip backwards over turds left over by ALIGN_FLOAT */
  284.  
  285.     /* This should be #ifdef FLOATING_ALIGNMENT, but
  286.        works by serendipity since the padding turds have a
  287.        datum of 0 and are correctly skipped over.
  288.      */
  289.  
  290.     if (* where = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0)))
  291.     {
  292.       where -= 1;
  293.       continue;
  294.     }
  295. #endif
  296.     where -= (1 + (OBJECT_DATUM (* where)));
  297.     if (where < obj_address)
  298.       return (where + 1);
  299.   }
  300.   return ((SCHEME_OBJECT *) NULL);
  301. }
  302.  
  303. Boolean
  304. DEFUN (Pure_Test, (obj_address), SCHEME_OBJECT * obj_address)
  305. {
  306.   SCHEME_OBJECT * block;
  307.  
  308.   block = (find_constant_space_block (obj_address));
  309.   if (block == ((SCHEME_OBJECT *) NULL))
  310.     return (false);
  311.   return
  312.     ((Boolean) (obj_address <= (block + (OBJECT_DATUM (* block)))));
  313. }
  314.  
  315. DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1,
  316.   "Return #T if OBJECT is pure (i.e. it doesn't point to any other object,\n\
  317. or it is in a pure section of the constant space).")
  318. {
  319.   PRIMITIVE_HEADER (1);
  320.   {
  321.     fast SCHEME_OBJECT object = (ARG_REF (1));
  322.     if ((GC_Type_Non_Pointer (object)) ||
  323.     (GC_Type_Special (object)))
  324.       PRIMITIVE_RETURN (SHARP_T);
  325.     TOUCH_IN_PRIMITIVE (object, object);
  326.     {
  327.       SCHEME_OBJECT * address =
  328.     ((GC_Type_Compiled (object))
  329.      ? (compiled_entry_to_block_address (object))
  330.      : (OBJECT_ADDRESS (object)));
  331.       PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (ADDRESS_PURE_P (address)));
  332.     }
  333.   }
  334. }
  335.  
  336. DEFINE_PRIMITIVE ("CONSTANT?", Prim_constant_p, 1, 1,
  337.   "Return #T if OBJECT is in constant space or isn't a pointer.")
  338. {
  339.   PRIMITIVE_HEADER (1);
  340.   {
  341.     fast SCHEME_OBJECT object = (ARG_REF (1));
  342.     if ((GC_Type_Non_Pointer (object)) || (GC_Type_Special (object)))
  343.       PRIMITIVE_RETURN (SHARP_T);
  344.     TOUCH_IN_PRIMITIVE (object, object);
  345.     PRIMITIVE_RETURN
  346.       (BOOLEAN_TO_OBJECT (ADDRESS_CONSTANT_P (OBJECT_ADDRESS (object))));
  347.   }
  348. }
  349.  
  350. DEFINE_PRIMITIVE ("GET-NEXT-CONSTANT", Prim_get_next_constant, 0, 0,
  351.   "Return the next free address in constant space.")
  352. {
  353.   SCHEME_OBJECT * next_address = (Free_Constant + 1);
  354.   PRIMITIVE_HEADER (0);
  355.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (next_address)));
  356. }
  357.  
  358. /* copy_to_constant_space is a microcode utility procedure.
  359.    It takes care of making legal constant space blocks.
  360.    The microcode kills itself if there is not enough constant
  361.    space left.
  362.  */
  363.  
  364. extern SCHEME_OBJECT *copy_to_constant_space();
  365.  
  366. SCHEME_OBJECT *
  367. DEFUN (copy_to_constant_space,
  368.        (source, nobjects),
  369.        fast SCHEME_OBJECT *source AND
  370.        long nobjects)
  371. {
  372.   fast long i;
  373.   fast SCHEME_OBJECT * dest;
  374.   SCHEME_OBJECT * result;
  375.  
  376.   dest = Free_Constant;
  377.   if (!(TEST_CONSTANT_TOP (dest + nobjects + 6)))
  378.   {
  379.     outf_fatal ("copy_to_constant_space: Not enough constant space!\n");
  380.     Microcode_Termination (TERM_NO_SPACE);
  381.   }
  382.   *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 3));
  383.   *dest++ = (MAKE_OBJECT (PURE_PART, nobjects + 5));
  384.   *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  385.   *dest++ = (MAKE_OBJECT (CONSTANT_PART, 3));
  386.   result = dest;
  387.   for (i = nobjects; --i >= 0; )
  388.     *dest++ = *source++;
  389.   *dest++ = (MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1));
  390.   *dest++ = (MAKE_OBJECT (END_OF_BLOCK, nobjects + 5));
  391.   Free_Constant = dest;
  392.   SET_CONSTANT_TOP ();
  393.  
  394.   return (result);
  395. }
  396.  
  397. gc_hook_list  pre_gc_hooks = ((gc_hook_list) NULL);
  398. gc_hook_list post_gc_hooks = ((gc_hook_list) NULL);
  399.  
  400. static int
  401. DEFUN (add_gc_hook, (cell, hook),
  402.        gc_hook_list * cell AND void EXFUN ((* hook), (void)))
  403. {
  404.   gc_hook_list new = ((gc_hook_list)
  405.               (malloc (sizeof (struct gc_hook_list_s))));
  406.   if (new == ((gc_hook_list) NULL))
  407.     return (-1);
  408.  
  409.   new->hook = hook;
  410.   new->next = ((gc_hook_list) NULL);
  411.  
  412.   while ((* cell) != ((gc_hook_list) NULL))
  413.     cell = (& ((* cell)->next));
  414.  
  415.   * cell = new;
  416.   return (0);
  417. }
  418.  
  419. static void
  420. DEFUN (run_gc_hooks, (gc_hooks), gc_hook_list gc_hooks)
  421. {
  422.   while (gc_hooks != ((gc_hook_list) NULL))
  423.   {
  424.     (* (gc_hooks->hook)) ();
  425.     gc_hooks = gc_hooks->next;
  426.   }
  427.   return;
  428. }
  429.  
  430. int
  431. DEFUN (add_pre_gc_hook, (hook),
  432.        void EXFUN ((* hook), (void)))
  433. {
  434.   return (add_gc_hook ((& pre_gc_hooks), hook));
  435. }
  436.  
  437. int
  438. DEFUN (add_post_gc_hook, (hook),
  439.        void EXFUN ((* hook), (void)))
  440. {
  441.   return (add_gc_hook ((& post_gc_hooks), hook));
  442. }
  443.  
  444. void
  445. DEFUN_VOID (run_pre_gc_hooks)
  446. {
  447.   run_gc_hooks (pre_gc_hooks);
  448.   return;
  449. }
  450.  
  451. void
  452. DEFUN_VOID (run_post_gc_hooks)
  453. {
  454.   run_gc_hooks (post_gc_hooks);
  455.   return;
  456. }
  457.