summaryrefslogtreecommitdiff
path: root/libguile/objcodes.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/objcodes.c')
-rw-r--r--libguile/objcodes.c807
1 files changed, 564 insertions, 243 deletions
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index e315f3e6e..3f51c70e0 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012
+ * 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
@@ -37,204 +38,584 @@
#include <full-read.h>
#include "_scm.h"
+#include "elf.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.
+/* Before, we used __BYTE_ORDER, but that is not defined on all
+ systems. So punt and use automake, PDP endianness be damned. */
+#define SCM_BYTE_ORDER_BE 4321
+#define SCM_BYTE_ORDER_LE 1234
- The length of the header must be a multiple of 8 bytes. */
-verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
+/* Byte order of the build machine. */
+#ifdef WORDS_BIGENDIAN
+#define SCM_BYTE_ORDER SCM_BYTE_ORDER_BE
+#else
+#define SCM_BYTE_ORDER SCM_BYTE_ORDER_LE
+#endif
-/* 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;
+/* This file contains the loader for Guile's on-disk format: ELF with
+ some custom tags in the dynamic segment. */
+
+#if SIZEOF_SCM_T_BITS == 4
+#define Elf_Half Elf32_Half
+#define Elf_Word Elf32_Word
+#define Elf_Ehdr Elf32_Ehdr
+#define ELFCLASS ELFCLASS32
+#define Elf_Phdr Elf32_Phdr
+#define Elf_Dyn Elf32_Dyn
+#elif SIZEOF_SCM_T_BITS == 8
+#define Elf_Half Elf64_Half
+#define Elf_Word Elf64_Word
+#define Elf_Ehdr Elf64_Ehdr
+#define ELFCLASS ELFCLASS64
+#define Elf_Phdr Elf64_Phdr
+#define Elf_Dyn Elf64_Dyn
+#else
+#error
+#endif
-
-/*
- * Objcode type
- */
+#define DT_LOGUILE 0x37146000 /* Start of Guile-specific */
+#define DT_GUILE_GC_ROOT 0x37146000 /* Offset of GC roots */
+#define DT_GUILE_GC_ROOT_SZ 0x37146001 /* Size in machine words of GC
+ roots */
+#define DT_GUILE_ENTRY 0x37146002 /* Address of entry thunk */
+#define DT_GUILE_RTL_VERSION 0x37146003 /* Bytecode version */
+#define DT_HIGUILE 0x37146fff /* End of Guile-specific */
-/* Endianness of the build machine. */
#ifdef WORDS_BIGENDIAN
-# define NATIVE_ENDIANNESS 'B'
+#define ELFDATA ELFDATA2MSB
#else
-# define NATIVE_ENDIANNESS 'L'
+#define ELFDATA ELFDATA2LSB
#endif
-/* Return the endianness of the compilation target. */
-static char
-target_endianness (void)
+enum bytecode_kind
+ {
+ BYTECODE_KIND_NONE,
+ BYTECODE_KIND_GUILE_2_0
+ };
+
+static SCM
+pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr)
{
- 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;
+ switch (bytecode_kind)
+ {
+ case BYTECODE_KIND_GUILE_2_0:
+ {
+ SCM objcode;
+ scm_t_bits tag = SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0);
+
+ objcode = scm_double_cell (tag, (scm_t_bits) ptr, SCM_BOOL_F_BITS, 0);
+ return scm_make_program (objcode, SCM_BOOL_F, SCM_UNDEFINED);
+ }
+ case BYTECODE_KIND_NONE:
+ default:
+ abort ();
+ }
}
-/* Return the word size in bytes of the compilation target. */
-static size_t
-target_word_size (void)
+static const char*
+check_elf_header (const Elf_Ehdr *header)
{
- 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 *);
+ if (!(header->e_ident[EI_MAG0] == ELFMAG0
+ && header->e_ident[EI_MAG1] == ELFMAG1
+ && header->e_ident[EI_MAG2] == ELFMAG2
+ && header->e_ident[EI_MAG3] == ELFMAG3))
+ return "not an ELF file";
+
+ if (header->e_ident[EI_CLASS] != ELFCLASS)
+ return "ELF file does not have native word size";
+
+ if (header->e_ident[EI_DATA] != ELFDATA)
+ return "ELF file does not have native byte order";
+
+ if (header->e_ident[EI_VERSION] != EV_CURRENT)
+ return "bad ELF version";
+
+ if (header->e_ident[EI_OSABI] != ELFOSABI_STANDALONE)
+ return "unexpected OS ABI";
+
+ if (header->e_ident[EI_ABIVERSION] != 0)
+ return "unexpected ABI version";
+
+ if (header->e_type != ET_DYN)
+ return "unexpected ELF type";
+
+ if (header->e_machine != EM_NONE)
+ return "unexpected machine";
+
+ if (header->e_version != EV_CURRENT)
+ return "unexpected ELF version";
+
+ if (header->e_ehsize != sizeof *header)
+ return "unexpected header size";
+
+ if (header->e_phentsize != sizeof (Elf_Phdr))
+ return "unexpected program header size";
+
+ return NULL;
}
-/* Convert X, which is in byte order ENDIANNESS, to its native
- representation. */
-static inline uint32_t
-to_native_order (uint32_t x, char endianness)
+static int
+segment_flags_to_prot (Elf_Word flags)
{
- if (endianness == NATIVE_ENDIANNESS)
- return x;
- else
- return bswap_32 (x);
+ int prot = 0;
+
+ if (flags & PF_X)
+ prot |= PROT_EXEC;
+ if (flags & PF_W)
+ prot |= PROT_WRITE;
+ if (flags & PF_R)
+ prot |= PROT_READ;
+
+ return prot;
}
-static void
-verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
-#define FUNC_NAME "make_objcode_from_file"
+static int
+map_segments (int fd, char **base,
+ const Elf_Phdr *from, const Elf_Phdr *to)
{
- /* 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))
+ int prot = segment_flags_to_prot (from->p_flags);
+ char *ret;
+
+ ret = mmap (*base + from->p_vaddr,
+ to->p_offset + to->p_filesz - from->p_offset,
+ prot, MAP_PRIVATE, fd, from->p_offset);
+
+ if (ret == (char *) -1)
+ return 1;
+
+ if (!*base)
+ *base = ret;
+
+ return 0;
+}
+
+static int
+mprotect_segments (char *base, const Elf_Phdr *from, const Elf_Phdr *to)
+{
+ return mprotect (base + from->p_vaddr,
+ to->p_vaddr + to->p_memsz - from->p_vaddr,
+ segment_flags_to_prot (from->p_flags));
+}
+
+static char*
+process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
+ SCM *init_out, SCM *entry_out)
+{
+ char *dyn_addr = base + dyn_phdr->p_vaddr;
+ Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr;
+ size_t i, dyn_size = dyn_phdr->p_memsz / sizeof (Elf_Dyn);
+ char *init = 0, *gc_root = 0, *entry = 0;
+ scm_t_ptrdiff gc_root_size = 0;
+ enum bytecode_kind bytecode_kind = BYTECODE_KIND_NONE;
+
+ for (i = 0; i < dyn_size; i++)
{
- SCM args = scm_list_1 (scm_from_latin1_stringn
- (cookie, strlen (SCM_OBJCODE_COOKIE)));
- if (map_fd >= 0)
+ if (dyn[i].d_tag == DT_NULL)
+ break;
+
+ switch (dyn[i].d_tag)
{
- (void) close (map_fd);
-#ifdef HAVE_SYS_MMAN_H
- (void) munmap (map_addr, st->st_size);
-#endif
+ case DT_INIT:
+ if (init)
+ return "duplicate DT_INIT";
+ init = base + dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_GC_ROOT:
+ if (gc_root)
+ return "duplicate DT_GUILE_GC_ROOT";
+ gc_root = base + dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_GC_ROOT_SZ:
+ if (gc_root_size)
+ return "duplicate DT_GUILE_GC_ROOT_SZ";
+ gc_root_size = dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_ENTRY:
+ if (entry)
+ return "duplicate DT_GUILE_ENTRY";
+ entry = base + dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_RTL_VERSION:
+ if (bytecode_kind != BYTECODE_KIND_NONE)
+ return "duplicate DT_GUILE_RTL_VERSION";
+ {
+ scm_t_uint16 major = dyn[i].d_un.d_val >> 16;
+ scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff;
+ if (major != 0x0200)
+ return "incompatible bytecode kind";
+ if (minor > SCM_OBJCODE_MINOR_VERSION)
+ return "incompatible bytecode version";
+ bytecode_kind = BYTECODE_KIND_GUILE_2_0;
+ break;
+ }
}
- scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
}
- {
- char minor_version = cookie[strlen (SCM_OBJCODE_COOKIE) - 1];
+ if (bytecode_kind != BYTECODE_KIND_GUILE_2_0)
+ return "missing DT_GUILE_RTL_VERSION";
+ if (init)
+ return "unexpected DT_INIT";
+ if ((scm_t_uintptr) entry % 8)
+ return "unaligned DT_GUILE_ENTRY";
+ if (!entry)
+ return "missing DT_GUILE_ENTRY";
+
+ if (gc_root)
+ GC_add_roots (gc_root, gc_root + gc_root_size);
+
+ *init_out = SCM_BOOL_F;
+ *entry_out = pointer_to_procedure (bytecode_kind, entry);
+ return NULL;
+}
+
+#define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
- 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
- }
+static SCM
+load_thunk_from_fd_using_mmap (int fd)
+#define FUNC_NAME "load-thunk-from-disk"
+{
+ Elf_Ehdr header;
+ Elf_Phdr *ph;
+ const char *err_msg = 0;
+ char *base = 0;
+ size_t n;
+ int i;
+ int start_segment = -1;
+ int prev_segment = -1;
+ int dynamic_segment = -1;
+ SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
+
+ if (full_read (fd, &header, sizeof header) != sizeof header)
+ ABORT ("object file too small");
+
+ if ((err_msg = check_elf_header (&header)))
+ goto cleanup;
+
+ if (lseek (fd, header.e_phoff, SEEK_SET) == (off_t) -1)
+ goto cleanup;
+
+ n = header.e_phnum;
+ ph = scm_gc_malloc_pointerless (n * sizeof (Elf_Phdr), "segment headers");
+
+ if (full_read (fd, ph, n * sizeof (Elf_Phdr)) != n * sizeof (Elf_Phdr))
+ ABORT ("failed to read program headers");
+
+ for (i = 0; i < n; i++)
+ {
+ if (!ph[i].p_memsz)
+ continue;
- 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)));
- }
+ if (ph[i].p_filesz != ph[i].p_memsz)
+ ABORT ("expected p_filesz == p_memsz");
+
+ if (!ph[i].p_flags)
+ ABORT ("expected nonzero segment flags");
+
+ if (ph[i].p_type == PT_DYNAMIC)
+ {
+ if (dynamic_segment >= 0)
+ ABORT ("expected only one PT_DYNAMIC segment");
+ dynamic_segment = i;
+ }
+
+ if (start_segment < 0)
+ {
+ if (!base && ph[i].p_vaddr)
+ ABORT ("first loadable vaddr is not 0");
+
+ start_segment = prev_segment = i;
+ continue;
+ }
+
+ if (ph[i].p_flags == ph[start_segment].p_flags)
+ {
+ if (ph[i].p_vaddr - ph[prev_segment].p_vaddr
+ != ph[i].p_offset - ph[prev_segment].p_offset)
+ ABORT ("coalesced segments not contiguous");
+
+ prev_segment = i;
+ continue;
+ }
+
+ /* Otherwise we have a new kind of segment. Map previous
+ segments. */
+ if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
+ goto cleanup;
+
+ /* Open a new set of segments. */
+ start_segment = prev_segment = i;
+ }
+
+ /* Map last segments. */
+ if (start_segment < 0)
+ ABORT ("no loadable segments");
+
+ if (map_segments (fd, &base, &ph[start_segment], &ph[prev_segment]))
+ goto cleanup;
+
+ if (dynamic_segment < 0)
+ ABORT ("no PT_DYNAMIC segment");
+
+ if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
+ &init, &entry)))
+ goto cleanup;
+
+ if (scm_is_true (init))
+ scm_call_0 (init);
+
+ /* Finally! Return the thunk. */
+ return entry;
+
+ /* FIXME: munmap on error? */
+ cleanup:
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
+ SCM_EOL);
}
}
#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.
- */
+#endif /* HAVE_SYS_MMAN_H */
static SCM
-make_objcode_from_file (int fd)
-#define FUNC_NAME "make_objcode_from_file"
+load_thunk_from_memory (char *data, size_t len)
+#define FUNC_NAME "load-thunk-from-memory"
{
- 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;
+ Elf_Ehdr header;
+ Elf_Phdr *ph;
+ const char *err_msg = 0;
+ char *base = 0;
+ size_t n, memsz = 0, alignment = 8;
+ int i;
+ int first_loadable = -1;
+ int start_segment = -1;
+ int prev_segment = -1;
+ int dynamic_segment = -1;
+ SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
+
+ if (len < sizeof header)
+ ABORT ("object file too small");
+
+ memcpy (&header, data, sizeof header);
+
+ if ((err_msg = check_elf_header (&header)))
+ goto cleanup;
+
+ n = header.e_phnum;
+ if (len < header.e_phoff + n * sizeof (Elf_Phdr))
+ goto cleanup;
+ ph = (Elf_Phdr*) (data + header.e_phoff);
+
+ for (i = 0; i < n; i++)
+ {
+ if (!ph[i].p_memsz)
+ continue;
- ret = fstat (fd, &st);
- if (ret < 0)
- SCM_SYSERROR;
+ if (ph[i].p_filesz != ph[i].p_memsz)
+ ABORT ("expected p_filesz == p_memsz");
- 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)));
+ if (!ph[i].p_flags)
+ ABORT ("expected nonzero segment flags");
-#ifdef HAVE_SYS_MMAN_H
- {
- char *addr;
- struct scm_objcode *data;
+ if (ph[i].p_align < alignment)
+ {
+ if (ph[i].p_align % alignment)
+ ABORT ("expected new alignment to be multiple of old");
+ alignment = ph[i].p_align;
+ }
- addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
+ if (ph[i].p_type == PT_DYNAMIC)
+ {
+ if (dynamic_segment >= 0)
+ ABORT ("expected only one PT_DYNAMIC segment");
+ dynamic_segment = i;
+ }
- 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);
- }
+ if (first_loadable < 0)
+ {
+ if (ph[i].p_vaddr)
+ ABORT ("first loadable vaddr is not 0");
- verify_cookie (cookie, &st, fd, addr);
+ first_loadable = i;
+ }
+ if (ph[i].p_vaddr < memsz)
+ ABORT ("overlapping segments");
- if (data->len + data->metalen
- != (st.st_size - sizeof (*data) - sizeof cookie))
- {
- size_t total_len = sizeof (*data) + data->len + data->metalen;
+ if (ph[i].p_offset + ph[i].p_filesz > len)
+ ABORT ("segment beyond end of byte array");
+
+ memsz = ph[i].p_vaddr + ph[i].p_memsz;
+ }
- (void) close (fd);
- (void) munmap (addr, st.st_size);
+ if (first_loadable < 0)
+ ABORT ("no loadable segments");
- 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)));
- }
+ if (dynamic_segment < 0)
+ ABORT ("no PT_DYNAMIC segment");
- (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);
+ /* Now copy segments. */
- 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);
- }
+ /* We leak this memory, as we leak the memory mappings in
+ load_thunk_from_fd_using_mmap.
- (void) close (fd);
+ If the file is has an alignment of 8, use the standard malloc.
+ (FIXME to ensure alignment on non-GNU malloc.) Otherwise use
+ posix_memalign. We only use mprotect if the aligment is 4096. */
+ if (alignment == 8)
+ {
+ base = malloc (memsz);
+ if (!base)
+ goto cleanup;
+ }
+ else
+ if ((errno = posix_memalign ((void **) &base, alignment, memsz)))
+ goto cleanup;
+
+ memset (base, 0, memsz);
+
+ for (i = 0; i < n; i++)
+ {
+ if (!ph[i].p_memsz)
+ continue;
+
+ memcpy (base + ph[i].p_vaddr,
+ data + ph[i].p_offset,
+ ph[i].p_memsz);
+
+ if (start_segment < 0)
+ {
+ start_segment = prev_segment = i;
+ continue;
+ }
+
+ if (ph[i].p_flags == ph[start_segment].p_flags)
+ {
+ prev_segment = i;
+ continue;
+ }
+
+ if (alignment == 4096)
+ if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
+ goto cleanup;
+
+ /* Open a new set of segments. */
+ start_segment = prev_segment = i;
+ }
+
+ /* Mprotect the last segments. */
+ if (alignment == 4096)
+ if (mprotect_segments (base, &ph[start_segment], &ph[prev_segment]))
+ goto cleanup;
+
+ if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
+ &init, &entry)))
+ goto cleanup;
+
+ if (scm_is_true (init))
+ scm_call_0 (init);
- verify_cookie (cookie, &st, -1, NULL);
+ /* Finally! Return the thunk. */
+ return entry;
- return scm_bytecode_to_native_objcode (bv);
+ cleanup:
+ {
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
+ SCM_EOL);
}
+}
+#undef FUNC_NAME
+
+#ifndef HAVE_SYS_MMAN_H
+static SCM
+load_thunk_from_fd_using_read (int fd)
+#define FUNC_NAME "load-thunk-from-disk"
+{
+ char *data;
+ size_t len;
+ struct stat st;
+ int ret;
+
+ ret = fstat (fd, &st);
+ if (ret < 0)
+ SCM_SYSERROR;
+ len = st.st_size;
+ data = scm_gc_malloc_pointerless (len, "objcode");
+ if (full_read (fd, data, len) != len)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, "short read while loading objcode",
+ SCM_EOL);
+ }
+ (void) close (fd);
+ return load_thunk_from_memory (data, len);
+}
+#undef FUNC_NAME
+#endif /* ! HAVE_SYS_MMAN_H */
+
+SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
+ (SCM filename),
+ "")
+#define FUNC_NAME s_scm_load_thunk_from_file
+{
+ char *c_filename;
+ int fd;
+
+ SCM_VALIDATE_STRING (1, filename);
+
+ c_filename = scm_to_locale_string (filename);
+ fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC);
+ free (c_filename);
+ if (fd < 0) SCM_SYSERROR;
+
+#ifdef HAVE_SYS_MMAN_H
+ return load_thunk_from_fd_using_mmap (fd);
+#else
+ return load_thunk_from_fd_using_read (fd);
#endif
}
#undef FUNC_NAME
+SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0,
+ (SCM bv),
+ "")
+#define FUNC_NAME s_scm_load_thunk_from_memory
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ return load_thunk_from_memory ((char *) SCM_BYTEVECTOR_CONTENTS (bv),
+ SCM_BYTEVECTOR_LENGTH (bv));
+}
+#undef FUNC_NAME
+
+
+/*
+ * Objcode type
+ */
+
+/* Convert X, which is in byte order BYTE_ORDER, to its native
+ representation. */
+static inline uint32_t
+to_native_order (uint32_t x, int byte_order)
+{
+ if (byte_order == SCM_BYTE_ORDER)
+ return x;
+ else
+ return bswap_32 (x);
+}
SCM
scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
@@ -300,9 +681,10 @@ SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
}
#undef FUNC_NAME
-/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE. */
+/* Wrap BYTECODE in objcode, interpreting its lengths according to
+ BYTE_ORDER. */
static SCM
-bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
+bytecode_to_objcode (SCM bytecode, int byte_order)
#define FUNC_NAME "bytecode->objcode"
{
size_t size, len, metalen;
@@ -318,8 +700,8 @@ bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
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);
+ len = to_native_order (data->len, byte_order);
+ metalen = to_native_order (data->metalen, byte_order);
if (len + metalen != (size - sizeof (*data)))
scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
@@ -333,111 +715,63 @@ bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
- (SCM bytecode),
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 1, 0,
+ (SCM bytecode, SCM endianness),
"")
#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;
+ int byte_order;
+
+ if (SCM_UNBNDP (endianness))
+ byte_order = SCM_BYTE_ORDER;
+ else if (scm_is_eq (endianness, scm_endianness_big))
+ byte_order = SCM_BYTE_ORDER_BE;
+ else if (scm_is_eq (endianness, scm_endianness_little))
+ byte_order = SCM_BYTE_ORDER_LE;
+ else
+ scm_wrong_type_arg (FUNC_NAME, 2, endianness);
- return make_objcode_from_file (fd);
+ return bytecode_to_objcode (bytecode, byte_order);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
- (SCM objcode),
+SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 1, 0,
+ (SCM objcode, SCM endianness),
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
- scm_t_int8 *s8vector;
- scm_t_uint32 len;
+ scm_t_uint32 len, meta_len, total_len;
+ int byte_order;
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;
+ if (SCM_UNBNDP (endianness))
+ byte_order = SCM_BYTE_ORDER;
+ else if (scm_is_eq (endianness, scm_endianness_big))
+ byte_order = SCM_BYTE_ORDER_BE;
+ else if (scm_is_eq (endianness, scm_endianness_little))
+ byte_order = SCM_BYTE_ORDER_LE;
+ else
+ scm_wrong_type_arg (FUNC_NAME, 2, endianness);
- total_size =
- to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
- + to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());
+ len = SCM_OBJCODE_LEN (objcode);
+ meta_len = SCM_OBJCODE_META_LEN (objcode);
- scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
- scm_c_write (port, SCM_OBJCODE_DATA (objcode),
- sizeof (struct scm_objcode) + total_size);
+ total_len = sizeof (struct scm_objcode);
+ total_len += to_native_order (len, byte_order);
+ total_len += to_native_order (meta_len, byte_order);
- return SCM_UNSPECIFIED;
+ return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
+ total_len, objcode);
}
#undef FUNC_NAME
void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<objcode ", port);
+ scm_puts_unlocked ("#<objcode ", port);
scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
@@ -449,14 +783,6 @@ scm_bootstrap_objcodes (void)
(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)
{
@@ -466,11 +792,6 @@ scm_init_objcodes (void)
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");
}
/*