guile 0.0.2

/* Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#if HAVE_CONFIG_H
#  include <config.h>
#endif

#include <string.h>
#include <fcntl.h>
#include <unistd.h>

#ifdef HAVE_SYS_MMAN_H
#include <sys/mman.h>
#endif

#include <sys/stat.h>
#include <sys/types.h>
#include <assert.h>
#include <alignof.h>
#include <byteswap.h>

#include <full-read.h>

#include "_scm.h"
#include "programs.h"
#include "objcodes.h"

/* SCM_OBJCODE_COOKIE, defined in _scm.h, is a magic value prepended
   to objcode on disk but not in memory.

   The length of the header must be a multiple of 8 bytes.  */
verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);

/* Endianness and word size of the compilation target.  */
static SCM target_endianness_var = SCM_BOOL_F;
static SCM target_word_size_var = SCM_BOOL_F;


/*
 * Objcode type
 */

/* Endianness of the build machine.  */
#ifdef WORDS_BIGENDIAN
# define NATIVE_ENDIANNESS 'B'
#else
# define NATIVE_ENDIANNESS 'L'
#endif

/* Return the endianness of the compilation target.  */
static char
target_endianness (void)
{
  if (scm_is_true (target_endianness_var))
    return scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
		      scm_endianness_big) ? 'B' : 'L';
  else
    return NATIVE_ENDIANNESS;
}

/* Return the word size in bytes of the compilation target.  */
static size_t
target_word_size (void)
{
  if (scm_is_true (target_word_size_var))
    return scm_to_size_t (scm_call_0
			  (scm_variable_ref (target_word_size_var)));
  else
    return sizeof (void *);
}

/* Convert X, which is in byte order ENDIANNESS, to its native
   representation.  */
static inline uint32_t
to_native_order (uint32_t x, char endianness)
{
  if (endianness == NATIVE_ENDIANNESS)
    return x;
  else
    return bswap_32 (x);
}

static void
verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
#define FUNC_NAME "make_objcode_from_file"
{
  /* The cookie ends with a version of the form M.N, where M is the
     major version and N is the minor version.  For this Guile to be
     able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N
     must be less than or equal to SCM_OBJCODE_MINOR_VERSION.  Since N
     is the last character, we do a strict comparison on all but the
     last, then a <= on the last one.  */
  if (memcmp (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1))
    {
      SCM args = scm_list_1 (scm_from_latin1_stringn
                             (cookie, strlen (SCM_OBJCODE_COOKIE)));
      if (map_fd >= 0)
        {
          (void) close (map_fd);
#ifdef HAVE_SYS_MMAN_H
          (void) munmap (map_addr, st->st_size);
#endif
        }
      scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
    }

  {
    char minor_version = cookie[strlen (SCM_OBJCODE_COOKIE) - 1];

    if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0])
      {
        if (map_fd >= 0)
          {
            (void) close (map_fd);
#ifdef HAVE_SYS_MMAN_H
            (void) munmap (map_addr, st->st_size);
#endif
          }

        scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
                        scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
                                    scm_from_latin1_string
                                    (SCM_OBJCODE_MINOR_VERSION_STRING)));
      }
  }
}
#undef FUNC_NAME

/* The words in an objcode SCM object are as follows:
     - scm_tc7_objcode | type | flags
     - the struct scm_objcode C object
     - the parent of this objcode: either another objcode, a bytevector,
       or, in the case of mmap types, #f
     - "native code" -- not currently used.
 */

static SCM
make_objcode_from_file (int fd)
#define FUNC_NAME "make_objcode_from_file"
{
  int ret;
  /* The SCM_OBJCODE_COOKIE is a string literal, and thus has an extra
     trailing NUL, hence the - 1. */
  char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
  struct stat st;

  ret = fstat (fd, &st);
  if (ret < 0)
    SCM_SYSERROR;

  if (st.st_size <= sizeof (struct scm_objcode) + sizeof cookie)
    scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
		    scm_list_1 (SCM_I_MAKINUM (st.st_size)));

#ifdef HAVE_SYS_MMAN_H
  {
    char *addr;
    struct scm_objcode *data;

    addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);

    if (addr == MAP_FAILED)
      {
        int errno_save = errno;
        (void) close (fd);
        errno = errno_save;
        SCM_SYSERROR;
      }
    else
      {
        memcpy (cookie, addr, sizeof cookie);
        data = (struct scm_objcode *) (addr + sizeof cookie);
      }

    verify_cookie (cookie, &st, fd, addr);


    if (data->len + data->metalen
        != (st.st_size - sizeof (*data) - sizeof cookie))
      {
        size_t total_len = sizeof (*data) + data->len + data->metalen;

        (void) close (fd);
        (void) munmap (addr, st.st_size);

        scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
                        scm_list_2 (scm_from_size_t (st.st_size),
                                    scm_from_size_t (total_len)));
      }

    (void) close (fd);
    return scm_permanent_object
      (scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
                        (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
                        SCM_BOOL_F_BITS, 0));
  }
#else
  {
    SCM bv = scm_c_make_bytevector (st.st_size - sizeof cookie);

    if (full_read (fd, cookie, sizeof cookie) != sizeof cookie
        || full_read (fd, SCM_BYTEVECTOR_CONTENTS (bv),
                      SCM_BYTEVECTOR_LENGTH (bv)) != SCM_BYTEVECTOR_LENGTH (bv))
      {
        int errno_save = errno;
        (void) close (fd);
        errno = errno_save;
        if (errno)
          SCM_SYSERROR;
        scm_misc_error (FUNC_NAME, "file truncated while reading", SCM_EOL);
      }

    (void) close (fd);

    verify_cookie (cookie, &st, -1, NULL);

    return scm_bytecode_to_native_objcode (bv);
  }
#endif
}
#undef FUNC_NAME


SCM
scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
#define FUNC_NAME "make-objcode-slice"
{
  const struct scm_objcode *data, *parent_data;
  const scm_t_uint8 *parent_base;

  SCM_VALIDATE_OBJCODE (1, parent);
  parent_data = SCM_OBJCODE_DATA (parent);
  parent_base = SCM_C_OBJCODE_BASE (parent_data);

  if (ptr < parent_base
      || ptr >= (parent_base + parent_data->len + parent_data->metalen
                 - sizeof (struct scm_objcode)))
    scm_misc_error
      (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
       scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr),
                   scm_from_unsigned_integer ((scm_t_bits) parent_base),
                   scm_from_uint32 (parent_data->len),
                   scm_from_uint32 (parent_data->metalen)));

  /* Make sure bytecode for the objcode-meta is suitable aligned.  Failing to
     do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC).  */
  assert ((((scm_t_bits) ptr) &
	   (alignof_type (struct scm_objcode) - 1UL)) == 0);

  data = (struct scm_objcode*) ptr;
  assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
	  <= parent_base + parent_data->len + parent_data->metalen);

  return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0),
                          (scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME


/*
 * Scheme interface
 */

SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
	    (SCM obj),
	    "")
#define FUNC_NAME s_scm_objcode_p
{
  return scm_from_bool (SCM_OBJCODE_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
	    (SCM objcode),
	    "")
#define FUNC_NAME s_scm_objcode_meta
{
  SCM_VALIDATE_OBJCODE (1, objcode);

  if (SCM_OBJCODE_META_LEN (objcode) == 0)
    return SCM_BOOL_F;
  else
    return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
                                               + SCM_OBJCODE_LEN (objcode)));
}
#undef FUNC_NAME

/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE.  */
static SCM
bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
#define FUNC_NAME "bytecode->objcode"
{
  size_t size, len, metalen;
  const scm_t_uint8 *c_bytecode;
  struct scm_objcode *data;

  if (!scm_is_bytevector (bytecode))
    scm_wrong_type_arg (FUNC_NAME, 1, bytecode);

  size = SCM_BYTEVECTOR_LENGTH (bytecode);
  c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);

  SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
  data = (struct scm_objcode*)c_bytecode;

  len = to_native_order (data->len, endianness);
  metalen = to_native_order (data->metalen, endianness);

  if (len + metalen != (size - sizeof (*data)))
    scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
		    scm_list_2 (scm_from_size_t (size),
				scm_from_uint32 (sizeof (*data) + len + metalen)));

  /* foolishly, we assume that as long as bytecode is around, that c_bytecode
     will be of the same length; perhaps a bad assumption? */
  return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0),
                          (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
	    (SCM bytecode),
	    "")
#define FUNC_NAME s_scm_bytecode_to_objcode
{
  /* Assume we're called from Scheme, which known that to do with
     `target-type'.  */
  return bytecode_to_objcode (bytecode, target_endianness (),
			      target_word_size ());
}
#undef FUNC_NAME

/* Like `bytecode->objcode', but ignore the `target-type' fluid.  This
   is useful for native compilation that happens lazily---e.g., direct
   calls to this function from libguile itself.  */
SCM
scm_bytecode_to_native_objcode (SCM bytecode)
{
  return bytecode_to_objcode (bytecode, NATIVE_ENDIANNESS, sizeof (void *));
}

SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
	    (SCM file),
	    "")
#define FUNC_NAME s_scm_load_objcode
{
  int fd;
  char *c_file;

  SCM_VALIDATE_STRING (1, file);

  c_file = scm_to_locale_string (file);
  fd = open (c_file, O_RDONLY | O_BINARY | O_CLOEXEC);
  free (c_file);
  if (fd < 0) SCM_SYSERROR;

  return make_objcode_from_file (fd);
}
#undef FUNC_NAME

SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
	    (SCM objcode),
	    "")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
  scm_t_int8 *s8vector;
  scm_t_uint32 len;

  SCM_VALIDATE_OBJCODE (1, objcode);

  len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);

  s8vector = scm_gc_malloc_pointerless (len, FUNC_NAME);
  memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);

  return scm_c_take_gc_bytevector (s8vector, len);
}
#undef FUNC_NAME

SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
	    (SCM objcode, SCM port),
	    "")
#define FUNC_NAME s_scm_write_objcode
{
  char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
  char endianness, word_size;
  size_t total_size;

  SCM_VALIDATE_OBJCODE (1, objcode);
  SCM_VALIDATE_OUTPUT_PORT (2, port);
  endianness = target_endianness ();
  switch (target_word_size ())
    {
    case 4:
      word_size = '4';
      break;
    case 8:
      word_size = '8';
      break;
    default:
      abort ();
    }

  memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
  cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
  cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;

  total_size =
    to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
    + to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());

  scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
  scm_c_write (port, SCM_OBJCODE_DATA (objcode),
               sizeof (struct scm_objcode) + total_size);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
  scm_puts ("#<objcode ", port);
  scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
  scm_puts (">", port);
}


void
scm_bootstrap_objcodes (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_objcodes",
                            (scm_t_extension_init_func)scm_init_objcodes, NULL);
}

/* Before, we used __BYTE_ORDER, but that is not defined on all
   systems. So punt and use automake, PDP endianness be damned. */
#ifdef WORDS_BIGENDIAN
#define SCM_BYTE_ORDER 4321
#else
#define SCM_BYTE_ORDER 1234
#endif

void
scm_init_objcodes (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/objcodes.x"
#endif

  scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
  scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));

  target_endianness_var = scm_c_public_variable ("system base target",
						 "target-endianness");
  target_word_size_var = scm_c_public_variable ("system base target",
						"target-word-size");
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/