-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* 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
#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 "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
-/* SCM_OBJCODE_COOKIE is defined in _scm.h */
-/* The length of the header must be a multiple of 8 bytes. */
+/* 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;
+
\f
/*
* Objcode type
*/
-scm_t_bits scm_tc16_objcode;
+/* 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_by_mmap (int fd)
-#define FUNC_NAME "make_objcode_by_mmap"
+make_objcode_from_file (int fd)
+#define FUNC_NAME "make_objcode_from_file"
{
int ret;
- char *addr;
+ /* 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;
- SCM sret = SCM_BOOL_F;
- struct scm_objcode *data;
ret = fstat (fd, &st);
if (ret < 0)
SCM_SYSERROR;
- if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
+ 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)));
- addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
- if (addr == MAP_FAILED)
- {
- (void) close (fd);
- SCM_SYSERROR;
- }
-
- if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)))
- {
- SCM args = scm_list_1 (scm_from_locale_stringn
- (addr, strlen (SCM_OBJCODE_COOKIE)));
- (void) close (fd);
- (void) munmap (addr, st.st_size);
- scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
- }
-
- data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
-
- if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
- {
- (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_uint32 (sizeof (*data) + data->len
- + data->metalen)));
- }
-
- SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
- SCM_PACK (SCM_BOOL_F), fd);
- SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
-
- /* FIXME: we leak ourselves and the file descriptor. but then again so does
- dlopen(). */
- return scm_permanent_object (sret);
+#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 ret;
SCM_VALIDATE_OBJCODE (1, parent);
parent_data = SCM_OBJCODE_DATA (parent);
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_ulong ((unsigned long) ptr),
- scm_from_ulong ((unsigned long) parent_base),
- scm_from_uint32 (parent_data->len),
- scm_from_uint32 (parent_data->metalen)));
+ 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_C_OBJCODE_BASE (data) + data->len + data->metalen
<= parent_base + parent_data->len + parent_data->metalen);
- SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
- SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
- return ret;
+ return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0),
+ (scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
- (SCM bytecode),
- "")
-#define FUNC_NAME s_scm_bytecode_to_objcode
+/* 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;
- ssize_t increment;
- scm_t_array_handle handle;
+ size_t size, len, metalen;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
- SCM objcode;
- if (scm_is_false (scm_u8vector_p (bytecode)))
+ if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
- data = (struct scm_objcode*)c_bytecode;
- SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
- scm_array_handle_release (&handle);
+ 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));
- if (data->len + data->metalen != (size - sizeof (*data)))
- scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+ 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) + data->len + data->metalen)));
- assert (increment == 1);
- SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
-
+ 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
- return objcode;
+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),
"")
SCM_VALIDATE_STRING (1, file);
c_file = scm_to_locale_string (file);
- fd = open (c_file, O_RDONLY);
+ fd = open (c_file, O_RDONLY | O_BINARY | O_CLOEXEC);
free (c_file);
if (fd < 0) SCM_SYSERROR;
- return make_objcode_by_mmap (fd);
+ return make_objcode_from_file (fd);
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
- scm_t_uint8 *u8vector;
+ scm_t_int8 *s8vector;
scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
- len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+ len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- u8vector = scm_malloc (len);
- memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+ s8vector = scm_gc_malloc_pointerless (len, FUNC_NAME);
+ memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
- return scm_take_u8vector (u8vector, len);
+ return scm_c_take_gc_bytevector (s8vector, len);
}
#undef FUNC_NAME
"")
#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);
-
- scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
+ 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) + SCM_OBJCODE_TOTAL_LEN (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);
+}
+
\f
void
scm_bootstrap_objcodes (void)
{
- scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
- scm_c_register_extension ("libguile", "scm_init_objcodes",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_objcodes",
(scm_t_extension_init_func)scm_init_objcodes, NULL);
}
void
scm_init_objcodes (void)
{
- scm_bootstrap_vm ();
-
#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");
}
/*
HCoop / bpt / guile.git / blobdiff