#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"
verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
static SCM target_endianness_var = SCM_BOOL_F;
static SCM target_word_size_var = SCM_BOOL_F;
#ifdef WORDS_BIGENDIAN
# define NATIVE_ENDIANNESS 'B'
#else
# define NATIVE_ENDIANNESS 'L'
#endif
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;
}
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 *);
}
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"
{
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
static SCM
make_objcode_from_file (int fd)
#define FUNC_NAME "make_objcode_from_file"
{
int ret;
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)));
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
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
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)));
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
{
return bytecode_to_objcode (bytecode, target_endianness (),
target_word_size ());
}
#undef FUNC_NAME
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);
}
#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");
}