mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
e716f4410f
* libguile/objcodes.c (make_objcode_from_file): Add correct error message if full_read failed without an errno.
480 lines
13 KiB
C
480 lines
13 KiB
C
/* 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:
|
||
*/
|