diff options
Diffstat (limited to 'libguile/objcodes.c')
-rw-r--r-- | libguile/objcodes.c | 480 |
1 files changed, 0 insertions, 480 deletions
diff --git a/libguile/objcodes.c b/libguile/objcodes.c deleted file mode 100644 index e315f3e6e..000000000 --- a/libguile/objcodes.c +++ /dev/null @@ -1,480 +0,0 @@ -/* 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: -*/ |