path: root/byterun/extern.c

/***********************************************************************/
/*                                                                     */
/*                           Objective Caml                            */
/*                                                                     */
/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
/*                                                                     */
/*  Copyright 1996 Institut National de Recherche en Informatique et   */
/*  Automatique.  Distributed only by permission.                      */
/*                                                                     */
/***********************************************************************/

/* $Id$ */

/* Structured output */

#include <string.h>
#include "alloc.h"
#include "fail.h"
#include "gc.h"
#include "intext.h"
#include "io.h"
#include "memory.h"
#include "misc.h"
#include "mlvalues.h"
#include "reverse.h"
#include "str.h"

/* To keep track of sharing in externed objects */

typedef unsigned long byteoffset_t;

struct extern_obj {
  value obj;
  byteoffset_t ofs;
};

static struct extern_obj * extern_table;
static unsigned long extern_table_size;

#ifdef SIXTYFOUR
#define Hash(v) (((unsigned long) ((v) >> 3)) % extern_table_size)
#else
#define Hash(v) (((unsigned long) ((v) >> 2)) % extern_table_size)
#endif

static void alloc_extern_table()
{
  asize_t i;

  extern_table = (struct extern_obj *)
    stat_alloc(extern_table_size * sizeof(struct extern_obj));
  for (i = 0; i < extern_table_size; i++) extern_table[i].obj = 0;
}

static void resize_extern_table()
{
  asize_t oldsize;
  struct extern_obj * oldtable;
  value obj;
  asize_t i, h;

  oldsize = extern_table_size;
  oldtable = extern_table;
  extern_table_size = 2 * extern_table_size;
  alloc_extern_table();
  for (i = 0; i < oldsize; i++) {
    obj = oldtable[i].obj;
    if (obj != 0) {
      h = Hash(obj);
      while (extern_table[h].obj != 0) {
        h++;
        if (h >= extern_table_size) h = 0;
      }
      extern_table[h].obj = obj;
      extern_table[h].ofs = oldtable[i].ofs;
    }
  }
  stat_free((char *) oldtable);
}

/* To buffer the output */

static char * extern_block, * extern_ptr, * extern_limit;

static void alloc_extern_block()
{
  extern_block = stat_alloc(INITIAL_EXTERN_BLOCK_SIZE);
  extern_limit = extern_block + INITIAL_EXTERN_BLOCK_SIZE;
  extern_ptr = extern_block;
}

static void resize_extern_block(required)
     int required;
{
  long curr_pos, size, reqd_size;

  curr_pos = extern_ptr - extern_block;
  size = extern_limit - extern_block;
  reqd_size = curr_pos + required;
  while (size <= reqd_size) size *= 2;
  extern_block = stat_resize(extern_block, size);
  extern_limit = extern_block + size;
  extern_ptr = extern_block + curr_pos;
}

#define Write(c) \
  if (extern_ptr >= extern_limit) resize_extern_block(1); \
  *extern_ptr++ = (c)

/* Write integers and blocks in the output buffer */

static void writeblock(data, len)
     char * data;
     long len;
{
  if (extern_ptr + len > extern_limit) resize_extern_block(len);
  bcopy(data, extern_ptr, len);
  extern_ptr += len;
}

static void writecode8(code, val)
     int code;
     long val;
{
  if (extern_ptr + 2 > extern_limit) resize_extern_block(2);
  extern_ptr[0] = code;
  extern_ptr[1] = val;
  extern_ptr += 2;
}

static void writecode16(code, val)
     int code;
     long val;
{
  if (extern_ptr + 3 > extern_limit) resize_extern_block(3);
  extern_ptr[0] = code;
  extern_ptr[1] = val >> 8;
  extern_ptr[2] = val;
  extern_ptr += 3;
}

static void write32(val)
     long val;
{
  if (extern_ptr + 4 > extern_limit) resize_extern_block(4);
  extern_ptr[0] = val >> 24;
  extern_ptr[1] = val >> 16;
  extern_ptr[2] = val >> 8;
  extern_ptr[3] = val;
  extern_ptr += 4;
}

static void writecode32(code, val)
     int code;
     long val;
{
  if (extern_ptr + 5 > extern_limit) resize_extern_block(5);
  extern_ptr[0] = code;
  extern_ptr[1] = val >> 24;
  extern_ptr[2] = val >> 16;
  extern_ptr[3] = val >> 8;
  extern_ptr[4] = val;
  extern_ptr += 5;
}

#ifdef SIXTYFOUR
static void writecode64(code, val)
     int code;
     long val;
{
  int i;
  if (extern_ptr + 9 > extern_limit) resize_extern_block(9);
  *extern_ptr ++ = code;
  for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i;
}
#endif

/* Marshal the given value in the output buffer */

static byteoffset_t obj_counter;    /* Number of objects emitted so far */
static unsigned long size_32;  /* Size in words of 32-bit block for struct. */
static unsigned long size_64;  /* Size in words of 64-bit block for struct. */

static void extern_cleanup()
{
  stat_free(extern_block);
  stat_free((char *) extern_table);
}

static void extern_rec(v)
     value v;
{
 tailcall:
  if (Is_long(v)) {
    long n = Long_val(v);
    if (n >= 0 && n < 0x40) {
      Write(PREFIX_SMALL_INT + n);
    } else if (n >= -(1 << 7) && n < (1 << 7)) {
      writecode8(CODE_INT8, n);
    } else if (n >= -(1 << 15) && n < (1 << 15)) {
      writecode16(CODE_INT16, n);
#ifdef SIXTYFOUR
    } else if (n < -(1L << 31) || n >= (1L << 31)) {
      writecode64(CODE_INT64, n);
#endif
    } else
      writecode32(CODE_INT32, n);
  } else if (!Is_atom(v) && !Is_young(v) && !Is_in_heap(v)) {
    extern_cleanup();
    invalid_argument("output_value: abstract value");
  } else {
    header_t hd = Hd_val(v);
    tag_t tag = Tag_hd(hd);
    mlsize_t sz = Wosize_hd(hd);
    asize_t h;
    /* Atoms are treated specially for two reasons: they are not allocated
       in the externed block, and they are automatically shared. */
    if (sz == 0) {
      if (tag < 16) {
        Write(PREFIX_SMALL_BLOCK + tag);
      } else {
        writecode32(CODE_BLOCK32, hd);
      }
    } else {
      /* Check if already seen */
      if (2 * obj_counter >= extern_table_size) resize_extern_table();
      h = Hash(v);
      while (extern_table[h].obj != 0) {
        if (extern_table[h].obj == v) {
          byteoffset_t d = obj_counter - extern_table[h].ofs;
          if (d < 0x100) {
            writecode8(CODE_SHARED8, d);
          } else if (d < 0x10000) {
            writecode16(CODE_SHARED16, d);
          } else {
            writecode32(CODE_SHARED32, d);
          }
          return;
        }
        h++;
        if (h >= extern_table_size) h = 0;
      }
      /* Not seen yet. Record the object and output its contents. */
      extern_table[h].obj = v;
      extern_table[h].ofs = obj_counter;
      obj_counter++;
      switch(tag) {
      case String_tag: {
        mlsize_t len = string_length(v);
        if (len < 0x20) {
          Write(PREFIX_SMALL_STRING + len);
        } else if (len < 0x100) {
          writecode8(CODE_STRING8, len);
        } else {
          writecode32(CODE_STRING32, len);
        }
        writeblock(String_val(v), len);
        size_32 += 1 + (len + 4) / 4;
        size_64 += 1 + (len + 8) / 8;
        break;
      }
      case Double_tag: {
        if (sizeof(double) != 8) {
          extern_cleanup();
          invalid_argument("output_value: non-standard floats");
        }
        Write(CODE_DOUBLE_NATIVE);
        writeblock((char *) v, 8);
        size_32 += 1 + 2;
        size_64 += 1 + 1;
        break;
      }
      case Double_array_tag: {
        mlsize_t nfloats;
        if (sizeof(double) != 8) {
          extern_cleanup();
          invalid_argument("output_value: non-standard floats");
        }
        nfloats = Wosize_val(v) / Double_wosize;
        if (nfloats < 0x100) {
          writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
        } else {
          writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
        }
        writeblock((char *) v, Bosize_val(v));
        size_32 += 1 + nfloats * 2;
        size_64 += 1 + nfloats;
        break;
      }
      case Abstract_tag:
      case Final_tag:
        extern_cleanup();
        invalid_argument("output_value: abstract value");
        break;
      case Closure_tag:
      case Infix_tag:
        extern_cleanup();
        invalid_argument("output_value: functional value");
        break;
      default: {
        mlsize_t i;
        if (tag < 16 && sz < 8) {
          Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
        } else {
          writecode32(CODE_BLOCK32, hd);
        }
        size_32 += 1 + sz;
        size_64 += 1 + sz;
        for (i = 0; i < sz - 1; i++) extern_rec(Field(v, i));
        v = Field(v, i);
        goto tailcall;
      }
      }
    }
  }
}

static long extern_value(v)
     value v;
{
  long res_len;
  alloc_extern_block();
  extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
  alloc_extern_table();
  obj_counter = 0;
  size_32 = 0;
  size_64 = 0;
  /* Write magic number */
  write32(Intext_magic_number);
  /* Set aside space for the sizes */
  extern_ptr += 4*4;
  /* Marshal the object */
  extern_rec(v);
  /* Free the table of shared objects */
  stat_free((char *) extern_table);
  /* Write the sizes */
#ifdef SIXTYFOUR
  if (size_32 >= (1L << 32) || size_64 >= (1L << 32)) {
    /* The object is so big its size cannot be written in the header.
       Besides, some of the block sizes or string lengths or shared offsets
       it contains may have overflowed the 32 bits used to write them. */
    failwith("output_value: object too big");
  }
#endif
  res_len = extern_ptr - extern_block;
  extern_ptr = extern_block + 4;
  write32(res_len - 5*4);
  write32(obj_counter);
  write32(size_32);
  write32(size_64);
  /* Result is res_len bytes starting at extern_block */
  return res_len;
}

value output_value(chan, v) /* ML */
     struct channel * chan;
     value v;
{
  long len;
  len = extern_value(v);
  really_putblock(chan, extern_block, len);
  stat_free(extern_block);
  return Val_unit;
}

value output_value_to_string(v) /* ML */
     value v;
{
  long len;
  value res;
  len = extern_value(v);
  res = alloc_string(len);
  bcopy(extern_block, String_val(res), len);
  stat_free(extern_block);
  return res;
}