Gold Fish 2/goldfish_vol2_cd1.bin/files/dev/lang/umbscheme/src/architecture.c

C/C++ Source or Header | 1993-11-30 | 13.9 KB | 651 lines

/* architecture.c -- UMB Scheme, symbol table, stacks and heap.

UMB Scheme Interpreter                  $Revision: 2.12 $
Copyright (C) 1988, 1991 William R Campbell

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

UMB Scheme was written by Bill Campbell with help from Karl Berry,
Barbara Dixey, Ira Gerstein, Mary Glaser, Kathy Hargreaves, Bill McCabe,
Long Nguyen, Susan Quina, Jeyashree Sivasubram, Bela Sohoni and Thang Quoc Tran.

For additional information about UMB Scheme, contact the author:

    Bill Campbell
    Department of Mathematics and Computer Science
    University of Massachusetts at Boston
    Harbor Campus
    Boston, MA 02125

    Telephone: [phone]        Internet: [e-mail]

*/

#include <signal.h>
#include "portable.h"
#include "io.h"
#include "eval.h"
#include "object.h"
#include "architecture.h"
#include "steering.h"
#include "debug.h"
#include "primitive.h"
#include "number.h"

Public Object     Expression_Register, Value_Register, Environment_Register,
        Function_Register, Arguments_Register, State_Register;

Public ELabel    PC_Register;

Public    Object    Value_Debugged, State_Debugged;

Public    ELabel    PC_Debugged;

Public    Integer Arg_Stack_Ptr = 0;
Public    Integer    Debugged_Ptr  = 0;
Public    Object    Arg_Stack[ARG_STACK_SIZE];

/* Garbage collector declarations. */

Public    Boolean    Allocating = FALSE;
Public    Boolean Show_GC_Messages = TRUE;

Private Integer Free = 0;        /* First free location. */
Private Integer Working = 0;        /* Space allocations come from this. */
Private Integer Fallow = 1;        /* The half currently not in use. */
Private Byte * Heap[2] = { NULL,NULL};    /* Two spaces. */

#define INITIAL_HEAPSIZE     200000
#define MAX_HEAPSIZE          800000
#define    ENLARGEMENT_FACTOR    2
#define DESIRED_RECLAIMATION    0.2

Private Integer Heapsize = INITIAL_HEAPSIZE;
Private    Boolean    Enable_Heap_Enlargement = TRUE;
Private    Integer    Next_Heapsize = INITIAL_HEAPSIZE;


typedef struct entry_structure
{
    Object Symbol;
    struct entry_structure *Next;
} Entry;


Private Entry * Make_Entry();

Private    void Init_Heap(size)

Integer size;

{
    if (Heap[0] == NULL && Heap[1] == NULL )
    {
        Heap[0] = (Byte *)malloc( (unsigned) (size+ALIGNMENT));
        Heap[1] = (Byte *)malloc( (unsigned) (size+ALIGNMENT));
    }

    if ( Heap[0] == NULL || Heap[1] == NULL )
    {
        Output( "\nPANIC: Not enough memory for the heap.\n" );
        exit(1);
    }

    Free = 0;
    Working = 0;
    Fallow = 1;
}

/* Get the current size of the heap. */

Public void Get_Heap_Size()
{
    Integer_To_Number(Heapsize - Free);
}

Public void Get_Arg_Stack_Ptr()
{
    Integer_To_Number( Arg_Stack_Ptr );
}



/* Allocate some memory from the working space. */

Public Object Allocate(size)

    Integer size;

{
    Object    new;
    void    Garbage_Collect();

    Allocating = TRUE;

    if (Free + size >= Heapsize)
    {
        /* Not enough space. */
        Garbage_Collect();
    }

    if (Free + size < Heapsize)
    {
        /* Enough space now, or was before. */
        new = (Object)&Heap[Working][Free];
#if (ALIGNMENT-1)
        /* Alignment (if not 1; defined in portable.h) */

        Free += ((size+ALIGNMENT-1)/ALIGNMENT)*ALIGNMENT;
#else
        Free += size;
#endif
    }
    else
    {
        Panic( "Memory Exhausted" );
        new =  Nil;
    }

    if ( Control_C )
    {
        Control_C = FALSE;
        Allocating = FALSE;
        Handler( SIGINT );
    }
    Allocating = FALSE;

    return new;
}


Public void Garbage_Collect()
{
    Integer this_argument;
    Integer orig_free = Free;
    Byte    *new_heap[2] ;
    Character temp_string[120];

    if ( Show_GC_Messages )
    {
        Output( "GCing... " );
    }

    if ( Next_Heapsize > Heapsize )
    {
        /* Allocate a new, larger, heap */

        new_heap[0] = NULL;
        new_heap[1] = NULL;
        new_heap[0] = (Byte *) malloc((unsigned) Next_Heapsize);
        new_heap[1] = (Byte *) malloc((unsigned) Next_Heapsize);

        if ( new_heap[0] == NULL || new_heap[1] == NULL )
        {
            /* Reallocation has failed  -- Disable enlargement */

            if ( new_heap[0] != NULL ) free( new_heap[0] );
            if ( new_heap[1] != NULL ) free( new_heap[1] );
            Enable_Heap_Enlargement = FALSE;
            Next_Heapsize = Heapsize;
        }
        else
        {
            /* Enlarge the current fallow (next working) heap. */
            free( Heap[Fallow] );
            Heap[Fallow] = new_heap[Fallow];
        }
    }

    /* Exchange spaces. */
    Working = 1 - Working;
    Fallow = 1 - Fallow;

    /* Nothing's allocated yet in the new space. */
    Free = 0;

    /* Garbage collect the (object) registers. */
    Relocate(&Expression_Register);
    Relocate(&Value_Register);
    Relocate(&Environment_Register);
    Relocate(&Function_Register);
    Relocate(&Arguments_Register);
    Relocate(&State_Register);

    /* Garbage collect the (object) debugged registers */

    Relocate(&Value_Debugged);
    Relocate(&State_Debugged);

    /* And the special objects. */
    Relocate(&Nil);
    Relocate(&The_Global_Environment);
    Relocate(&The_True_Object);
    Relocate(&The_False_Object);
    Relocate(&The_Eof_Object);
    Relocate(&Current_Input_Port);
    Relocate(&Current_Output_Port);
    Relocate(&The_Transcript_Port);
    Relocate(&The_Dot_Object);
    Relocate(&The_Rparen_Object);

    /* Debugger Registers */
    Relocate(&Traced_Procedures);

    /* And the special symbols. */
    Relocate(&The_Undefined_Symbol);
    Relocate(&The_Syntactic_Keyword);
    Relocate(&An_Argument);
    Relocate("E_Symbol);
    Relocate(&DEFINE_Symbol);
    Relocate(&SET_Symbol);
    Relocate(&IF_Symbol);
    Relocate(&MACRO_Symbol);
    Relocate(&BEGIN_Symbol);
    Relocate(&DELAY_Symbol);
    Relocate(&LAMBDA_Symbol);

    /* Now gc the stack... */
    for (this_argument = 0; this_argument < Arg_Stack_Ptr;
                this_argument++)
    {
        Relocate(&Arg_Stack[this_argument]);
    }

    /* ...and the symbols. */
    Symbol_Hash_Iterate(Relocate);

    if ( Next_Heapsize != Heapsize )
    {
        /* Enlarge the current fallow (previous working) heap. */
        free( Heap[Fallow] );
        Heap[Fallow] = new_heap[Fallow];
        Heapsize = Next_Heapsize;
    }

    if ( Show_GC_Messages )
    {
        sprintf( temp_string,
         "%d bytes collected, %d bytes used, heapsize %d bytes.\n",
         orig_free-Free, Free, Heapsize );
            Output(temp_string);
    }

    if ( Enable_Heap_Enlargement && Heapsize < MAX_HEAPSIZE )
    {
        /* Decide whether to enlarge heap at next garbage collection */

        if ( (float) Free / (float) Heapsize > DESIRED_RECLAIMATION )
        {
            Next_Heapsize = Heapsize * ENLARGEMENT_FACTOR;
            if ( Next_Heapsize > MAX_HEAPSIZE )
            {
                Next_Heapsize = MAX_HEAPSIZE;
                if ( Show_GC_Messages )
                 Output("Disabling enlargement due to size.\n");
            }
        }
    }
}


Public void Relocate( old )

    Object * old;
{
    if ( *old != NULL )
    {
        if (Is_Forwarded(*old))
        {
            *old = Get_Forwarding_Address(*old);
        }
        else
        {
            *old = GC_Object(*old);
        }
    }
}



Public Object Move_Object(old_object, size)

    Object old_object;
    Integer size;
{
    Byte *new, *old;
    Object new_object;

    new_object = Allocate(size); /* GC never called during GC */
    old = (Byte *) old_object;
    new = (Byte *) new_object;

    for (; size > 0; size--)
    {
        *new++ = *old++;
    }

    Set_Forwarding_Address(old_object,new_object);
    return( new_object );
}

/* Symbol table/environment handling stuff. */

Public void Assign(var, value, env)

    Object var, value, env;
{
    Object*    location;
    Object* how;
    Integer    frame;

    if ( Is_Local_Variable( var ) )
    {
        for ( frame = 0;
              frame < Get_Variable_Frame_Number( var );
                  frame++ ) env = Get_Environment_Frame_Previous( env );
        location = &Get_Environment_Frame_Binding_Value( env ,
                Get_Variable_Displacement( var ) );
        how = &Get_Environment_Frame_Binding_How( env ,
                Get_Variable_Displacement( var ) );
    }
    else
    {
        location = &Get_Global_Binding(Get_Variable_Symbol( var ) );
        how = &Get_Symbol_How(Get_Variable_Symbol( var ) );
    }

    if (*location == The_Undefined_Symbol)
    {
        Error1("`%s' is undefined; you can't assign to it",
                Get_Symbol_Name(Get_Variable_Symbol(var)));
    }

    *location = value;
    *how = Expression_Register;
    Value_Register = value;
}

Public void Define(var, value, env)

    Object var, value, env;
{
    Object*    location;
    Object* how;

    if ( Is_Local_Variable( var )  )
    {
        /* We know it's frame 0 (the most recent);
           otherwise, compile_form() would have caught it */

        location = &Get_Environment_Frame_Binding_Value( env ,
                Get_Variable_Displacement( var ) );
        how = &Get_Environment_Frame_Binding_How( env ,
                Get_Variable_Displacement( var ) );

        if (*location != The_Undefined_Symbol)
        {
            Error1("`%s' cannot be defined twice in the same scope",
                Get_Symbol_Name(Get_Variable_Symbol( var)));
        }

    }
    else
    {
        location = &Get_Global_Binding(Get_Variable_Symbol( var ) );
        how = &Get_Symbol_How(Get_Variable_Symbol( var ) );
        Get_Symbol_User_Defined(Get_Variable_Symbol( var )) =
            Prelude_Complete;
    }

    *location = value;
    *how = Expression_Register;
    Value_Register = Get_Variable_Symbol( var );

    if ( Is_Procedure( value ) )
    {
        Get_Procedure_Name( value ) = Get_Symbol_Name( Value_Register );
    }
}

/* Extend_Environment makes a new environment to be added to the top of
the environment stack. */

Public void Extend_Environment(actual_count)

    Integer actual_count;
{
    Object old_frame = Get_Procedure_Frame(Function_Register);
    Integer formal_count = Get_Procedure_Numargs(Function_Register);
    Boolean has_rest = Get_Procedure_Has_Rest(Function_Register);

    if (has_rest && actual_count < formal_count)
    {
        Display_Error(
        "Not enough actuals in the following procedure call",
        Expression_Register);
    }
    else if (! has_rest && actual_count != formal_count)
    {
        Display_Error(
        "Wrong number of actuals in the following procedure call",
                   Expression_Register);
    }

    Environment_Register =
        Copy_Object( old_frame,
             (Integer) Environment_Frame_Size(
                            Get_Environment_Frame_Size(old_frame)));

    Get_Environment_Frame_Previous(Environment_Register) =
        Get_Procedure_Environment(Function_Register);

    if (has_rest)
    {
        Integer rest_count = actual_count - formal_count;

        /* Construct the list for the rest argument. */
        Push(Nil);   /* The end of our list. */
        while (rest_count--)
        {
            Make_Pair();
            Push(Value_Register);
        }
        Get_Environment_Frame_Binding_Value(Environment_Register,
                          formal_count) = Top(1);
        Pop(1);
    }

    actual_count = formal_count;
    while (formal_count--)
    {
        Get_Environment_Frame_Binding_Value(Environment_Register,
                 formal_count) = Top(actual_count-formal_count);
    }
    Pop(actual_count);
}


Public Object Copy_Object(old_object, size)

    Object old_object;
    Integer size;
{
    Byte *new, *old;
    Object new_object;

    Push( old_object );    /* Save from GC */
    new_object = Allocate(size);
    old = (Byte *) Top(1);
    Pop( 1 );
    new = (Byte *) new_object;

    for (; size > 0; size--)
    {
        *new++ = *old++;
    }

    return( new_object );
}


#define HASH_TABLE_SIZE 1009

Private Entry * Symbol_Hash_Table[HASH_TABLE_SIZE];


Private Integer Hash(s)

    String s;
{
    /* From Aho, Sethi and Ullman */

    String p;
    unsigned h = 0, g;
    for ( p = s ; *p != '\0' ; p++ )
    {
        h = (h << 4) + (*p);
        if ((g = (h & 0xf0000000)))
        {
            h = h ^ (g >> 24);
            h = h ^ g;
        }
    }
    return( h % HASH_TABLE_SIZE );
}

Private void Init_Hash_Table()
{
    Integer this_entry;

    for (this_entry = 0; this_entry < HASH_TABLE_SIZE; this_entry++)
        Symbol_Hash_Table[this_entry] = NULL;
}

#define hash_entry Symbol_Hash_Table[hash_value]

Public Object Intern_Name(name)

    String name;
{
    Integer hash_value = Hash(name);

    if (hash_entry == NULL)
    {
        hash_entry = Make_Entry(name);
        return hash_entry->Symbol;
    }
    else
    {
        Boolean at_end = FALSE;
        Entry * this_entry = hash_entry;

        while (strcmp(name, Get_Symbol_Name(this_entry->Symbol)) != 0
            && !(at_end = (this_entry->Next == NULL)))
        {
            this_entry = this_entry->Next;
        }

        /* If at end of chain, add the entry. */
        if (at_end)
        {
            this_entry->Next = Make_Entry(name);
            return this_entry->Next->Symbol;
        }
        else
        {
            return this_entry->Symbol;
        }
    }
}

/* Go through the hash table calling the operation on all its elements. */

Public    void Symbol_Hash_Iterate(operation)

void (*operation)();            /* Takes an &object. */
{
    Integer this_bucket;
    Entry * this_entry;

    for (this_bucket = 0; this_bucket < HASH_TABLE_SIZE; this_bucket++)
    {
        for (this_entry = Symbol_Hash_Table[this_bucket];
            this_entry != NULL;
            this_entry = this_entry->Next )
        {
            (*operation)(&(this_entry->Symbol));
        }
    }
}


Private Entry * Make_Entry(name)

    String name;
{
    Entry * new = (Entry *) malloc(sizeof(Entry));

    if ( new == NULL )
    {
        Panic( "Out of space in making hash entry" );
    }

    Make_Symbol(name);
    new->Symbol = Value_Register;
    new->Next = NULL;

    return new;
}


/* Push and pop State Frames. */

Public void Save()
{
    Make_State_Frame();

    Get_State_Frame_Expression(Value_Register) = Expression_Register;
    Get_State_Frame_Environment(Value_Register) = Environment_Register;
    Get_State_Frame_Function(Value_Register) = Function_Register;
    Get_State_Frame_Arguments(Value_Register) = Arguments_Register;
    Get_State_Frame_PC(Value_Register) = PC_Register;
    Get_State_Frame_State(Value_Register) = State_Register;
    Get_State_Frame_Top(Value_Register) = Arg_Stack_Ptr;


    State_Register = Value_Register;
}


Public void Restore()
{
        /* Note this does not mess with the Value_Register. */

    Expression_Register = Get_State_Frame_Expression(State_Register);
    Environment_Register = Get_State_Frame_Environment(State_Register);
    Function_Register = Get_State_Frame_Function(State_Register);
    Arguments_Register = Get_State_Frame_Arguments(State_Register);
    PC_Register = Get_State_Frame_PC(State_Register);
    Arg_Stack_Ptr = Get_State_Frame_Top(State_Register);
    State_Register = Get_State_Frame_State(State_Register);
}


Public void Initialize_Architecture()
{
    Init_Heap(Heapsize);
    Init_Hash_Table();
}