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 / gcloop.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  8KB  |  326 lines
  1. /* -*-C-*-
  2.  
  3. $Id: gcloop.c,v 9.47 2000/12/05 21:23:44 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* 
  23.  *
  24.  * This file contains the code for the most primitive part
  25.  * of garbage collection.
  26.  *
  27.  */
  28.  
  29. #include "scheme.h"
  30. #include "gccode.h"
  31.  
  32. /* Exports */
  33.  
  34. extern SCHEME_OBJECT * EXFUN (GCLoop, (SCHEME_OBJECT *, SCHEME_OBJECT **));
  35.  
  36. #define GC_Pointer(Code)                        \
  37. {                                    \
  38.   Old = (OBJECT_ADDRESS (Temp));                    \
  39.   Code;                                    \
  40. }
  41.  
  42. #define GC_RAW_POINTER(Code)                        \
  43. {                                    \
  44.   Old = (SCHEME_ADDR_TO_ADDR (Temp));                    \
  45.   Code;                                    \
  46. }
  47.  
  48. #define Setup_Pointer_for_GC(Extra_Code)                \
  49. {                                    \
  50.   GC_Pointer (Setup_Pointer (true, Extra_Code));            \
  51. }
  52.  
  53. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  54.  
  55. #ifndef GC_SCAN_HISTORY_SIZE
  56. #define GC_SCAN_HISTORY_SIZE 1024
  57. #endif
  58.  
  59. SCHEME_OBJECT
  60.   * gc_scan_trap = ((SCHEME_OBJECT *) 0),
  61.   * gc_free_trap = ((SCHEME_OBJECT *) 0),
  62.   gc_trap = (MAKE_OBJECT (TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE)),
  63.   * (gc_scan_history [GC_SCAN_HISTORY_SIZE]),
  64.   * (gc_to_history [GC_SCAN_HISTORY_SIZE]);
  65.  
  66. SCHEME_OBJECT gc_object_referenced = SHARP_F;
  67. SCHEME_OBJECT gc_objects_referencing = SHARP_F;
  68. unsigned long gc_objects_referencing_count;
  69. SCHEME_OBJECT * gc_objects_referencing_scan;
  70. SCHEME_OBJECT * gc_objects_referencing_end;
  71.  
  72. static int gc_scan_history_index;
  73.  
  74. #define INITIALIZE_GC_HISTORY()                        \
  75. {                                    \
  76.   gc_scan_history_index = 0;                        \
  77.   {                                    \
  78.     SCHEME_OBJECT ** scan = gc_scan_history;                \
  79.     SCHEME_OBJECT ** end = (scan + GC_SCAN_HISTORY_SIZE);        \
  80.     while (scan < end)                            \
  81.       (*scan++) = ((SCHEME_OBJECT *) 0);                \
  82.   }                                    \
  83.   {                                    \
  84.     SCHEME_OBJECT ** scan = gc_to_history;                \
  85.     SCHEME_OBJECT ** end = (scan + GC_SCAN_HISTORY_SIZE);        \
  86.     while (scan < end)                            \
  87.       (*scan++) = ((SCHEME_OBJECT *) 0);                \
  88.   }                                    \
  89. }
  90.  
  91. #define HANDLE_GC_TRAP()                        \
  92. {                                    \
  93.   (gc_scan_history [gc_scan_history_index]) = Scan;            \
  94.   (gc_to_history [gc_scan_history_index]) = To;                \
  95.   if ((++gc_scan_history_index) == GC_SCAN_HISTORY_SIZE)        \
  96.     gc_scan_history_index = 0;                        \
  97.   if ((Temp == gc_trap)                            \
  98.       || ((gc_scan_trap != 0) && (Scan >= gc_scan_trap))        \
  99.       || ((gc_free_trap != 0) && (To >= gc_free_trap)))            \
  100.     {                                    \
  101.       outf_error ("\nGCLoop: trap.\n");                    \
  102.       abort ();                                \
  103.     }                                    \
  104. }
  105.  
  106. #else
  107.  
  108. #define INITIALIZE_GC_HISTORY()
  109. #define HANDLE_GC_TRAP()
  110.  
  111. #endif
  112.  
  113. SCHEME_OBJECT *
  114. DEFUN (GCLoop,
  115.        (Scan, To_Pointer),
  116.        fast SCHEME_OBJECT * Scan
  117.        AND SCHEME_OBJECT ** To_Pointer)
  118. {
  119.   fast SCHEME_OBJECT
  120.     * To, * Old, Temp,
  121.     * low_heap, New_Address;
  122. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  123.   SCHEME_OBJECT object_referencing;
  124. #endif
  125.  
  126.   INITIALIZE_GC_HISTORY ();
  127.   To = * To_Pointer;
  128.   low_heap = Constant_Top;
  129.   for ( ; Scan != To; Scan++)
  130.   {
  131.     Temp = * Scan;
  132. #ifdef ENABLE_GC_DEBUGGING_TOOLS
  133.     object_referencing = Temp;
  134. #endif
  135.     HANDLE_GC_TRAP ();
  136.  
  137.     Switch_by_GC_Type (Temp)
  138.     {
  139.       case TC_BROKEN_HEART:
  140.         if (Scan == (OBJECT_ADDRESS (Temp)))
  141.     {
  142.       *To_Pointer = To;
  143.       return (Scan);
  144.     }
  145.     sprintf (gc_death_message_buffer,
  146.          "gcloop: broken heart (0x%lx) in scan",
  147.          Temp);
  148.     gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
  149.     /*NOTREACHED*/
  150.  
  151.       case TC_MANIFEST_NM_VECTOR:
  152.       case TC_MANIFEST_SPECIAL_NM_VECTOR:
  153.     Scan += OBJECT_DATUM (Temp);
  154.     break;
  155.  
  156.       /* Compiled code relocation. */
  157.  
  158.       case TC_LINKAGE_SECTION:
  159.       {
  160.     switch (READ_LINKAGE_KIND (Temp))
  161.     {
  162.       case REFERENCE_LINKAGE_KIND:
  163.       case ASSIGNMENT_LINKAGE_KIND:
  164.       {
  165.         /* Assumes that all others are objects of type TC_QUAD without
  166.            their type codes.
  167.            */
  168.  
  169.         fast long count;
  170.  
  171.         Scan++;
  172.         for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
  173.          --count >= 0;
  174.          Scan += 1)
  175.         {
  176.           Temp = (* Scan);
  177.           GC_RAW_POINTER (Setup_Internal (true,
  178.                           TRANSPORT_RAW_QUADRUPLE (),
  179.                           RAW_BH (true, continue)));
  180.         }
  181.         Scan -= 1;
  182.         break;
  183.       }
  184.  
  185.       case OPERATOR_LINKAGE_KIND:
  186.       case GLOBAL_OPERATOR_LINKAGE_KIND:
  187.       {
  188.         fast long count;
  189.         fast char * word_ptr;
  190.         SCHEME_OBJECT * end_scan;
  191.  
  192.         START_OPERATOR_RELOCATION (Scan);
  193.         count = (READ_OPERATOR_LINKAGE_COUNT (Temp));
  194.         word_ptr = (FIRST_OPERATOR_LINKAGE_ENTRY (Scan));
  195.         end_scan = (END_OPERATOR_LINKAGE_AREA (Scan, count));
  196.  
  197.         while (--count >= 0)
  198.         {
  199.           Scan = ((SCHEME_OBJECT *) word_ptr);
  200.           word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
  201.           EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
  202.           GC_RAW_POINTER (Setup_Aligned
  203.                   (true,
  204.                    TRANSPORT_RAW_COMPILED (),
  205.                    RAW_COMPILED_BH (true,
  206.                         goto next_operator)));
  207.         next_operator:
  208.           STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan);
  209.         }
  210.         Scan = end_scan;
  211.         END_OPERATOR_RELOCATION (Scan);
  212.         break;
  213.       }
  214.  
  215.       case CLOSURE_PATTERN_LINKAGE_KIND:
  216.         Scan += (READ_CACHE_LINKAGE_COUNT (Temp));
  217.         break;
  218.  
  219.       default:
  220.       {
  221.         gc_death (TERM_EXIT,
  222.               "GC: Unknown compiler linkage kind.",
  223.               Scan, Free);
  224.         /*NOTREACHED*/
  225.       }
  226.     }
  227.     break;
  228.       }
  229.  
  230.       case TC_MANIFEST_CLOSURE:
  231.       {
  232.     fast long count;
  233.     fast char * word_ptr;
  234.     SCHEME_OBJECT * area_end;
  235.  
  236.     START_CLOSURE_RELOCATION (Scan);
  237.     Scan += 1;
  238.     count = (MANIFEST_CLOSURE_COUNT (Scan));
  239.     word_ptr = (FIRST_MANIFEST_CLOSURE_ENTRY (Scan));
  240.     area_end = (MANIFEST_CLOSURE_END (Scan, count));
  241.  
  242.     while ((--count) >= 0)
  243.     {
  244.       Scan = ((SCHEME_OBJECT *) (word_ptr));
  245.       word_ptr = (NEXT_MANIFEST_CLOSURE_ENTRY (word_ptr));
  246.       EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
  247.       GC_RAW_POINTER (Setup_Aligned
  248.               (true,
  249.                TRANSPORT_RAW_COMPILED (),
  250.                RAW_COMPILED_BH (true,
  251.                         goto next_closure)));
  252.     next_closure:
  253.       STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan);
  254.     }
  255.  
  256.     Scan = area_end;
  257.     END_CLOSURE_RELOCATION (Scan);
  258.     break;
  259.       }
  260.  
  261.       case_compiled_entry_point:
  262.     GC_Pointer (Setup_Aligned (true,
  263.                    Transport_Compiled (),
  264.                    Compiled_BH (true, goto after_entry)));
  265.       after_entry:
  266.     *Scan = Temp;
  267.     break;
  268.  
  269.       case_Cell:
  270.     Setup_Pointer_for_GC(Transport_Cell());
  271.     break;
  272.  
  273.       case TC_REFERENCE_TRAP:
  274.     if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
  275.     {
  276.       /* It is a non pointer. */
  277.       break;
  278.     }
  279.     /* Fall Through. */
  280.  
  281.       case_Pair:
  282.     Setup_Pointer_for_GC (Transport_Pair ());
  283.     break;
  284.  
  285.       case TC_VARIABLE:
  286.       case_Triple:
  287.     Setup_Pointer_for_GC (Transport_Triple ());
  288.     break;
  289.  
  290.       case_Quadruple:
  291.     Setup_Pointer_for_GC (Transport_Quadruple ());
  292.     break;
  293.  
  294.       case_Aligned_Vector:
  295.     GC_Pointer (Setup_Aligned (true, 
  296.                    goto Move_Vector,
  297.                    Normal_BH (true, continue)));
  298.     break;
  299.  
  300.       case_Vector:
  301.     Setup_Pointer_for_GC (Transport_Vector ());
  302.     break;
  303.  
  304.       case TC_FUTURE:
  305.     Setup_Pointer_for_GC (Transport_Future ());
  306.     break;
  307.  
  308.       case TC_WEAK_CONS:
  309.     Setup_Pointer_for_GC (Transport_Weak_Cons ());
  310.     break;
  311.  
  312.       default:
  313.     GC_BAD_TYPE ("gcloop", Temp);
  314.     /* Fall Through */
  315.  
  316.       case_Non_Pointer:
  317.     break;
  318.  
  319.       }    /* Switch_by_GC_Type */
  320.   } /* For loop */
  321.  
  322.   *To_Pointer = To;
  323.   return (To);
  324.  
  325. } /* GCLoop */
  326.