Anubis / Anubis

/* delcode.c **********************************************

                     Anubis Compiler
                Generating the delete code

**********************************************************/

#include <stdlib.h>   
#include "compil.h"
   

/* 

   For  each  type  T,  there   is  a  corresponding  ``garbage-collector  type''  denoted
   GC(T). Such types are used only internally by the system.

   By definition:

       GC(T) = T            if 0 is a regular manipulation word of type T,
       GC(T) = T + {0}      otherwise. 

   Hence, the purpose of GC-types is just to  make zero a datum of any type, at least from
   the point of  view of the garbage-collector. This means  that the garbage-collector may
   encounter the word 0 for any type.  Of course, virtual deletion of this word amounts to
   do nothing, because in any case (regular datum or not) it cannot contain a reference to
   a segment.

   This null  manipulation word is generated  by routines which, after  having detected an
   exception,  need nevertheless  to  continue to  construct  some datum  which was  under
   construction  at the time  the exception  occured. What  happens is  that the  datum is
   completed with null data, and then virtually deleted.

   This  is needed  because  the garbage-collector  is  not able  to  delete correctly  an
   incomplete datum.

   This feature is  implemented in the virtual machine, in  all instructions which perform
   virtual deletion.

*/


static Expr alt_del_code(Expr, Expr); 


   
   
/* Getting the instruction  for deleting the slots of a multiple  variable. The type given
   as the argument is the type of the data in the slots.
   */ 
static Expr get_mvar_slots_del_instr(Expr type, Expr env)
{
  Expr implem; 
  dereference_type(type,env); 
   
  implem = implems[type_implementation_id(type,env)].implem; 
 
  if      (type == type_String)        return mvar_slots_del_ptr; 
  else if (type == type_ByteArray)     return mvar_slots_del_ptr; 
  else if (type == type_Int32)         return no_instr; 
  else if (type == type_Float)         return mvar_slots_del_ptr;
  else if (type == type_Listener)      return mvar_slots_del_conn; 
  else if (is_struct_ptr_type(type))   return cons(mvar_slots_del_struct_ptr,cdr(type)); 
  else if (is_functional_type(type))   return mvar_slots_del_function; 
  else if (type == type_Nat)           return mvar_slots_del_nat; 
  else if (is_address_type(type,nil))
    switch(car(type))
      {
      case type_RAddr:
      case type_WAddr:
      case type_RWAddr:                return mvar_slots_del_conn;
      case type_Var:                   return cons(mvar_slots_del_var,get_del_code_addr(cdr(type),env));
      case type_MVar:                  return cons(mvar_slots_del_mvar,get_del_code_addr(cdr(type),env));
      case type_GAddr:                 return no_instr; 
      default: assert(0); return nil; 
      }
  else if (is_small_implem(implem))    return no_instr; 
  else if (is_mixed_implem(implem))    return mcons3(mvar_slots_del_mixed,
                                                     mixed_copy_mask(implem),
                                                     get_del_code_addr(type,env)); 
  else if (is_large_implem(implem))    return cons(mvar_slots_del,get_del_code_addr(type,env));
  else                                 return internal_error("get_mvar_slots_del_instr: unknown type",type),
                                         nil; 
}


/* Getting the  address of the delete  code for a given  type. Returns 'nil'  if no delete
   code needed for that type. 
   
   Notice that a type  may have a set of deletion instructions even  if it has no deletion
   code. For  example function types  have no deletion  code, but there are  (non trivial)
   deletion instruction (each  instruction corresponds to a 'position' of  the datum to be
   deleted):
   
          del_function
          del_stack_function
          indirect_del_function
          mvar_slots_del_function
   
   Types for which there is a deletion code are:
   
      large types
      mixed types
      Var(T)
      MVar(T)

   regardless of T. 
   */ 
Expr get_del_code_addr(Expr type, 
         Expr env)
{
  int i; 

  dereference_type(type,env); 

  if (is_primitive_type(type))
    return nil; 

  if (is_struct_ptr_type(type))
    return nil; 
   
  if (is_functional_type(type))
    return nil; 

  if (consp(type))
    {
      if (car(type) == type_RAddr ||
          car(type) == type_WAddr ||
          car(type) == type_RWAddr)
        return nil; 
    }
   
  /* the delete code may have been already computed. */ 
  for (i = 0; i < next_del_code; i++)
    {
      if (same_type(type,env,del_codes[i].type,del_codes[i].env))
        return del_codes[i].addr; 
    }

  /* The delete code has not yet been computed */ 
  {
    Expr implem = implems[type_implementation_id(type,env)].implem; 
    Expr type_sort = car(implem); 

    /* small types do not need delete code */ 
    if (type_sort == small_type)
      return nil; 

    /* register a new deletion code */ 
    if (next_del_code >= max_del_code)
      {
        max_del_code += 500; 
        del_codes = (struct Del_code_struct *)
          reallocz(del_codes,max_del_code*sizeof(struct Del_code_struct));       
      }
    i = next_del_code; 
    next_del_code++; 
    del_codes[i].type = save(type); 
    del_codes[i].env = save(env); 
    del_codes[i].addr = new_addr_name(labs_del_code,i); 

    /* The delete code for a type T is a not regular subroutine. When called the stack is:

    datum to be deleted
    return address
    ...

    and R must not be modified by  the deletion procedure.  This datum to be deleted is
    a pointer  for a large type, and  a mixture of a  pointer and an index  for a mixed
    type.

    For large and mixed types, the first thing to do is to determine the alternative of
    the  datum.  This  is  achieved  by  (del_index_direct) for  mixed  types,  and  by
    (del_index_indirect)  for large  types.  These  instruction put  the  index of  the
    alternative of the datum  into I. Furthermore, the index is masked  out for a mixed
    type. Also the  instruction duplicates the pointer on top of  stack. Then the stack
    is:

    pointer to data segment
    pointer to data segment
    return address
    ...

    Duplicating  the pointer is  needed, because  we need  both to  walk into  the data
    segment, and to free it at the end.

    Next, we have a 'switch' which branches to the code for the right alternative.

    For  a small  alternative, the  code  is just  a 'invalid'  instruction, since  the
    deletion code is never  called for a small datum. If this  happens, this means that
    the code is corrupted, and this will stop the virtual machine.

    For a mixed or a large alternative, we need a deletion code which virtually deletes
    all components in the data segment. It is produced by another procedure below. This
    code increments the pointer  on top of stack.  When this is  done, the data segment
    is freed (by 'free_seg_1') which finds the pointer just below the top of stack, the
    stack pointer is decremented by 2, and a '(ret . 1)' is performed.
    */ 

    if (consp(type) && car(type) == type_Var)
      {
        /* The deletion code is as follows:

        label ?:                           v r ...
        free_var_seg                     c r ...   free var segment and replace it by its
        content
        del_stack_instr(T)                 r ...
        ret                                  ...
        */
        Expr result = nil; 
   
        result = list6(cons(header,new_string("* * * dynamic variable deletion code * * *")),
                       cons(label,del_codes[i].addr),
                       mcons3(context,list2(cons(argument,type),
                                            cons(ret,new_integer(1))),
                              env),
                       free_var_seg,
                       get_del_stack_instr(cdr(type),env,new_integer(0)),
                       cons(ret,new_integer(1))
                       );
   
        del_codes[i].offline_code = save(result); 
      }

    else if (consp(type) && car(type) == type_MVar)
      {
        /* The deletion code is as follows: 
           1. get the number 'n' of slots
           2. virtually delete each slot
           3. delete the handlers table
           4. delete the segment
   
           label ?:                           mv r ...
           push_mvar_length               n mv r ...
           mvar_slots_del_? ...             mv r ... 
           free_mvar_seg                       r ...
           ret                                   ...
   
           where addr is the address of deletioncode for the data in the slots. 
   
           If there is no deletion code for the data in the slots, the deletion code for the
           multiple variable is:
   
           label ?:                           mv r ...
           free_mvar_seg                       r ...
           ret                                   ...
        */
        Expr result; 
        Expr slots_del_code_addr = get_del_code_addr(cdr(type),env);
   
        if (slots_del_code_addr == nil)
          {
            result = list5(cons(header,new_string("* * * multiple dynamic variable deletion code * * *")),
                           cons(label,del_codes[i].addr),
                           mcons3(context,list2(cons(argument,type),
                                                cons(ret,new_integer(1))),
                                  env),
                           free_mvar_seg,
                           cons(ret,new_integer(1))); 
          }
        else
          {
            result = list7(cons(header,new_string("* * * multiple dynamic variable deletion code * * *")),
                           cons(label,del_codes[i].addr),
                           mcons3(context,list2(cons(argument,type),
                                                cons(ret,new_integer(1))),
                                  env),
                           push_mvar_length, 
                           get_mvar_slots_del_instr(cdr(type),env),
                           free_mvar_seg,
                           cons(ret,new_integer(1))); 
          }
        del_codes[i].offline_code = save(result); 
      }
   
    else
      {
        Expr alts = cdr3(implem); 
        Expr case_addrs = nil; 
        Expr aux; 
        Expr result = nil; 
        Expr alts_codes = nil; 

        /* get a list of addresses for cases */ 
        aux = alts; 
        while (consp(aux))
          {
            case_addrs = cons(new_addr_name(labs_none,0),case_addrs); 
            aux = cdr(aux); 
          }

        /* get the codes for alternatives */ 
        while (consp(alts))
          {
            alts_codes = cons(alt_del_code(car(alts),
                                           env),
                              alts_codes); 
            alts = cdr(alts);  
          }

        /* record codes for alternatives with their labels */ 
        aux = case_addrs;
        while (consp(alts_codes))
          {
            result = cons(cons(label,car(aux)),append(car(alts_codes),result)); 
            alts_codes = cdr(alts_codes); 
            aux = cdr(aux); 
          }

        /* add a switch */ 
        result = cons(cons(_switch,reverse(case_addrs)),result); 

        /* add the 'index' instruction */ 
        if (type_sort == large_type)
          {
            result = cons(del_index_indirect,result); 
          }
        else
          {
            result = cons(del_index_direct,result); 
          }

        /* if deleting a monitoring ticket insert a 'remove_monitor' */ 
        if (consp(type) && car(type) == app_ts && second(type) == pdstr_MonitoringTicket)
          result = cons(remove_monitor, 
                        result); 
   
        /* add the label of the subroutine */ 
        result = mcons4(cons(header,new_string("* * * deletion code * * *")),
                        cons(label,del_codes[i].addr),
                        mcons3(context,list2(cons(argument,type),
                                             cons(ret,new_integer(1))),
                               env),
                        result); 

        /* store the offline code */ 
        del_codes[i].offline_code = save(result); 
      }

    /* return address of deletion code */ 
    return del_codes[i].addr; 
  }
}




/* Making the deletion code for a  component. This function takes the implementation id of
   the component as its unique argument. It returns a list of instructions:
   
      nil                      for small components and Int32
      (indirect_del_ptr)       for String, ByteArray ...
      (indirect_del_conn)
      (indirect_del_var . <addr>)
      (indirect_del_struct_ptr . <id>)
      (indirect_del_function)
      (indirect_del_nat)
      (indirect_del . <addr>)
      (indirect_del_mixed <mask> . <addr>)
      (indirect_del_mvar . <addr>)
   
   */ 
Expr component_del_code(int id)
{
  /* id is an index into implems */ 

  Expr implem = implems[id].implem; 

  assert(id < next_implem); 

  if (implem == type_String)
    return list1(indirect_del_ptr); 
  if (implem == type_ByteArray)
    return list1(indirect_del_ptr); 
  if (implem == type_Int32)
    return nil; 
  if (implem == type_Float)
    return list1(indirect_del_ptr); 
  if (implem == type_Listener)
    return list1(indirect_del_conn); 

  if (is_address_type(implem,nil))
    switch(car(implem))
      {
      case type_RAddr:
      case type_WAddr:
      case type_RWAddr:
        return list1(indirect_del_conn); 
        break; 
      case type_Var:
        {
          Expr del_code_addr = get_del_code_addr(implems[id].type,implems[id].env);
          /* del_code_addr is the address of deletion code for type 'Var(T)', not for type
             'T'. It is never 'nil'. */ 
          assert(del_code_addr != nil); 
          return list1(cons(indirect_del_var,del_code_addr));
        }
        break; 
   
      case type_MVar:
        {
          /* del_code_addr is  the address  of deletion code  for type 'MVar(T)',  not for
             type 'T'. It is never 'nil'. */ 
          Expr del_code_addr = get_del_code_addr(implems[id].type,implems[id].env);
          assert(del_code_addr != nil); 
          return list1(cons(indirect_del_mvar,del_code_addr));
        }
        break; 
   
      case type_GAddr:
        return nil; 
        break; 
   
      default:
        assert(0);  
      }

  if (is_struct_ptr_type(implem))
    return list1(cons(indirect_del_struct_ptr,cdr(implem))); 
   
  if (is_functional_type(implem))  /* functional type */ 
    return list1(indirect_del_function); 

  if (implem == type_Nat) 
    return list1(indirect_del_nat); 

  if (!consp(implem))
    {
      internal_error("Cannot understand implementation",implem);  
    }
   
  switch(car(implem))
    {
    case small_type: return nil; /* nothing to delete */ 

    case large_type:
      {
        /* we have  to delete virtually  the datum whose  manipulation word is  pointed to
           from the top of stack.  This word is a pointer, except in the mixed case, where
           it may be a manipulation word of a small datum, or a pointer glued to an index.
           We use a indirect_del or indirect_del_mixed instruction. */ 
        return list1(cons(indirect_del,
                          get_del_code_addr(implems[id].type,implems[id].env))); 
      }
    case mixed_type:
      return list1(mcons3(indirect_del_mixed,
                          mixed_copy_mask(implem),
                          get_del_code_addr(implems[id].type,implems[id].env))); 
   
    default:
      assert(0); 
      return nil;
    }
}




/* Making the deletion code for an alternative */ 
static Expr alt_del_code(Expr alt_implem,
    Expr env)
{
  int code_offset = 5; 

  switch(car(alt_implem))
    {
    case small_alt: return list1(invalid);

    case mixed_alt:
      code_offset--; 
    case large_alt:
      {
        /* get geometry of components in reverse order */ 
        Expr geoms = reverse(cdr(alt_implem)); 
        /* each geometry has the form: (<imp> <offset> . <width>) */ 

        Expr result = list3(free_seg_1,
                            pop2,
                            cons(ret,new_integer(1)));
        Expr prevw; 

        while (consp(geoms))
          {
            Expr util;
   
            if (!consp(cdr(geoms)))
              prevw = new_integer(code_offset); 
            else
              prevw = cdr2(car(cdr(geoms))); 
   
            util = append(component_del_code(integer_value(car(car(geoms)))),
                          result);
   
            if (car(util) != free_seg_1)
              result = cons(cons(increment_del,prevw),
                            util);
            else 
              result = util; 
   
            geoms = cdr(geoms); 
          } 


        return result; 
      }
    default:
      assert(0);
      return nil; 
    }
}