Anubis / Anubis

/* implem.c ******************************************************************************

                                     The Anubis Compiler. 
                           Computing the implementation of types. 

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

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

/* 
   Here  we  compute type  implementations.   For  a given  'actual'  type  (i.e.  a  type
   instance, not a type scheme), we compute a list like this one:

     (small_type <nalt> <iw> <alt geom> ... <alt geom>)
     (mixed_type <nalt> <iw> <alt geom> ... <alt geom>)
     (large_type <nalt> <iw> <alt geom> ... <alt geom>)

   depending on the sort (small, mixed or large) of the type implementation. 

   <nalt> is the number of alternatives, <iw> is the bit width of the index (number of the
   alternative).  For a mixed type, <iw> is always 2.

   Each  <alt  geom> has  one  of  the  following forms,  depending  on  the sort  of  the
   alternative:

     (small_alt (<imp> <offset> . <width>) ... (<imp> <offset> . <width>))
     (mixed_alt (<imp> <offset> . <width>) ... (<imp> <offset> . <width>))
     (large_alt (<imp> <offset> . <width>) ... (<imp> <offset> . <width>))

   where <imp> (Lisp_like integer) is the id of the implementation of the component.

   <offset>  and <width>  have a  different interpretation  depending on  the sort  of the
   alternative.

   Note: small types may have only small alternatives
         mixed types may have small and mixed alternatives
         large types may have only large alternatives

   For a small alternative <offset> and <width> represent:

     <offset> number of bits below argument bit field (including index field)
     <width>  width of bit field (in bits)

   For a mixed alternative:

     <offset> number of bytes above reference counter of data segment
     <width>  width of fields in bytes

   For a large alternative:

     <offset> number of bytes above index field in data segment
     <width>  width of field in bytes

   For a primitive  type, the implementation is  the tag of the type  itself. For example,
   type_String for type_String.

   For an address type like (type_RAddr . T), the implementation is (type_RAddr . I) where
   I is the implementation of T.
   
*/ 

/* Computing implementations of alternatives (<alt geom>s). */ 
static Expr small_alt_implem(Expr, int, Expr); 
static Expr mixed_alt_implem(Expr, int, Expr); 
static Expr large_alt_implem(Expr, int, Expr); 

static int new_type_implementation(Expr type,    /* type */ 
                                   Expr env);    /* environment for unknowns */ 

/* Computing the type  implementation id for a type.  If the  type is already implemented,
   the id  of this interpretation is  returned. Otherwise, the type  is first implemented,
   and the id of this new interpretation is returned. */ 
int type_implementation_id(Expr type, Expr env)
{
  int i; 

  /* try to find it among already computed implementations. */ 
  for (i = 0; i < next_implem; i++)
    if (same_type(type,env,implems[i].type,implems[i].env))
      return i; 

  /* if not found, construct the implementation. */ 
  return new_type_implementation(type,env); 
}


   
/* Now, we compute  the implementation for a type. The  type is given as a  pair made of a
   type expression, and an environment giving  the values of the type parameters which may
   occur in the type expression. */ 
static int new_type_implementation(Expr type,    /* type */ 
                                   Expr env)     /* environment for unknowns */ 
{
  Expr tname = nil; 
  int type_id; 
  Expr parms; 
  Expr parms_values = nil; 
  Expr p_env; 
  Expr alts; 
  Expr alt_widths; 
  Expr alts_implem; 
  Expr aux; 
  int nalt; 
  int iw, w; 
  int max_alt_width; 
  Expr type_sort; 
  int implem_id; 

  dereference_type(type,env); 

  assert(!(is_user_type_variable(type))); 
  assert(!(is_primitive_type(type))); 

  /* Now the  interpretation has not yet  been computed. Initiate  a new slot in  order to
     avoid an infinite loop */ 
  if (next_implem >= max_implem)
    {
      max_implem += 500; 
      implems = (struct Implem_struct *)reallocz(implems,
                                                 max_implem*sizeof(struct Implem_struct)); 
    }

   
  implems[next_implem].type = save(type); 
  implems[next_implem].env = save(env); 
  implems[next_implem].implem = invalid; 
  implems[next_implem].addr = new_addr_name(labs_implem,next_implem); 
  implems[next_implem].offline_code = nil; 
  implem_id = next_implem;  
  next_implem++; 
   
  /* Note: we do not compute the offline  pseudo code in this function. This is because it
     would not work for the following reason.

     When computing an interpretation of a recursive type, the entry in 'implems' for this
     type is created (at index 'implem_id' above) but still invalid, because both 'implem'
     and 'offline_code' fields are not computed, as visible from the previous lines.

     This  is  not a  problem  for computing  the  implementation,  because references  to
     implementations within implementations refer to indices in 'implems' not to the value
     of the 'implem' field.

     On the contrary, if we wanted to compute the 'offline_code' field here, we would need
     the value of the 'implem' field, which may not yet be computed.

     The problem is solved by computing  the 'offline_code' field only when needed, in the
     function 'scode_from_label' in 'vminstr.c'. This occurs only when all implementations
     are computed. */ 

#if 1  
  if (consp(type) && car(type) == type_Var)
    {
      /* Var(T) is implemented as a large type like this:
   
      (large_type 1 0 (large_alt (<imp> 4 . 4)))
   
      where <imp> is the implementation id for T. */
    
      Expr imp = type_implementation_id(cdr(type),env); 
   
      implems[implem_id].implem = 
        save(list4(large_type,
                   new_integer(1),
                   new_integer(0),
                   list2(large_alt,
                         mcons3(new_integer(imp),new_integer(4),new_integer(4)))));
   
      return implem_id;
    }
#endif   
   
  if (is_functional_type(type))   
    /* type = (functype <types> . <type>). We construct (functype <implems> . <implem>)*/ 
    {
      Expr aux = second(type); 
      Expr args_implems = nil; 
   
      while (consp(aux))
        {
          args_implems = cons(new_integer(type_implementation_id(car(aux),env)),args_implems); 
          aux = cdr(aux); 
        }
   
      implems[implem_id].implem = save(mcons3(car(type),
                                              reverse(args_implems),
                                              new_integer(type_implementation_id(cdr2(type),env)))); 
      return implem_id;
    }

  if (is_address_type(type))
    {
      switch (car(type))
        {
        case type_RAddr:
        case type_WAddr:
        case type_RWAddr:
        case type_GAddr:
        case type_MVar:
          implems[implem_id].implem = save(cons(car(type),
                                                new_integer(type_implementation_id(cdr(type),env)))); 
          return implem_id;

        default: 
          internal_error("Cannot implement address type",type);
          return nil; 
        }
    }

  if (is_struct_ptr_type(type))
    {
      implems[implem_id].implem = save(type); 
      return implem_id; 
    }

  /* from  here, the  type is  defined. If  the  type has  just one  alternative with  one
     component, its a  copy of the type  of the component, and should  be implemented like
     the  component. However,  in this  version 1  of the  Anubis compiler,  it's  not the
     case. Such  a type is implemented  as a small type  if the component has  a bit width
     strictly  less  than  mw,  and  as  a  mixed  type  otherwise.   See  'HostImage'  in
     predefined.anubis for an example. */ 

  /* get name of type (or of type scheme) and values of parms */ 
  if (is_string(type))
    {
      tname = type;
      parms_values = nil; 
    }
  else if (consp(type))
    {
      assert(car(type) == app_ts); 
      tname = second(type); 
      parms_values = cdr(cdr(type)); 
    }
  else 
    {
      internal_error("cannot find name of type",type); 
    }


  /* get type id */ 
  type_id = integer_value(get_type_name_id(tname)); 

  /* get list of parameters */ 
  parms = types[type_id].parms; 

  /* construct an association list ((parm . value) ...) */ 
  p_env = nil; 

  while (consp(parms))
    {
      p_env = cons(cons(car(parms),
                        car(parms_values)),
                   p_env);
      parms = cdr(parms); 
      parms_values = cdr(parms_values);  
    }

  /* get some informations about the type */ 
  alts = get_alts(types[type_id].file_name,type,env,0); 
  nalt = length(alts); 
  iw = logar2(nalt); 

  /* subtitute parms in alternatives */ 
  alts = substitute(alts,p_env); 

  /* compute maximal width of alternatives and store alternatives
     widths */ 
  alt_widths = nil; 
  max_alt_width = 0; 
  aux = alts; 
  while (consp(aux))
    {
      w = alt_width(car(aux),env,type); 

      alt_widths = cons(new_integer(w),alt_widths); 
      max_alt_width =
        sup(max_alt_width,w);
      aux = cdr(aux); 
    }
  alt_widths = hard_reverse(alt_widths);   /* used below for mixed
                                              types */ 


  /* compute the sort of the type */ 
   
#if 0   
  if (nalt == 1 && max_alt_width == mw /* && length(car(alts)) == 2 */ )
    { /* do for copy types */ 
      type_sort = mixed_type;
    } else 
#endif
   
      if (iw + max_alt_width <= mw)
        type_sort = small_type; 
      else if (nalt <= 4)
        type_sort = mixed_type; 
      else 
        type_sort = large_type; 

  /* force iw = 2 for mixed types */ 
  if (type_sort == mixed_type) iw = 2;    
   
  /* compute alternatives implementations */ 
  alts_implem = nil; 

  if (type_sort == small_type)
    {
      while (consp(alts))
        {
          alts_implem =
            cons(small_alt_implem(cdr(car(alts)),  /* ((<type> . <var>) ...) */ 
                                  iw, 
                                  env),
                 alts_implem); 
          alts = cdr(alts); 
        }
    }

  else if (type_sort == mixed_type)
    {
      while (consp(alts))
        {
          if (integer_value(car(alt_widths)) < mw)
            {
              /* alternative is small */ 
              alts_implem = 
                cons(small_alt_implem(cdr(car(alts)),
                                      iw,
                                      env),
                     alts_implem); 
            }
          else
            {
              /* alternative is mixed */ 
              alts_implem =
                cons(mixed_alt_implem(cdr(car(alts)), 
                                      iw, 
                                      env),
                     alts_implem); 
            }
          alt_widths = cdr(alt_widths); 
          alts = cdr(alts); 
        }
    }

  else /* type_sort == large_type */  
    {
      assert(type_sort == large_type); 
      while (consp(alts))
        {
          alts_implem =
            cons(large_alt_implem(cdr(car(alts)), 
                                  iw, 
                                  env),
                 alts_implem); 
          alts = cdr(alts); 
        }
    }

   
  /* return type implementation */
  implems[implem_id].implem = save(mcons4(type_sort,
                                          new_integer(nalt), 
                                          new_integer(iw), 
                                          hard_reverse(alts_implem))); 
  return implem_id;
}


   

/* implementing a small alternative */ 
static Expr small_alt_implem(Expr factors,   /* ((<type> . <var>) ...) */
        int iw, 
        Expr env)
{
  int offset = iw; 
  int w;
  Expr comp_id;  
  Expr result = nil; 

  while(consp(factors))
    {
      comp_id = type_implementation_id(car(car(factors)),env); 
   
      w = type_width(car(car(factors)),env); 
      result = cons(mcons3(new_integer(comp_id),new_integer(offset),new_integer(w)),result); 
      offset += w; 
      factors = cdr(factors); 
    }
  result = cons(small_alt,hard_reverse(result)); 
   
  return result; 
}




/* implementing a mixed alternative */ 
static Expr mixed_alt_implem(Expr factors,
        int iw, 
        Expr env)
{
  int offset = 0; 
  int bw; 
  Expr comp_id; 
  Expr result = nil; 

  while (consp(factors))
    {
      comp_id = type_implementation_id(car(car(factors)),env); 
      bw = byte_type_width(car(car(factors)),env); 
      result = cons(mcons3(new_integer(comp_id),new_integer(offset),new_integer(bw)),result);
      offset += bw; 
      factors = cdr(factors); 
    }
  return cons(mixed_alt,hard_reverse(result)); 
}



/* implementing a large alternative */ 
static Expr large_alt_implem(Expr factors, 
        int iw, 
        Expr env)
{
  int offset = 0; 
  int bw; 
  Expr comp_id; 
  Expr result = nil; 

  while (consp(factors))
    {
      comp_id = type_implementation_id(car(car(factors)),env); 
      bw = byte_type_width(car(car(factors)),env);
      result = cons(mcons3(new_integer(comp_id),new_integer(offset),new_integer(bw)),result);
      offset += bw; 
      factors = cdr(factors); 
    }
  return cons(large_alt,hard_reverse(result)); 
}



static int small_implem_byte_width(Expr implem)
{
  int result; 
  int alt_width; 
  int max_alt_width = 0;
  int index_width = integer_value(third(implem));
  Expr alt;

  assert(car(implem) == small_type); 

  implem = cdr3(implem); /* ((small_alt (<imp> <offset> . <width>) ...) ...) */ 

  /* bit width of type is the max of <offset>+<width> */ 
  while (consp(implem))
    {
      alt_width = 0; 
      assert(car(car(implem)) == small_alt); 
      alt = cdr(car(implem)); /* ((<imp> <offset> . <width>) ...) */ 
      while (consp(alt))
 {
   alt_width += integer_value(cdr2(car(alt))); 
   alt = cdr(alt); 
 }
      max_alt_width = sup(alt_width,max_alt_width); 
      implem = cdr(implem); 
    }
  result = max_alt_width + index_width; 
  assert(result <= mw); 

  if      (result == 0) return 0; 
  else if (result <= 8) return 1; 
  else if (result <= 16) return 2; 
  else return 4; 
}


#if 0
/* get the symbolic address of an implementation */ 
static Expr addr_of_implem(Expr implem)
{
  int i; 
  for (i = 0; i < next_implem; i++)
    if (equal(implem,implems[i].implem))
      return implems[i].addr; 
  internal_error("Cannot find symbolic address of implementation",implem); 
  return nil; 
}
#endif

   
/* small types descriptions: They are lists on integers defined by the following grammar: 
   
   <na> :=   8 bits integer (number of alternatives)
   <iw> :=   8 bits integer (index width)
   <nc> :=   8 bits integer (number of components)
   
   <small type descr> :=    <iw> <na> <alt descr> ...   (as many <alt descr> as <na>)
   
   <alt descr> := <nc> <small type descr> ...   (as many as <nc>)

   Hence a small type description is a list of 8 bits integers. These integers become part
   of  serialization/unserialization instructions  like 'type_8',  'type_16'  etc...  (see
   'vminstr.c'). One question is: `how long this  description may be ?'. The answer is not
   so obvious !  Remember that the number  of alternatives is limited to 256, and likewise
   for the  number of components in  an alternative.  Now, if  'iw' is the  number of bits
   required for the index,  the total width of the components is at  most: 'bw - iw' where
   'bw' is  the bit width of  our type.  So, let  'dl(iw,bw)' be the maximal  length for a
   description of a type of index width 'iw' and bit width 'bw'. We have,
   
                       dl(iw1,bw1) =< 2 + (2^iw1 * (1 + bl(iw2,bw1 - iw1)))
   

   
                 
   
   The next function computes the description for a small type.
*/

static Expr small_type_description(Expr implem); 
   
static Expr small_alt_description(Expr geom)
{
  Expr result; 
  int n; 

  assert(car(geom) == small_alt); 
  geom = cdr(geom); 
  n = length(geom); 
   
  result = nil; 
  while (consp(geom))
    {
      /* car(geom) = (<imp> <offset> . <width>) */ 
      result = append(result,small_type_description(implems[integer_value(car(car(geom)))].implem)); 
      geom = cdr(geom); 
    }
  return cons(new_integer(n),result); 
}
   
   
static Expr small_alts_descriptions(Expr geoms)
{
  Expr result = nil; 
   
  while (consp(geoms))
    {
      result = append(result,small_alt_description(car(geoms))); 
      geoms = cdr(geoms); 
    }
  return result; 
}
   
   
static Expr small_type_description(Expr implem)   
{  

  //debug(implem); 
  assert(car(implem) == small_type);       // type_Int32 found here !!!
   
  /* 
   This is because if width(type_Int32) is 32, a copy type of Int32 is seen as small ! 
   Now, width(Int32) is mw+1 (like for pointers); see typewidth.c. 
   */ 
   
  return mcons3(third(implem),   // <iw>
                second(implem),  // <na>
                small_alts_descriptions(cdr3(implem))); 
}
   

#if 0   
static Expr indirect(Expr instr)
{
  switch (instr)
    {
#define item(n)  case n: return indirect_##n; 
    address_types_list
#undef item
    default: internal_error("Cannot compute indirect version of",instr); anb_exit(1); 
    }
  return nil; 
}
#endif

   
static void msg_type_not_serializable(int implem_id)   
{
  fprintf(errfile,
          msgtext_type_not_serializable[language]); 
  show_type(errfile,implems[implem_id].type,implems[implem_id].env); 
  fprintf(errfile,"\n\n"); 
  anb_exit(1); 
}
   
   
static Expr get_indirect_implem_pseudo_instr(int implem_id)
{
  Expr implem = implems[implem_id].implem; 

  if      (implem == type_String)        return indirect_type_String; 
  else if (implem == type_ByteArray)     return indirect_type_ByteArray; 
  else if (implem == type_Int32)         return indirect_type_Int32; 
  else if (implem == type_Float)         return indirect_type_Float; 
  else if (is_small_implem(implem))
    {
      int w = small_implem_byte_width(implem); 

      if      (w == 0) return indirect_type_0; 
      else if (w == 1) return cons(indirect_type_8,small_type_description(implem)); 
      else if (w == 2) return cons(indirect_type_16,small_type_description(implem)); 
      else if (w == 4) return cons(indirect_type_32,small_type_description(implem)); 
      else    assert(0); 
      return nil; 
    }
  else if (is_mixed_implem(implem))
    {
      /* implem (mixed_type <nalt> <iw> <alt geom> ...) */ 
      return mcons3(indirect_type_mixed,
      mixed_copy_mask(implem),
      implems[implem_id].addr); 
    }
  else if (is_large_implem(implem))
    {
      return cons(indirect_type_large,
    implems[implem_id].addr); 
    }
  else 
    {
      msg_type_not_serializable(implem_id); 

      return nil; 
    }
}


   
/* return the byte size of the data segment for an alternative (mixed or large) */ 
static int seg_size(Expr alt_geom)
{
  /* alt_geom =     (mixed_alt (<imp> <offset> . <width>) ... (<imp> <offset> . <width>))
                    (large_alt (<imp> <offset> . <width>) ... (<imp> <offset> . <width>))
  */
  int result = 4;     /* counter */  
  Expr alt_sort = car(alt_geom); 
  assert(alt_sort == mixed_alt || alt_sort == large_alt); 

  if (alt_sort == large_alt) result++;   /* large index */ 

  alt_geom = cdr(alt_geom);   /* keep only components */ 
  while (consp(alt_geom))
    {
      result += integer_value(cdr2(car(alt_geom)));    /* <width> in bytes */ 
      alt_geom = cdr(alt_geom); 
    }
  return result; 
}


static Expr alt_pseudo_code(Expr alt_geom, Expr index_width, int index)
{
  Expr result; 
  Expr alt_sort = car(alt_geom); 

  if (alt_sort == small_alt)
    {
      return list1(mcons4(type_small_alt,
                          index_width,
                          new_integer(index),
                          small_alt_description(alt_geom))); 
    }

  assert(alt_sort == mixed_alt || alt_sort == large_alt); 

  result = list1(cons(alt_sort == mixed_alt ? mixed_alt_begin : large_alt_begin,
        new_integer(seg_size(alt_geom))));
  alt_geom = cdr(alt_geom); 
  while (consp(alt_geom))
    {
      Expr ind_instr = get_indirect_implem_pseudo_instr(integer_value(car(car(alt_geom)))); 
      if (consp(ind_instr) && 
          car(ind_instr) != indirect_type_8 && 
          car(ind_instr) != indirect_type_16 &&
          car(ind_instr) != indirect_type_32 &&
          car(ind_instr) != type_small_alt)
 /* This case may happen only if the component has address, mixed or large type. */ 
        result = mcons3(pop1,ind_instr,result);
      else
 result = cons(ind_instr,result);

      alt_geom = cdr(alt_geom); 
    }
  result = cons(cons(alt_sort == mixed_alt ? mixed_alt_end : large_alt_end,
       new_integer(index)),
                result);   /* mark the end of the alternative */ 
  return hard_reverse(result); 
}



static Expr alts_pseudo_code(Expr labels,
                             Expr index_width,    /* not always significant */ 
                             Expr alt_geoms,
                             Expr end_label)
{
  Expr result = nil; 
  int n = length(labels); 

  labels = reverse(labels); 
  alt_geoms = reverse(alt_geoms); 

  while (consp(labels))
    {
      n--; 
      result = cons(cons(label,car(labels)),
      append(alt_pseudo_code(car(alt_geoms),index_width,n),
      cons(cons(jmp,end_label),
    result))); 

      labels = cdr(labels); 
      alt_geoms = cdr(alt_geoms); 
    }
  assert(alt_geoms == nil); 

  return result; 
}



/* making the complete offline pseudo-code for a given type */ 
Expr offline_pseudo_code(int implem_id)
{
  Expr implem = implems[implem_id].implem; 
  Expr type = substitute(implems[implem_id].type,implems[implem_id].env);
  Expr result = list2(swap, 
                      cons(ret,new_integer(1))); 

  if      (implem == type_String)          result = cons(type_String,result); 
  else if (implem == type_ByteArray)       result = cons(type_ByteArray,result); 
  else if (implem == type_Int32)           result = cons(type_Int32,result); 
  else if (implem == type_Float)           result = cons(type_Float,result); 
  else if (is_small_implem(implem))
    {
      int w = small_implem_byte_width(implem); 

      if      (w == 0) result = cons(type_0,result); 
      else if (w == 1) result = cons(cons(type_8,small_type_description(implem)),result); 
      else if (w == 2) result = cons(cons(type_16,small_type_description(implem)),result); 
      else if (w == 4) result = cons(cons(type_32,small_type_description(implem)),result); 
      else    assert(0); 
    }
  else if (is_mixed_implem(implem))
    {
      /* implem = (mixed_type <nalt> <iw> <alt geom> ...) */ 
      Expr labels = nil; 
      Expr end_label = new_addr_name(labs_none,0); 
      Expr aux; 
      int nalt = integer_value(second(implem)); 
      while (nalt--) labels = cons(new_addr_name(labs_none,0),labels); 
      aux = labels;

      result = cons(mcons3(type_mixed_switch,mixed_copy_mask(implem),labels),
      append(alts_pseudo_code(labels,third(implem),cdr3(implem),end_label),
      cons(cons(label,end_label),
    result)));
    }
  else if (is_large_implem(implem))
    {
      /* implem = (large_type <nalt> <iw> <alt geom> ...) */ 
      Expr labels = nil; 
      Expr end_label = new_addr_name(labs_none,0); 
      Expr aux; 
      int nalt = integer_value(second(implem)); 
      while (nalt--) labels = cons(new_addr_name(labs_none,0),labels); 
      aux = labels;

      result = cons(cons(type_large_switch,labels),
      append(alts_pseudo_code(labels,third(implem),cdr3(implem),end_label),
      cons(cons(label,end_label),
    result)));
    }
  else
    {
      msg_type_not_serializable(implem_id); 
   
      /*
      internal_error("Cannot generate offline pseudo-code for",type);
      */ 
      anb_exit(1); 
    }

  result = mcons4(cons(header,new_string("* * * type implementation pseudo code * * *")),
                  cons(label,implems[implem_id].addr),
                  mcons3(context,
                         list2(cons(argument,type),
                               cons(ret,new_integer(1))),
                         nil),
                  result); 
   
  return result; 
}