home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / oct93 / develop / umbscheme.lha / UMBScheme / src / architecture.c next >
C/C++ Source or Header  |  1993-07-21  |  14KB  |  654 lines
  1. /* architecture.c -- UMB Scheme, symbol table, stacks and heap.
  2.  
  3. UMB Scheme Interpreter                    $Revision: 2.5 $
  4. Copyright (C) 1988, 1991 William R Campbell
  5.  
  6. This program is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 1, or (at your option)
  9. any later version.
  10.  
  11. This program is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. GNU General Public License for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with this program; if not, write to the Free Software
  18. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. UMB Scheme was written by Bill Campbell with help from Karl Berry,
  21. Barbara Dixey, Ira Gerstein, Mary Glaser, Kathy Hargreaves, Bill McCabe,
  22. Long Nguyen, Susan Quina, Jeyashree Sivasubram, Bela Sohoni and Thang Quoc Tran.
  23.  
  24. For additional information about UMB Scheme, contact the author:
  25.  
  26.     Bill Campbell
  27.     Department of Mathematics and Computer Science
  28.     University of Massachusetts at Boston
  29.     Harbor Campus
  30.     Boston, MA 02125
  31.  
  32.     Telephone: 617-287-6449     Internet: bill@cs.umb.edu
  33.  
  34. */
  35.  
  36. #include <signal.h>
  37. #include "portable.h"
  38. #include "io.h"
  39. #include "eval.h"
  40. #include "object.h"
  41. #include "architecture.h"
  42. #include "steering.h"
  43. #include "debug.h"
  44. #include "primitive.h"
  45. #include "number.h"
  46.  
  47. Public Object    Expression_Register, Value_Register, Environment_Register,
  48.         Function_Register, Arguments_Register, State_Register;
  49.  
  50. Public ELabel    PC_Register;
  51.  
  52. Public    Object    Value_Debugged, State_Debugged;
  53.  
  54. Public    ELabel    PC_Debugged;
  55.  
  56. Public    Integer Arg_Stack_Ptr = 0;
  57. Public    Integer Debugged_Ptr  = 0;
  58. #ifdef _DCC
  59. __far
  60. #endif
  61. Public    Object    Arg_Stack[ARG_STACK_SIZE];
  62.  
  63. /* Garbage collector declarations. */
  64.  
  65. Public    Boolean Allocating = FALSE;
  66. Public    Boolean Show_GC_Messages = TRUE;
  67.  
  68. Private Integer Free = 0;        /* First free location. */
  69. Private Integer Working = 0;        /* Space allocations come from this. */
  70. Private Integer Fallow = 1;        /* The half currently not in use. */
  71. Private Byte * Heap[2] = { NULL,NULL};    /* Two spaces. */
  72.  
  73. #define INITIAL_HEAPSIZE    200000
  74. #define MAX_HEAPSIZE        800000
  75. #define ENLARGEMENT_FACTOR    2
  76. #define DESIRED_RECLAIMATION    0.2
  77.  
  78. Private Integer Heapsize = INITIAL_HEAPSIZE;
  79. Private Boolean Enable_Heap_Enlargement = TRUE;
  80. Private Integer Next_Heapsize = INITIAL_HEAPSIZE;
  81.  
  82.  
  83. typedef struct entry_structure
  84. {
  85.     Object Symbol;
  86.     struct entry_structure *Next;
  87. } Entry;
  88.  
  89.  
  90. Private Entry * Make_Entry();
  91.  
  92. Private void Init_Heap(size)
  93.  
  94. Integer size;
  95.  
  96. {
  97.     if (Heap[0] == NULL && Heap[1] == NULL )
  98.     {
  99.         Heap[0] = (Byte *)malloc( (unsigned) (size+ALIGNMENT));
  100.         Heap[1] = (Byte *)malloc( (unsigned) (size+ALIGNMENT));
  101.     }
  102.  
  103.     if ( Heap[0] == NULL || Heap[1] == NULL )
  104.     {
  105.         Output( "\nPANIC: Not enough memory for the heap.\n" );
  106.         exit(1);
  107.     }
  108.  
  109.     Free = 0;
  110.     Working = 0;
  111.     Fallow = 1;
  112. }
  113.  
  114. /* Get the current size of the heap. */
  115.  
  116. Public void Get_Heap_Size()
  117. {
  118.     Integer_To_Number(Heapsize - Free);
  119. }
  120.  
  121. Public void Get_Arg_Stack_Ptr()
  122. {
  123.     Integer_To_Number( Arg_Stack_Ptr );
  124. }
  125.  
  126.  
  127.  
  128. /* Allocate some memory from the working space. */
  129.  
  130. Public Object Allocate(size)
  131.  
  132.     Integer size;
  133.  
  134. {
  135.     Object    new;
  136.     void    Garbage_Collect();
  137.  
  138.     Allocating = TRUE;
  139.  
  140.     if (Free + size >= Heapsize)
  141.     {
  142.         /* Not enough space. */
  143.         Garbage_Collect();
  144.     }
  145.  
  146.     if (Free + size < Heapsize)
  147.     {
  148.         /* Enough space now, or was before. */
  149.         new = (Object)&Heap[Working][Free];
  150. #if (ALIGNMENT-1)
  151.         /* Alignment (if not 1; defined in portable.h) */
  152.  
  153.         Free += ((size+ALIGNMENT-1)/ALIGNMENT)*ALIGNMENT;
  154. #else
  155.         Free += size;
  156. #endif
  157.     }
  158.     else
  159.     {
  160.         Panic( "Memory Exhaused" );
  161.         new =  Nil;
  162.     }
  163.  
  164.     if ( Control_C )
  165.     {
  166.         Control_C = FALSE;
  167.         Allocating = FALSE;
  168.         Handler( SIGINT );
  169.     }
  170.     Allocating = FALSE;
  171.  
  172.     return new;
  173. }
  174.  
  175.  
  176. Public void Garbage_Collect()
  177. {
  178.     Integer this_argument;
  179.     Integer orig_free = Free;
  180.     Byte    *new_heap[2] ;
  181.     Character temp_string[120];
  182.  
  183.     if ( Show_GC_Messages )
  184.     {
  185.         Output( "GCing... " );
  186.     }
  187.  
  188.     if ( Next_Heapsize > Heapsize )
  189.     {
  190.         /* Allocate a new, larger, heap */
  191.  
  192.         new_heap[0] = NULL;
  193.         new_heap[1] = NULL;
  194.         new_heap[0] = (Byte *) malloc((unsigned) Next_Heapsize);
  195.         new_heap[1] = (Byte *) malloc((unsigned) Next_Heapsize);
  196.  
  197.         if ( new_heap[0] == NULL || new_heap[1] == NULL )
  198.         {
  199.             /* Reallocation has failed  -- Disable enlargement */
  200.  
  201.             if ( new_heap[0] != NULL ) free( new_heap[0] );
  202.             if ( new_heap[1] != NULL ) free( new_heap[1] );
  203.             Enable_Heap_Enlargement = FALSE;
  204.             Next_Heapsize = Heapsize;
  205.         }
  206.         else
  207.         {
  208.             /* Enlarge the current fallow (next working) heap. */
  209.             free( Heap[Fallow] );
  210.             Heap[Fallow] = new_heap[Fallow];
  211.         }
  212.     }
  213.  
  214.     /* Exchange spaces. */
  215.     Working = 1 - Working;
  216.     Fallow = 1 - Fallow;
  217.  
  218.     /* Nothing's allocated yet in the new space. */
  219.     Free = 0;
  220.  
  221.     /* Garbage collect the (object) registers. */
  222.     Relocate(&Expression_Register);
  223.     Relocate(&Value_Register);
  224.     Relocate(&Environment_Register);
  225.     Relocate(&Function_Register);
  226.     Relocate(&Arguments_Register);
  227.     Relocate(&State_Register);
  228.  
  229.     /* Garbage collect the (object) debugged registers */
  230.  
  231.     Relocate(&Value_Debugged);
  232.     Relocate(&State_Debugged);
  233.  
  234.     /* And the special objects. */
  235.     Relocate(&Nil);
  236.     Relocate(&The_Global_Environment);
  237.     Relocate(&The_True_Object);
  238.     Relocate(&The_False_Object);
  239.     Relocate(&The_Eof_Object);
  240.     Relocate(&Current_Input_Port);
  241.     Relocate(&Current_Output_Port);
  242.     Relocate(&The_Transcript_Port);
  243.     Relocate(&The_Dot_Object);
  244.     Relocate(&The_Rparen_Object);
  245.  
  246.     /* Debugger Registers */
  247.     Relocate(&Traced_Procedures);
  248.  
  249.     /* And the special symbols. */
  250.     Relocate(&The_Undefined_Symbol);
  251.     Relocate(&The_Syntactic_Keyword);
  252.     Relocate(&An_Argument);
  253.     Relocate("E_Symbol);
  254.     Relocate(&DEFINE_Symbol);
  255.     Relocate(&SET_Symbol);
  256.     Relocate(&IF_Symbol);
  257.     Relocate(&MACRO_Symbol);
  258.     Relocate(&BEGIN_Symbol);
  259.     Relocate(&DELAY_Symbol);
  260.     Relocate(&LAMBDA_Symbol);
  261.  
  262.     /* Now gc the stack... */
  263.     for (this_argument = 0; this_argument < Arg_Stack_Ptr;
  264.                 this_argument++)
  265.     {
  266.         Relocate(&Arg_Stack[this_argument]);
  267.     }
  268.  
  269.     /* ...and the symbols. */
  270.     Symbol_Hash_Iterate(Relocate);
  271.  
  272.     if ( Next_Heapsize != Heapsize )
  273.     {
  274.         /* Enlarge the current fallow (previous working) heap. */
  275.         free( Heap[Fallow] );
  276.         Heap[Fallow] = new_heap[Fallow];
  277.         Heapsize = Next_Heapsize;
  278.     }
  279.  
  280.     if ( Show_GC_Messages )
  281.     {
  282.         sprintf( temp_string,
  283.          "%d bytes collected, %d bytes used, heapsize %d bytes.\n",
  284.          orig_free-Free, Free, Heapsize );
  285.         Output(temp_string);
  286.     }
  287.  
  288.     if ( Enable_Heap_Enlargement && Heapsize < MAX_HEAPSIZE )
  289.     {
  290.         /* Decide whether to enlarge heap at next garbage collection */
  291.  
  292.         if ( (float) Free / (float) Heapsize > DESIRED_RECLAIMATION )
  293.         {
  294.             Next_Heapsize = Heapsize * ENLARGEMENT_FACTOR;
  295.             if ( Next_Heapsize > MAX_HEAPSIZE )
  296.             {
  297.                 Next_Heapsize = MAX_HEAPSIZE;
  298.                 if ( Show_GC_Messages )
  299.                  Output("Disabling enlargement due to size.\n");
  300.             }
  301.         }
  302.     }
  303. }
  304.  
  305.  
  306. Public void Relocate( old )
  307.  
  308.     Object * old;
  309. {
  310.     if ( *old != NULL )
  311.     {
  312.         if (Is_Forwarded(*old))
  313.         {
  314.             *old = Get_Forwarding_Address(*old);
  315.         }
  316.         else
  317.         {
  318.             *old = GC_Object(*old);
  319.         }
  320.     }
  321. }
  322.  
  323.  
  324.  
  325. Public Object Move_Object(old_object, size)
  326.  
  327.     Object old_object;
  328.     Integer size;
  329. {
  330.     Byte *new, *old;
  331.     Object new_object;
  332.  
  333.     new_object = Allocate(size); /* GC never called during GC */
  334.     old = (Byte *) old_object;
  335.     new = (Byte *) new_object;
  336.  
  337.     for (; size > 0; size--)
  338.     {
  339.         *new++ = *old++;
  340.     }
  341.  
  342.     Set_Forwarding_Address(old_object,new_object);
  343.     return( new_object );
  344. }
  345.  
  346. /* Symbol table/environment handling stuff. */
  347.  
  348. Public void Assign(var, value, env)
  349.  
  350.     Object var, value, env;
  351. {
  352.     Object* location;
  353.     Object* how;
  354.     Integer frame;
  355.  
  356.     if ( Is_Local_Variable( var ) )
  357.     {
  358.         for ( frame = 0;
  359.               frame < Get_Variable_Frame_Number( var );
  360.               frame++ ) env = Get_Environment_Frame_Previous( env );
  361.         location = &Get_Environment_Frame_Binding_Value( env ,
  362.                 Get_Variable_Displacement( var ) );
  363.         how = &Get_Environment_Frame_Binding_How( env ,
  364.                 Get_Variable_Displacement( var ) );
  365.     }
  366.     else
  367.     {
  368.         location = &Get_Global_Binding(Get_Variable_Symbol( var ) );
  369.         how = &Get_Symbol_How(Get_Variable_Symbol( var ) );
  370.     }
  371.  
  372.     if (*location == The_Undefined_Symbol)
  373.     {
  374.         Error1("`%s' is undefined; you can't assign to it",
  375.                 Get_Symbol_Name(Get_Variable_Symbol(var)));
  376.     }
  377.  
  378.     *location = value;
  379.     *how = Expression_Register;
  380.     Value_Register = value;
  381. }
  382.  
  383. Public void Define(var, value, env)
  384.  
  385.     Object var, value, env;
  386. {
  387.     Object* location;
  388.     Object* how;
  389.  
  390.     if ( Is_Local_Variable( var )  )
  391.     {
  392.         /* We know it's frame 0 (the most recent);
  393.            otherwise, compile_form() would have caught it */
  394.  
  395.         location = &Get_Environment_Frame_Binding_Value( env ,
  396.                 Get_Variable_Displacement( var ) );
  397.         how = &Get_Environment_Frame_Binding_How( env ,
  398.                 Get_Variable_Displacement( var ) );
  399.  
  400.         if (*location != The_Undefined_Symbol)
  401.         {
  402.             Error1("`%s' cannot be defined twice in the same scope",
  403.                 Get_Symbol_Name(Get_Variable_Symbol( var)));
  404.         }
  405.  
  406.     }
  407.     else
  408.     {
  409.         location = &Get_Global_Binding(Get_Variable_Symbol( var ) );
  410.         how = &Get_Symbol_How(Get_Variable_Symbol( var ) );
  411.         Get_Symbol_User_Defined(Get_Variable_Symbol( var )) =
  412.             Prelude_Complete;
  413.     }
  414.  
  415.     *location = value;
  416.     *how = Expression_Register;
  417.     Value_Register = Get_Variable_Symbol( var );
  418.  
  419.     if ( Is_Procedure( value ) )
  420.     {
  421.         Get_Procedure_Name( value ) = Get_Symbol_Name( Value_Register );
  422.     }
  423. }
  424.  
  425. /* Extend_Environment makes a new environment to be added to the top of
  426. the environment stack. */
  427.  
  428. Public void Extend_Environment(actual_count)
  429.  
  430.     Integer actual_count;
  431. {
  432.     Object old_frame = Get_Procedure_Frame(Function_Register);
  433.     Integer formal_count = Get_Procedure_Numargs(Function_Register);
  434.     Boolean has_rest = Get_Procedure_Has_Rest(Function_Register);
  435.  
  436.     if (has_rest && actual_count < formal_count)
  437.     {
  438.         Display_Error(
  439.         "Not enough actuals in the following procedure call",
  440.         Expression_Register);
  441.     }
  442.     else if (! has_rest && actual_count != formal_count)
  443.     {
  444.         Display_Error(
  445.         "Wrong number of actuals in the following procedure call",
  446.                    Expression_Register);
  447.     }
  448.  
  449.     Environment_Register =
  450.         Copy_Object( old_frame, Environment_Frame_Size(
  451.                     Get_Environment_Frame_Size(old_frame)));
  452.  
  453.     Get_Environment_Frame_Previous(Environment_Register) =
  454.         Get_Procedure_Environment(Function_Register);
  455.  
  456.     if (has_rest)
  457.     {
  458.         Integer rest_count = actual_count - formal_count;
  459.  
  460.         /* Construct the list for the rest argument. */
  461.         Push(Nil);   /* The end of our list. */
  462.         while (rest_count--)
  463.         {
  464.             Make_Pair();
  465.             Push(Value_Register);
  466.         }
  467.         Get_Environment_Frame_Binding_Value(Environment_Register,
  468.                           formal_count) = Top(1);
  469.         Pop(1);
  470.     }
  471.  
  472.     actual_count = formal_count;
  473.     while (formal_count--)
  474.     {
  475.         Get_Environment_Frame_Binding_Value(Environment_Register,
  476.                  formal_count) = Top(actual_count-formal_count);
  477.     }
  478.     Pop(actual_count);
  479. }
  480.  
  481.  
  482. Public Object Copy_Object(old_object, size)
  483.  
  484.     Object old_object;
  485.     Integer size;
  486. {
  487.     Byte *new, *old;
  488.     Object new_object;
  489.  
  490.     Push( old_object );     /* Save from GC */
  491.     new_object = Allocate(size);
  492.     old = (Byte *) Top(1);
  493.     Pop( 1 );
  494.     new = (Byte *) new_object;
  495.  
  496.     for (; size > 0; size--)
  497.     {
  498.         *new++ = *old++;
  499.     }
  500.  
  501.     return( new_object );
  502. }
  503.  
  504.  
  505. #define HASH_TABLE_SIZE 1009
  506.  
  507. #ifdef _DCC
  508. __far
  509. #endif
  510.  
  511. Private Entry * Symbol_Hash_Table[HASH_TABLE_SIZE];
  512.  
  513.  
  514. Private Integer Hash(s)
  515.  
  516.     String s;
  517. {
  518.     /* From Aho, Sethi and Ullman */
  519.  
  520.     String p;
  521.     unsigned h = 0, g;
  522.     for ( p = s ; *p != '\0' ; p++ )
  523.     {
  524.         h = (h << 4) + (*p);
  525.         if (g = h & 0xf0000000)
  526.         {
  527.             h = h ^ (g >> 24);
  528.             h = h ^ g;
  529.         }
  530.     }
  531.     return( h % HASH_TABLE_SIZE );
  532. }
  533.  
  534. Private void Init_Hash_Table()
  535. {
  536.     Integer this_entry;
  537.  
  538.     for (this_entry = 0; this_entry < HASH_TABLE_SIZE; this_entry++)
  539.         Symbol_Hash_Table[this_entry] = NULL;
  540. }
  541.  
  542. #define hash_entry Symbol_Hash_Table[hash_value]
  543.  
  544. Public Object Intern_Name(name)
  545.  
  546.     String name;
  547. {
  548.     Integer hash_value = Hash(name);
  549.  
  550.     if (hash_entry == NULL)
  551.     {
  552.         hash_entry = Make_Entry(name);
  553.         return hash_entry->Symbol;
  554.     }
  555.     else
  556.     {
  557.         Boolean at_end = FALSE;
  558.         Entry * this_entry = hash_entry;
  559.  
  560.         while (strcmp(name, Get_Symbol_Name(this_entry->Symbol)) != 0
  561.             && !(at_end = (this_entry->Next == NULL)))
  562.         {
  563.             this_entry = this_entry->Next;
  564.         }
  565.  
  566.         /* If at end of chain, add the entry. */
  567.         if (at_end)
  568.         {
  569.             this_entry->Next = Make_Entry(name);
  570.             return this_entry->Next->Symbol;
  571.         }
  572.         else
  573.         {
  574.             return this_entry->Symbol;
  575.         }
  576.     }
  577. }
  578.  
  579. /* Go through the hash table calling the operation on all its elements. */
  580.  
  581. Public    void Symbol_Hash_Iterate(operation)
  582.  
  583. void (*operation)();                    /* Takes an &object. */
  584. {
  585.     Integer this_bucket;
  586.     Entry * this_entry;
  587.  
  588.     for (this_bucket = 0; this_bucket < HASH_TABLE_SIZE; this_bucket++)
  589.     {
  590.         for (this_entry = Symbol_Hash_Table[this_bucket];
  591.             this_entry != NULL;
  592.             this_entry = this_entry->Next )
  593.         {
  594.             (*operation)(&(this_entry->Symbol));
  595.         }
  596.     }
  597. }
  598.  
  599.  
  600. Private Entry * Make_Entry(name)
  601.  
  602.     String name;
  603. {
  604.     Entry * new = (Entry *) malloc(sizeof(Entry));
  605.  
  606.     if ( new == NULL )
  607.     {
  608.         Panic( "Out of space in making hash entry" );
  609.     }
  610.  
  611.     Make_Symbol(name);
  612.     new->Symbol = Value_Register;
  613.     new->Next = NULL;
  614.  
  615.     return new;
  616. }
  617.  
  618.  
  619. /* Push and pop frames. */
  620. Public void Save()
  621. {
  622.     Make_State_Frame();
  623.  
  624.     Get_State_Frame_Expression(Value_Register) = Expression_Register;
  625.     Get_State_Frame_Environment(Value_Register) = Environment_Register;
  626.     Get_State_Frame_Function(Value_Register) = Function_Register;
  627.     Get_State_Frame_Arguments(Value_Register) = Arguments_Register;
  628.     Get_State_Frame_PC(Value_Register) = PC_Register;
  629.     Get_State_Frame_State(Value_Register) = State_Register;
  630.     Get_State_Frame_Top(Value_Register) = Arg_Stack_Ptr;
  631.  
  632.  
  633.     State_Register = Value_Register;
  634. }
  635.  
  636. /* Note this does not mess with the Value_Register. */
  637. Public void Restore()
  638. {
  639.     Expression_Register = Get_State_Frame_Expression(State_Register);
  640.     Environment_Register = Get_State_Frame_Environment(State_Register);
  641.     Function_Register = Get_State_Frame_Function(State_Register);
  642.     Arguments_Register = Get_State_Frame_Arguments(State_Register);
  643.     PC_Register = Get_State_Frame_PC(State_Register);
  644.     Arg_Stack_Ptr = Get_State_Frame_Top(State_Register);
  645.     State_Register = Get_State_Frame_State(State_Register);
  646. }
  647.  
  648.  
  649. Public void Initialize_Architecture()
  650. {
  651.     Init_Heap(Heapsize);
  652.     Init_Hash_Table();
  653. }
  654.