summaryrefslogtreecommitdiff
path: root/libguile/objcodes.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/objcodes.c')
-rw-r--r--libguile/objcodes.c480
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:
-*/