/* Loading of .O files */

#include "params.h"
#include "gambit.h"
#include "struct.h"
#include "os.h"
#include "mem.h"
#include "strings.h"
#include "opcodes.h"
#include "run.h"
#include "stats.h"
#include "emul.h"


/*---------------------------------------------------------------------------*/


struct patch_rec {
  struct patch_rec *next; /* next entry in the patch list    */
  long index;             /* index to value's source         */
  SCM_obj *loc;           /* pointer to location to patch to */
  };

typedef struct patch_rec *PATCH_PTR;


char *alloc_ptr, *read_bot, *read_top, *load_bot, *load_top, *load_ptr;
SCM_obj *object;
PATCH_PTR free_patches, prim_patches;
char *filename, *procedure_name;


char *alloc( len )
long len;
{ long len2 = ceiling8( len );
  if (alloc_ptr-len2 < read_top)
  { os_err = "Load memory overflow"; return NULL; }
  alloc_ptr -= len2;
  return alloc_ptr;
}


long begin_load()
{ free_patches = NULL;
  prim_patches = NULL;
  read_bot = pstate->heap_old;
  alloc_ptr = read_bot + (pstate->heap_mid - pstate->heap_bot);
  read_top = read_bot;
  object = (SCM_obj *)alloc( sizeof(SCM_obj) * (long)MAX_NB_OBJECTS_PER_FILE );
  return (object == NULL);
}


long end_load()
{ PATCH_PTR patch = prim_patches;
  while (patch != NULL)
  { SCM_obj val = sstate->globals[patch->index].value;
    if (val == (long)SCM_unbound)
    { os_err = string_append( "Undefined primitive, ",
                              global_name(patch->index) );
      return 1;
    }
    *(patch->loc) += val; /* patch up reference to the primitive */
    patch = patch->next;
  }
  return 0;
}


long eof()
{ os_err = "Premature EOF";
  return 1;
}


#define load_long_word(var) \
{ if (load_ptr+4>load_top) return eof(); var = *(long *)load_ptr; load_ptr += 4; }

#define load_word(var) \
{ if (load_ptr+2>load_top) return eof(); var = *(short *)load_ptr; load_ptr += 2; }

#define load_words( n, ptr ) \
{ register long i = (n); register short *pt = (ptr); \
  if (load_ptr + i*2 > load_top) return eof(); \
  while (i>0) { *(pt++) = *(short *)load_ptr; load_ptr += 2; i--; } \
}


long load_string( str )
char **str;
{ *str = load_ptr;
  while (*(load_ptr++) != '\0') if (load_ptr > load_top) return eof();
  load_ptr = (char *)ceiling2( load_ptr );
  if (load_ptr > load_top) return eof();
  return 0;
}


long skip_string( offset )
long *offset;
{ *offset = load_ptr - load_bot;
  while (*(load_ptr++) != '\0') if (load_ptr > load_top) return eof();
  load_ptr = (char *)ceiling2( load_ptr );
  if (load_ptr > load_top) return eof();
  return 0;
}


/*---------------------------------------------------------------------------*/


long nb_objects, highest_object, nb_symbols;
PATCH_PTR object_patches, M68020_patches, M68881_patches;


long add_object( value )
SCM_obj value;
{ long i = nb_objects++;
  if (i + nb_symbols >= (long)MAX_NB_OBJECTS_PER_FILE)
  { os_err = "Too many objects in an object file"; return 1; }
  object[i] = value;
  return 0;
}


long add_patch( list, index, loc )
PATCH_PTR *list;
long index;
SCM_obj *loc;
{ PATCH_PTR patch;
  if (free_patches != NULL)
  { patch = free_patches;
    free_patches = free_patches->next;
  }
  else
  { patch = (PATCH_PTR)alloc( (long)sizeof(struct patch_rec) );
    if (patch == NULL) return 1;
  }
  patch->next  = *list;
  patch->index = index;
  patch->loc   = loc;
  *list        = patch;
  return 0;
}


long add_prim_patch( index, loc )
long index;
SCM_obj *loc;
{ return add_patch( &prim_patches, index, loc );
}


long add_object_patch( index, loc )
long index;
SCM_obj *loc;
{ if (index + nb_symbols >= (long)MAX_NB_OBJECTS_PER_FILE)
  { os_err = "Object reference too big"; return 1; }
  if (index > highest_object) highest_object = index;
  return add_patch( &object_patches, index, loc );
}


long patchup_M68020_emul_code()
{ PATCH_PTR patch = M68020_patches;
  while (patch != NULL)
  { PATCH_PTR next = patch->next;
    if (emul_M68020_instr( (short *)patch->loc )) return 1;
    patch->next = free_patches;
    free_patches = patch;
    patch = next;
  }
  return 0;
}


long patchup_M68881_emul_code()
{ PATCH_PTR patch = M68881_patches;
  while (patch != NULL)
  { PATCH_PTR next = patch->next;
    if (emul_M68881_instr( (short *)patch->loc )) return 1;
    patch->next = free_patches;
    free_patches = patch;
    patch = next;
  }
  return 0;
}


long load_sym( i, loc )
short i;
SCM_obj *loc;
{ if (i == INDEX_MASK)
  { char *name;
    long j = nb_symbols++;
    if (j + nb_objects >= (long)MAX_NB_OBJECTS_PER_FILE)
    { os_err = "Too many symbols in an object file"; return 1; }
    if (load_string( &name )) return 1;
    if (alloc_symbol( name, loc )) return 1;
    object[MAX_NB_OBJECTS_PER_FILE-1-j] = *loc;
   }
  else if (i > nb_symbols)
  { os_err = "Symbol reference out of range"; return 1; }
  else
    *loc = object[MAX_NB_OBJECTS_PER_FILE-1-i];
  return 0;
}


long load_value( loc )
SCM_obj *loc;
{ long val, masked;
  load_long_word( val );
  masked = val & ~(((long)INDEX_MASK) << 3);
  if (masked == (long)OBJECT)
  { *loc = (SCM_obj)0;
    if (add_object_patch( (val >> 3) & INDEX_MASK, loc )) return 1;
  }
  else if (masked == (long)SYMBOL)
  { if (load_sym( (short)((val >> 3) & INDEX_MASK), loc )) return 1;
  }
  else if (masked == (long)PRIM_PROC)
  { SCM_obj sym;
    long index;
    if (load_sym( (short)((val >> 3) & INDEX_MASK), &sym )) return 1;
    if (alloc_global_from_symbol( sym, &index )) return 1;
    if (add_prim_patch( index, loc )) return 1;
    *loc = (SCM_obj)0;
  }
  else
    *loc = (SCM_obj)val;
  return 0;
}


long load_proc( proc_adr, len, name )
SCM_obj proc_adr;
long len;
char *name;
{ short *code_ptr = (short *)proc_adr;

  procedure_name = name;

  M68020_patches = NULL;
  M68881_patches = NULL;

  while (1)
  { short tag;

    load_word( tag );

    if (tag > 0)
    { load_words( tag, code_ptr );
      code_ptr += tag;
    }

    else if (tag == (short)PADDING_TAG)
      /* just skip */;

    else if (tag == (short)END_OF_CODE_TAG)
      break;

    else if (tag == (short)M68020_TAG)
    { if (!os_M68020)
        if (add_patch( &M68020_patches, 0L, (SCM_obj *)code_ptr )) return 1;
    }

    else if (tag == (short)M68881_TAG)
    { if (!os_M68881)
        if (add_patch( &M68881_patches, 0L, (SCM_obj *)code_ptr )) return 1;
    }

    else if (tag == (short)STAT_TAG)
    { long index;
      if (alloc_stat( &index ))
      { os_err = "Statistics table overflow"; return 1; }
      else
      { *(long **)code_ptr = &pstate->stats_counters[index];
        code_ptr += 2;
        if (skip_string( &sstate->stats_offsets[index] )) return 1;
      }
    }

    else
    { short i = tag & INDEX_MASK;
      tag = tag & ~INDEX_MASK;

      if (tag == (short)PROC_REF_TAG)
      { if (add_object_patch( (long)i, (SCM_obj *)code_ptr )) return 1;
        load_word( *(long *)code_ptr );
        code_ptr += 2;
      }

      else if (tag == (short)GLOBAL_VAR_REF_TAG)
      { SCM_obj sym;
        long index;
        if (load_sym( i, &sym )) return 1;
        if (alloc_global_from_symbol( sym, &index )) return 1;
        *(code_ptr++) = table_offset( &sstate->globals[index].value );
      }

      else if (tag == (short)GLOBAL_VAR_SET_TAG)
      { SCM_obj sym;
        long index;
        if (load_sym( i, &sym )) return 1;
        if (alloc_global_from_symbol( sym, &index )) return 1;
        *(code_ptr++) = table_offset( &sstate->globals[index].value );
        *(code_ptr++) = LEAA6_DISP_A1_OP;
        *(code_ptr++) = table_offset( &sstate->tramps[index] );
        *(code_ptr++) = MOVE_L_A1_A6_DISP_OP;
        *(code_ptr++) = table_offset( &sstate->globals[index].jump_adr );
      }

      else if (tag == (short)GLOBAL_VAR_REF_JUMP_TAG)
      { SCM_obj sym;
        long index;
        if (load_sym( i, &sym )) return 1;
        if (alloc_global_from_symbol( sym, &index )) return 1;
        *(code_ptr++) = table_offset( &sstate->globals[index].jump_adr );
      }

      else if (tag == (short)PRIM_REF_TAG)
      { SCM_obj sym;
        long index;
        if (load_sym( i, &sym )) return 1;
        if (alloc_global_from_symbol( sym, &index )) return 1;
        if (add_prim_patch( index, (SCM_obj *)code_ptr )) return 1;
        load_word( *(long *)code_ptr );
        code_ptr += 2;
      }

      else
      { os_err = "Procedure object format error"; return 1; }
    }

  }

  { long i, rest = len - ( ((long)code_ptr) - ((long)proc_adr) - 2 );
    if ((rest < 0L) || ((rest & 3L) != 0))
    { os_err = "Procedure object format error"; return 1; }
    for (i=rest/4; i>0; i--)
    { if (load_value( (SCM_obj *)code_ptr )) return 1;
      code_ptr += 2;
    }
  }

  /* do patchup for emulation code */

  if (patchup_M68020_emul_code()) return 1;

  if (patchup_M68881_emul_code()) return 1;

  procedure_name = NULL;
  return 0;
}


long load_mem( index, ptr, len, init_proc )
long index;
char *ptr;
long len;
SCM_obj *init_proc;
{ short version_major, version_minor;
  char *emul_code_start = pstate->emul_code_ptr;

  emul_code_top   = pstate->emul_code_top;
  emul_code_alloc = emul_code_start;

  load_bot = ptr;
  load_top = ptr+len;
  load_ptr = ptr;

  nb_objects = 0;
  nb_symbols = 0;
  highest_object = -1;
  object_patches = NULL;
  stats_begin( index );

  load_word( version_major );
  if (version_major < OFILE_VERSION_MAJOR)
  { os_err = "Old object file format"; return 1; }
  else if (version_major > OFILE_VERSION_MAJOR)
  { os_err = "New object file format"; return 1; }
  load_word( version_minor );

  while (load_ptr+4 <= load_top)
  { long prefix;
    load_long_word( prefix );

    switch (prefix)
    {
      case (long)PRIM_PROC_PREFIX:
      { SCM_obj adr, sym;
        long indx, l;
        short header, i;
        char *name;
        load_word( i );
        if (load_sym( i, &sym )) return 1;
        if (alloc_global_from_symbol( sym, &indx )) return 1;
        name = SCM_obj_to_str(SCM_obj_to_vect(sym)[SYMBOL_NAME]);
        load_word( header );
        if (header >= 0)
        { os_err = "Object file format error"; return 1; }
        l = header + 0x8000;
        if (sstate->debug>=2)
        { os_warn( "  (primitive procedure %s", (long)name );
          os_warn( ", length=%d)\n", l );
        }
        if (alloc_const_proc( l, &adr )) return 1;
        if (add_object( adr )) return 1;
        if (load_proc( adr, l, name )) return 1;
        if ((sstate->debug>=2) &&
            (sstate->globals[indx].value != (long)SCM_unbound))
          os_warn( "Redefining %s\n", (long)name );
        sstate->globals[indx].value    = adr;
        sstate->globals[indx].jump_adr = (long)&sstate->tramps[indx];
        break;
      }

      case (long)USER_PROC_PREFIX:
      { SCM_obj adr;
        long l;
        short header;
        load_word( header );
        if (header >= 0)
        { os_err = "Object file format error"; return 1; }
        l = header + 0x8000;
        if (sstate->debug>=2) os_warn( "  (procedure, length=%d)\n", l );
        if (alloc_const_proc( l, &adr )) return 1;
        if (add_object( adr )) return 1;
        if (load_proc( adr, l, (char *)NULL )) return 1;
        break;
      }

      case (long)PAIR_PREFIX:
      { SCM_obj pair_adr;
        if (sstate->debug>=2) os_warn( "  (pair)\n", 0L );
        if (alloc_const_pair( &pair_adr )) return 1;
        if (add_object( pair_adr )) return 1;
        if (load_value( (SCM_obj *)(pair_adr-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj)) )) return 1;
        if (load_value( (SCM_obj *)(pair_adr-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj)) )) return 1;
        break;
      }

    default:
    { SCM_obj vector_adr;
      long l = SCM_header_length( prefix );
      long subtype = SCM_header_subtype( prefix );
      if (alloc_const_subtyped( l, subtype, &vector_adr )) return 1;
      if (add_object( vector_adr )) return 1;

      if (SCM_subtype_is_ovector( subtype ))
      { long i, n = l/4;
        if (sstate->debug>=2)
          os_warn( "  (object vector; length=%d)\n", n );
        for (i=0; i<n; i++)
          if (load_value( &SCM_obj_to_vect(vector_adr)[i] )) return 1;
      }

      else

      { short *p = (short *)SCM_obj_to_vect(vector_adr);
        if (sstate->debug>=2)
          os_warn( "  (byte vector; length=%d)\n", l );
        load_words( (l + 1)/2, p );
      }

      break;
    }
    }
  }

  if (nb_objects < 1) { os_err = "Object file is empty"; return 1; }

  stats_end( index );

  /* do patchup for local object references */

  if (highest_object >= nb_objects)
  { os_err = "Unresolved local object reference(s)"; return 1; }

  { PATCH_PTR patch = object_patches;
    while (patch != NULL)
    { PATCH_PTR next = patch->next;
      *(patch->loc) += object[patch->index];
      patch->next = free_patches;
      free_patches = patch;
      patch = next;
    }
  }

  /* copy emulation code to all other processors */

  { long i;
    long l = emul_code_alloc - emul_code_start;
    for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
    { PSTATE_PTR p = pstate->ps[i];
      if (p != pstate)
        os_block_copy( emul_code_start, p->emul_code_ptr, l );
      p->emul_code_ptr += l;
    }
  }

  *init_proc = object[0];

  return 0;
}


long load_file( index, init_proc )
long index;
SCM_obj *init_proc;
{ OS_FILE input;
  long len;

  filename = string_append( sstate->ofile[index].ptr, ".O" );
  if (filename == NULL) { os_err = NULL; return 1; }
  input = os_file_open_input( filename );
  if (input == -1L) { os_err = "Can't open"; return 1; }
  len = os_file_length( input );
  if (len < 0L) { os_err = "Read error"; return 1; }
  if (sstate->debug>=1)
  { os_warn( "Loading %s", (long)filename );
    os_warn( " (length=%d)\n", len );
  }

  read_top = read_bot+len;
  if (read_top > alloc_ptr)
  { os_file_close( input ); os_err = "Load memory overflow"; return 1; }

  if (os_file_read( input, read_bot, len ) != len)
  { os_file_close( input ); os_err = "Read error"; return 1; }

  os_file_close( input );

  if (load_mem( index, read_bot, len, init_proc )) return 1;

  filename = NULL;
  return 0;
}


void fill_in_os_err()
{ char *fn, *pn, *em;
  if (filename == NULL) fn = ""; else fn = string_append( filename, ": " );
  if (procedure_name == NULL) pn = ""; else pn = string_append( procedure_name, ", " );
  if (os_err == NULL) em = "Local memory overflow"; else em = os_err;
  os_err = string_append( fn, string_append( pn, em ) );
  if (os_err == NULL) os_err = "Local memory overflow";
}


long prepare_ofile( ptr, len )
char *ptr;
long len;
{ long i;
  if (len == 0)
  { for (i=0; i<sstate->nb_ofiles; i++)
      if ((sstate->ofile[i].len == 0) &&
          (string_compare( sstate->ofile[i].ptr, ptr ) == 0)) break;
  }
  else
    i = sstate->nb_ofiles;

  if (i >= (long)MAX_NB_OFILES)
  { os_err = "Too many object files"; return -1; }

  sstate->ofile[i].ptr = ptr;
  sstate->ofile[i].len = len;
  stats_clear( i );
  if (i == sstate->nb_ofiles) sstate->nb_ofiles++;
  return i;
}


void init_ofile( ptr, len )
char *ptr;
long len;
{ if (prepare_ofile( ptr, len ) < 0)
  { os_warn( "%s\n", (long)os_err ); os_quit(); }
}


SCM_obj init_program( argc, argv, envp )
long argc;
char *argv[], *envp[];
{ long i;
  long envc;
  SCM_obj ev, av, ep;

  filename = NULL;
  procedure_name = NULL;

  if (alloc_const_vector( sstate->nb_ofiles, &ev )) goto error;

  if (begin_load()) goto error;

  for (i=0; i<sstate->nb_ofiles; i++)
    if (sstate->ofile[i].len == 0)
    { if (load_file( i, &SCM_obj_to_vect(ev)[i] )) goto error; }
    else
    { if (load_mem( i,
                    sstate->ofile[i].ptr,
                    sstate->ofile[i].len,
                    &SCM_obj_to_vect(ev)[i] )) goto error;
    }

  if (end_load()) goto error;

  /* init trap trampolines */

  for (i=0; i<NB_TRAMPOLINE_TRAPS; i++)
  { long index;
    static char prefix[] = "###_kernel.trap_";
    char name[sizeof(prefix)+2], *p1 = name, *p2 = prefix;
    while (*p2 != '\0') *p1++ = *p2++;
    if (i > 9) *p1++ = '0' + (i/10);
    *p1++ = '0' + (i%10);
    *p1++ = '\0';
    if (alloc_global( name, &index )) goto error;
    sstate->traps[i].jmp = JMP_OP;
    sstate->traps[i].adr = sstate->globals[index].value;
  }

  /* init interrupt trap */

  { long index;
    if (alloc_global( "###_kernel.interrupt", &index )) goto error;
    sstate->traps[intr_trap].jmp = JMP_OP;
    sstate->traps[intr_trap].adr = sstate->globals[index].value;
  }

  if (set_global( "##exec-vector", ev )) goto error;

  if (set_global( "##argc", SCM_int_to_obj(argc) )) goto error;

  if (alloc_const_vector( argc, &av )) goto error;
  for (i=0; i<argc; i++)
    if (alloc_const_string( argv[i], &SCM_obj_to_vect(av)[i] )) goto error;
  if (set_global( "##argv", av )) goto error;

  envc = 0;
  while (envp[envc] != NULL) envc++;
  if (alloc_const_vector( envc, &ep )) goto error;
  for (i=0; i<envc; i++)
    if (alloc_const_string( envp[i], &SCM_obj_to_vect(ep)[i] )) goto error;
  if (set_global( "##envp", ep )) goto error;

  return SCM_obj_to_vect(ev)[0];

  error:
  fill_in_os_err();
  os_warn( "%s\n", (long)os_err );
  os_quit();
  /*NOTREACHED*/
}  


long do_load_copy_code( id, ptr )
long id;
char *ptr;
{ if (id != SCM_obj_to_int(pstate->id))
  { long len1 = ((long *)ptr)[0];
    long len2 = ((long *)ptr)[1];
    os_block_copy( ptr+2*sizeof(long), sstate->const_bptr - len1 , len1 );
    os_block_copy( ptr+2*sizeof(long)+len1, sstate->const_tptr, len2 );
  }
  return 0;
}


long load_ofile( name, init_proc )
char *name;
SCM_obj *init_proc;
{ if (name != NULL) /* only one processor does the load */
  { long index;
    char *const_b = sstate->const_bptr;
    char *const_t = sstate->const_tptr;

    os_err = "";

    filename = NULL;
    procedure_name = NULL;

    index = prepare_ofile( name, 0L );
    if (index < 0) goto error;

    if (begin_load()) goto error;

    if (load_file( index, init_proc )) goto error;

    if (end_load()) goto error;

    /* copy code to each processor */

    { long len1 = sstate->const_bptr - const_b;
      long len2 = const_t - sstate->const_tptr;
      if (len1+len2+2*sizeof(long) > pstate->heap_mid - pstate->heap_bot)
        goto error;
      ((long *)pstate->heap_old)[0] = len1;
      ((long *)pstate->heap_old)[1] = len2;
      os_block_copy( const_b, pstate->heap_old+2*sizeof(long), len1 );
      os_block_copy( sstate->const_tptr, pstate->heap_old+2*sizeof(long)+len1, len2 );
      return barrier_call( do_load_copy_code, (long)pstate->heap_old );
    }

    error:
    fill_in_os_err();
    if (sstate->debug>=1) os_warn( "%s\n", (long)os_err );
    *init_proc = c_str_to_string( os_err );
    return barrier_call( do_return, 1L );
  }
  else
    return barrier_service();
}


/*---------------------------------------------------------------------------*/