[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-7-gfb9600d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-7-gfb9600d |
|
Date: |
Thu, 23 May 2013 12:25:14 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=fb9600debcb3c754a312818101d8186f2e987d06
The branch, master has been updated
via fb9600debcb3c754a312818101d8186f2e987d06 (commit)
via e1aee492d7e419b590d627bd70459b90700187ae (commit)
via 0b3b73698c92081ad3c24f40203d8f34e82778a3 (commit)
via d4da9ba9c0ff7013b00c40c18c9dc0c3a409624c (commit)
via 51611a92f42e240cd842cb26efe6c4d5a1282c00 (commit)
via 6756d265ed53d7b107d31746e8455f10e2ecebdd (commit)
via 45037e75277b622334f347ef261ea347eec6e28d (commit)
from f6f4feb0a2222efcb297e634603621126542e63f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit fb9600debcb3c754a312818101d8186f2e987d06
Author: Andy Wingo <address@hidden>
Date: Sun Apr 28 14:42:01 2013 +0200
add (find-mapped-elf-image) procedure to (system vm objcode) module
* libguile/objcodes.c (register_elf, scm_find_mapped_elf_image): New
interfaces that keep a list of all ELF mappings. Exported from the
(system vm objcode) module.
* module/system/vm/objcode.scm: Export find-mapped-elf-image.
commit e1aee492d7e419b590d627bd70459b90700187ae
Author: Andy Wingo <address@hidden>
Date: Sun Apr 28 14:23:20 2013 +0200
refactor and simplify ELF loader in objcodes.c
* libguile/objcodes.c (sniff_elf_alignment, alloc_aligned)
(copy_and_align_elf_data): New helpers for portably re-aligning ELF
data from read(2) or from a bytevector.
(load_thunk_from_memory): Simplify! Now there is only one procedure
that loads ELF, and it does less: it simply receives the whole image
in one array, hopefully from mmap.
(scm_load_thunk_from_file): Use new map_file_contents helper, and go
through load_thunk_from_memory.
(scm_load_thunk_from_memory): Pass load_thunk_from_memory a piece of
memory that it owns, and that is appropriately aligned.
commit 0b3b73698c92081ad3c24f40203d8f34e82778a3
Author: Andy Wingo <address@hidden>
Date: Thu May 23 14:18:47 2013 +0200
add scm_{to,from}_{u,}intptr_t
* libguile/numbers.h (scm_to_intptr_t, scm_from_intptr_t)
(scm_to_uintptr_t, scm_from_uintptr_t): New defines.
* libguile/foreign.c: Remove definitions here; adapt callers to use new
names with _t suffixes.
commit d4da9ba9c0ff7013b00c40c18c9dc0c3a409624c
Author: Andy Wingo <address@hidden>
Date: Sun Apr 28 09:31:28 2013 +0200
refactor linker to lay out ELF files and memory in the same way
* module/system/vm/linker.scm (make-linker-object):
(linker-object-section-symbol):
(linker-object-symbols*): Create a symbol to the start of a linker
object. Hide it from the external linker-object-symbols* accessor.
(segment-kind, count-segments): Sections without SHF_ALLOC don't get
segments.
(collate-objects-into-segments): Allow for #f segment types. If two
sections have the same type and flags, leave them in the same order.
(align): Allow for 0 alignment.
(add-elf-objects): New helper: puts the ELF data structures (header,
segment table, and section table) in sections of their own. This
lends a nice clarity and conceptual unity to the linker.
(relocate-section-header, allocate-segment): Lay out segments with
congruent, contiguous addresses, so that we can just mmap the file and
if debugging sections that are not in segments are present, they can
be lazily paged in if needed by the kernel's VM system.
(link-elf): Refactor to use the new interfaces.
* test-suite/tests/linker.test: Update to expect the additional sections
for the header and section table.
commit 51611a92f42e240cd842cb26efe6c4d5a1282c00
Author: Andy Wingo <address@hidden>
Date: Sun Apr 28 07:51:42 2013 +0200
elf: add accessors for header members that might need relocation
* module/system/vm/elf.scm (elf-header-shoff-offset)
(elf-section-header-addr-offset, elf-section-header-offset-offset):
New accessors.
commit 6756d265ed53d7b107d31746e8455f10e2ecebdd
Author: Andy Wingo <address@hidden>
Date: Sun Apr 21 16:06:36 2013 +0200
ELF refactor and consequent linker simplifications
* module/system/vm/elf.scm: Add commentary.
(make-elf): Add a constructor similar to make-elf-segment and
make-elf-section.
(write-elf32-header, write-elf64-header, write-elf-header): Take an
<elf> instead of all the fields separately.
(<elf-segment>, <elf-section>): Add "index" property. Adapt
constructors accordingly.
* module/language/objcode/elf.scm (bytecode->elf): Arrange to set the
section indexes when creating ELF sections.
* module/system/vm/linker.scm (fold-values): New helper.
(alloc-segment, relocate-section-header): Arrange to set segment and
section indexes.
(find-shstrndx): New helper, replaces compute-sections-by-name. Now
that sections know their indexes, this is easier.
(allocate-elf, write-elf): New helpers, factored out of link-elf.
Easier now that sections have indexes.
(link-elf): Simplify. Check that the incoming objects have sensible
numbers.
* test-suite/tests/linker.test: Update to set #:index on the linker
objects.
commit 45037e75277b622334f347ef261ea347eec6e28d
Author: Andy Wingo <address@hidden>
Date: Wed Apr 17 23:07:04 2013 +0200
split linker out of elf module
* module/Makefile.am:
* module/system/vm/linker.scm: New file, split out of (system vm elf).
(make-string-table, string-table-intern): Export under their bare
names, instead of make-elf-string-table and elf-string-table-intern.
* module/system/vm/elf.scm: Remove linking capabilities.
(string-table-ref): Export.
* module/language/objcode/elf.scm (bytecode->elf): Adapt to use (system
vm linker).
* test-suite/tests/linker.test: New test.
-----------------------------------------------------------------------
Summary of changes:
libguile/foreign.c | 16 +-
libguile/numbers.h | 28 ++
libguile/objcodes.c | 544 ++++++++++++++++++---------------
module/Makefile.am | 1 +
module/language/objcode/elf.scm | 40 ++--
module/system/vm/elf.scm | 595 +++++++++---------------------------
module/system/vm/linker.scm | 644 +++++++++++++++++++++++++++++++++++++++
module/system/vm/objcode.scm | 5 +-
test-suite/tests/linker.test | 88 ++++++
9 files changed, 1237 insertions(+), 724 deletions(-)
create mode 100644 module/system/vm/linker.scm
create mode 100644 test-suite/tests/linker.test
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 4f5aa58..db8e131 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -65,16 +65,6 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
/* The cell representing the null pointer. */
static SCM null_pointer;
-#if SIZEOF_VOID_P == 4
-# define scm_to_uintptr scm_to_uint32
-# define scm_from_uintptr scm_from_uint32
-#elif SIZEOF_VOID_P == 8
-# define scm_to_uintptr scm_to_uint64
-# define scm_from_uintptr scm_from_uint64
-#else
-# error unsupported pointer size
-#endif
-
/* Raise a null pointer dereference error. */
static void
@@ -125,7 +115,7 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 0,
void *c_finalizer;
scm_t_uintptr c_address;
- c_address = scm_to_uintptr (address);
+ c_address = scm_to_uintptr_t (address);
if (SCM_UNBNDP (finalizer))
c_finalizer = NULL;
else
@@ -173,7 +163,7 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
{
SCM_VALIDATE_POINTER (1, pointer);
- return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
}
#undef FUNC_NAME
@@ -324,7 +314,7 @@ void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<pointer 0x", port);
- scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
+ scm_uintprint (scm_to_uintptr_t (scm_pointer_address (pointer)), 16, port);
scm_putc_unlocked ('>', port);
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 01eb2cf..5cdfbac 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -514,6 +514,34 @@ SCM_API SCM scm_from_mpz (mpz_t rop);
#endif
#endif
+#if SCM_SIZEOF_INTPTR_T == 0
+/* No intptr_t; use size_t functions. */
+#define scm_to_intptr_t scm_to_ssize_t
+#define scm_from_intptr_t scm_from_ssize_t
+#elif SCM_SIZEOF_INTPTR_T == 4
+#define scm_to_intptr_t scm_to_int32
+#define scm_from_intptr_t scm_from_int32
+#elif SCM_SIZEOF_INTPTR_T == 8
+#define scm_to_intptr_t scm_to_int64
+#define scm_from_intptr_t scm_from_int64
+#else
+#error sizeof(intptr_t) is not 4 or 8.
+#endif
+
+#if SCM_SIZEOF_UINTPTR_T == 0
+/* No uintptr_t; use size_t functions. */
+#define scm_to_uintptr_t scm_to_size_t
+#define scm_from_uintptr_t scm_from_size_t
+#elif SCM_SIZEOF_UINTPTR_T == 4
+#define scm_to_uintptr_t scm_to_uint32
+#define scm_from_uintptr_t scm_from_uint32
+#elif SCM_SIZEOF_UINTPTR_T == 8
+#define scm_to_uintptr_t scm_to_uint64
+#define scm_from_uintptr_t scm_from_uint64
+#else
+#error sizeof(uintptr_t) is not 4 or 8.
+#endif
+
/* conversion functions for double */
SCM_API int scm_is_real (SCM val);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 3f51c70..4daba55 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -89,6 +89,8 @@
#define ELFDATA ELFDATA2LSB
#endif
+static void register_elf (char *data, size_t len);
+
enum bytecode_kind
{
BYTECODE_KIND_NONE,
@@ -156,48 +158,105 @@ check_elf_header (const Elf_Ehdr *header)
return NULL;
}
-static int
-segment_flags_to_prot (Elf_Word flags)
+#define IS_ALIGNED(offset, alignment) \
+ (!((offset) & ((alignment) - 1)))
+#define ALIGN(offset, alignment) \
+ ((offset + (alignment - 1)) & ~(alignment - 1))
+
+/* Return the alignment required by the ELF at DATA, of LEN bytes. */
+static size_t
+elf_alignment (const char *data, size_t len)
{
- int prot = 0;
-
- if (flags & PF_X)
- prot |= PROT_EXEC;
- if (flags & PF_W)
- prot |= PROT_WRITE;
- if (flags & PF_R)
- prot |= PROT_READ;
+ Elf_Ehdr *header;
+ int i;
+ size_t alignment = 8;
+
+ if (len < sizeof(Elf_Ehdr))
+ return alignment;
+ header = (Elf_Ehdr *) data;
+ if (header->e_phoff + header->e_phnum * header->e_phentsize >= len)
+ return alignment;
+ for (i = 0; i < header->e_phnum; i++)
+ {
+ Elf_Phdr *phdr;
+ const char *phdr_addr = data + header->e_phoff + i * header->e_phentsize;
- return prot;
+ if (!IS_ALIGNED ((scm_t_uintptr) phdr_addr, alignof_type (Elf_Phdr)))
+ return alignment;
+ phdr = (Elf_Phdr *) phdr_addr;
+
+ if (phdr->p_align & (phdr->p_align - 1))
+ return alignment;
+
+ if (phdr->p_align > alignment)
+ alignment = phdr->p_align;
+ }
+
+ return alignment;
}
-static int
-map_segments (int fd, char **base,
- const Elf_Phdr *from, const Elf_Phdr *to)
+/* This function leaks the memory that it allocates. */
+static char*
+alloc_aligned (size_t len, unsigned alignment)
{
- 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 (alignment == 8)
+ {
+ /* FIXME: Assert that we actually have an 8-byte-aligned malloc. */
+ ret = malloc (len);
+ }
+#if defined(HAVE_SYS_MMAN_H) && defined(MMAP_ANONYMOUS)
+ else if (alignment == SCM_PAGE_SIZE)
+ {
+ ret = mmap (NULL, len, PROT_READ | PROT_WRITE, -1, 0);
+ if (ret == MAP_FAILED)
+ SCM_SYSERROR;
+ }
+#endif
+ else
+ {
+ if (len + alignment < len)
+ abort ();
- if (ret == (char *) -1)
- return 1;
+ ret = malloc (len + alignment - 1);
+ if (!ret)
+ abort ();
+ ret = (char *) ALIGN ((scm_t_uintptr) ret, alignment);
+ }
- if (!*base)
- *base = ret;
+ return ret;
+}
- return 0;
+static char*
+copy_and_align_elf_data (const char *data, size_t len)
+{
+ size_t alignment;
+ char *copy;
+
+ alignment = elf_alignment (data, len);
+ copy = alloc_aligned (len, alignment);
+ memcpy(copy, data, len);
+
+ return copy;
}
+#ifdef HAVE_SYS_MMAN_H
static int
-mprotect_segments (char *base, const Elf_Phdr *from, const Elf_Phdr *to)
+segment_flags_to_prot (Elf_Word flags)
{
- return mprotect (base + from->p_vaddr,
- to->p_vaddr + to->p_memsz - from->p_vaddr,
- segment_flags_to_prot (from->p_flags));
+ 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;
}
+#endif
static char*
process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
@@ -272,152 +331,38 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
#define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
-#ifdef HAVE_SYS_MMAN_H
static SCM
-load_thunk_from_fd_using_mmap (int fd)
-#define FUNC_NAME "load-thunk-from-disk"
+load_thunk_from_memory (char *data, size_t len, int is_read_only)
+#define FUNC_NAME "load-thunk-from-memory"
{
- Elf_Ehdr header;
+ Elf_Ehdr *header;
Elf_Phdr *ph;
const char *err_msg = 0;
- char *base = 0;
- size_t n;
+ size_t n, alignment = 8;
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)
+ if (len < 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;
+ header = (Elf_Ehdr*) data;
- 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;
-
- 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]))
+ if ((err_msg = check_elf_header (header)))
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
-#endif /* HAVE_SYS_MMAN_H */
-
-static SCM
-load_thunk_from_memory (char *data, size_t len)
-#define FUNC_NAME "load-thunk-from-memory"
-{
- 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 (header->e_phnum == 0)
+ ABORT ("no loadable segments");
+ n = header->e_phnum;
- if (len < sizeof header)
+ if (len < header->e_phoff + n * sizeof (Elf_Phdr))
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);
+ ph = (Elf_Phdr*) (data + header->e_phoff);
+ /* Check that the segment table is sane. */
for (i = 0; i < n; i++)
{
- if (!ph[i].p_memsz)
- continue;
-
if (ph[i].p_filesz != ph[i].p_memsz)
ABORT ("expected p_filesz == p_memsz");
@@ -438,90 +383,57 @@ load_thunk_from_memory (char *data, size_t len)
dynamic_segment = i;
}
- if (first_loadable < 0)
+ if (i == 0)
{
- if (ph[i].p_vaddr)
+ if (ph[i].p_vaddr != 0)
ABORT ("first loadable vaddr is not 0");
-
- first_loadable = i;
}
+ else
+ {
+ if (ph[i].p_vaddr < ph[i-1].p_vaddr + ph[i-1].p_memsz)
+ ABORT ("overlapping segments");
- if (ph[i].p_vaddr < memsz)
- ABORT ("overlapping segments");
-
- 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;
+ if (ph[i].p_offset + ph[i].p_filesz > len)
+ ABORT ("segment beyond end of byte array");
+ }
}
- if (first_loadable < 0)
- ABORT ("no loadable segments");
-
if (dynamic_segment < 0)
ABORT ("no PT_DYNAMIC segment");
- /* Now copy segments. */
-
- /* We leak this memory, as we leak the memory mappings in
- load_thunk_from_fd_using_mmap.
+ if (!IS_ALIGNED ((scm_t_uintptr) data, alignment))
+ ABORT ("incorrectly aligned base");
- 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)
+ /* Allow writes to writable pages. */
+ if (is_read_only)
{
- 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)
+#ifdef HAVE_SYS_MMAN_H
+ for (i = 0; i < n; i++)
{
- prev_segment = i;
- continue;
+ if (ph[i].p_flags == PF_R)
+ continue;
+ if (ph[i].p_align != 4096)
+ continue;
+
+ if (mprotect (data + ph[i].p_vaddr,
+ ph[i].p_memsz,
+ segment_flags_to_prot (ph[i].p_flags)))
+ goto cleanup;
}
-
- 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;
+#else
+ ABORT ("expected writable pages");
+#endif
}
- /* 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],
+ if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment],
&init, &entry)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
+ register_elf (data, len);
+
/* Finally! Return the thunk. */
return entry;
@@ -535,22 +447,40 @@ load_thunk_from_memory (char *data, size_t len)
}
#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"
+#define SCM_PAGE_SIZE 4096
+
+static char*
+map_file_contents (int fd, size_t len, int *is_read_only)
+#define FUNC_NAME "load-thunk-from-file"
{
char *data;
- size_t len;
- struct stat st;
- int ret;
- ret = fstat (fd, &st);
- if (ret < 0)
+#ifdef HAVE_SYS_MMAN_H
+ data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0);
+ if (data == MAP_FAILED)
SCM_SYSERROR;
- len = st.st_size;
- data = scm_gc_malloc_pointerless (len, "objcode");
- if (full_read (fd, data, len) != len)
+ *is_read_only = 1;
+#else
+ if (lseek (fd, 0, SEEK_START) < 0)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+
+ /* Given that we are using the read fallback, optimistically assume
+ that the .go files were made with 8-byte alignment.
+ alignment. */
+ data = malloc (end);
+ if (!data)
+ {
+ (void) close (fd);
+ scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes",
+ scm_list_1 (scm_from_size_t (end)));
+ }
+
+ if (full_read (fd, data, end) != end)
{
int errno_save = errno;
(void) close (fd);
@@ -560,11 +490,25 @@ load_thunk_from_fd_using_read (int fd)
scm_misc_error (FUNC_NAME, "short read while loading objcode",
SCM_EOL);
}
- (void) close (fd);
- return load_thunk_from_memory (data, len);
+
+ /* If our optimism failed, fall back. */
+ {
+ unsigned alignment = sniff_elf_alignment (data, end);
+
+ if (alignment != 8)
+ {
+ char *copy = copy_and_align_elf_data (data, end, alignment);
+ free (data);
+ data = copy;
+ }
+ }
+
+ *is_read_only = 0;
+#endif
+
+ return data;
}
#undef FUNC_NAME
-#endif /* ! HAVE_SYS_MMAN_H */
SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
(SCM filename),
@@ -572,7 +516,9 @@ SCM_DEFINE (scm_load_thunk_from_file,
"load-thunk-from-file", 1, 0, 0,
#define FUNC_NAME s_scm_load_thunk_from_file
{
char *c_filename;
- int fd;
+ int fd, is_read_only;
+ off_t end;
+ char *data;
SCM_VALIDATE_STRING (1, filename);
@@ -581,11 +527,15 @@ SCM_DEFINE (scm_load_thunk_from_file,
"load-thunk-from-file", 1, 0, 0,
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
+ end = lseek (fd, 0, SEEK_END);
+ if (end < 0)
+ SCM_SYSERROR;
+
+ data = map_file_contents (fd, end, &is_read_only);
+
+ (void) close (fd);
+
+ return load_thunk_from_memory (data, end, is_read_only);
}
#undef FUNC_NAME
@@ -594,10 +544,20 @@ SCM_DEFINE (scm_load_thunk_from_memory,
"load-thunk-from-memory", 1, 0, 0,
"")
#define FUNC_NAME s_scm_load_thunk_from_memory
{
+ char *data;
+ size_t len;
+
SCM_VALIDATE_BYTEVECTOR (1, bv);
- return load_thunk_from_memory ((char *) SCM_BYTEVECTOR_CONTENTS (bv),
- SCM_BYTEVECTOR_LENGTH (bv));
+ data = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ /* Copy data in order to align it, to trace its GC roots and
+ writable sections, and to keep it in memory. */
+
+ data = copy_and_align_elf_data (data, len);
+
+ return load_thunk_from_memory (data, len, 0);
}
#undef FUNC_NAME
@@ -652,6 +612,107 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
}
#undef FUNC_NAME
+struct mapped_elf_image
+{
+ char *start;
+ char *end;
+};
+
+static struct mapped_elf_image *mapped_elf_images = NULL;
+static size_t mapped_elf_images_count = 0;
+static size_t mapped_elf_images_allocated = 0;
+
+static size_t
+find_mapped_elf_insertion_index (char *ptr)
+{
+ /* "mapped_elf_images_count" must never be dereferenced. */
+ size_t start = 0, end = mapped_elf_images_count;
+
+ while (start < end)
+ {
+ size_t n = start + (end - start) / 2;
+
+ if (ptr < mapped_elf_images[n].end)
+ end = n;
+ else
+ start = n + 1;
+ }
+
+ return start;
+}
+
+static void
+register_elf (char *data, size_t len)
+{
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ /* My kingdom for a generic growable sorted vector library. */
+ if (mapped_elf_images_count == mapped_elf_images_allocated)
+ {
+ struct mapped_elf_image *prev;
+ size_t n;
+
+ if (mapped_elf_images_allocated)
+ mapped_elf_images_allocated *= 2;
+ else
+ mapped_elf_images_allocated = 16;
+
+ prev = mapped_elf_images;
+ mapped_elf_images =
+ scm_gc_malloc_pointerless (sizeof (*mapped_elf_images)
+ * mapped_elf_images_allocated,
+ "mapped elf images");
+
+ for (n = 0; n < mapped_elf_images_count; n++)
+ {
+ mapped_elf_images[n].start = prev[n].start;
+ mapped_elf_images[n].end = prev[n].end;
+ }
+ }
+
+ {
+ size_t end;
+ size_t n = find_mapped_elf_insertion_index (data);
+
+ for (end = mapped_elf_images_count; n < end; end--)
+ {
+ mapped_elf_images[end].start = mapped_elf_images[end - 1].start;
+ mapped_elf_images[end].end = mapped_elf_images[end - 1].end;
+ }
+ mapped_elf_images_count++;
+
+ mapped_elf_images[n].start = data;
+ mapped_elf_images[n].end = data + len;
+ }
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+}
+
+static SCM
+scm_find_mapped_elf_image (SCM ip)
+{
+ char *ptr = (char *) scm_to_uintptr_t (ip);
+ SCM result;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ size_t n = find_mapped_elf_insertion_index ((char *) ptr);
+ if (n < mapped_elf_images_count
+ && mapped_elf_images[n].start <= ptr
+ && ptr < mapped_elf_images[n].end)
+ {
+ signed char *data = (signed char *) mapped_elf_images[n].start;
+ size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
+ result = scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
+ }
+ else
+ result = SCM_BOOL_F;
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ return result;
+}
+
/*
* Scheme interface
@@ -790,6 +851,9 @@ scm_init_objcodes (void)
#include "libguile/objcodes.x"
#endif
+ scm_c_define_gsubr ("find-mapped-elf-image", 1, 0, 0,
+ (scm_t_subr) scm_find_mapped_elf_image);
+
scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
}
diff --git a/module/Makefile.am b/module/Makefile.am
index 4daf7cf..0601a05 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -348,6 +348,7 @@ SYSTEM_SOURCES = \
system/vm/inspect.scm \
system/vm/coverage.scm \
system/vm/elf.scm \
+ system/vm/linker.scm \
system/vm/frame.scm \
system/vm/instruction.scm \
system/vm/objcode.scm \
diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
index 9654c08..981c398 100644
--- a/module/language/objcode/elf.scm
+++ b/module/language/objcode/elf.scm
@@ -1,6 +1,6 @@
;;; Embedding bytecode in ELF
-;; Copyright (C) 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -30,25 +30,27 @@
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (system vm elf)
+ #:use-module (system vm linker)
#:export (write-objcode))
(define (bytecode->elf bv)
- (let ((string-table (make-elf-string-table)))
+ (let ((string-table (make-string-table)))
(define (intern-string! string)
(call-with-values
- (lambda () (elf-string-table-intern string-table string))
+ (lambda () (string-table-intern string-table string))
(lambda (table idx)
(set! string-table table)
idx)))
- (define (make-object name bv relocs . kwargs)
+ (define (make-object index name bv relocs . kwargs)
(let ((name-idx (intern-string! (symbol->string name))))
- (make-elf-object (apply make-elf-section
- #:name name-idx
- #:size (bytevector-length bv)
- kwargs)
- bv relocs
- (list (make-elf-symbol name 0)))))
- (define (make-dynamic-section word-size endianness)
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-linker-symbol name 0)))))
+ (define (make-dynamic-section index word-size endianness)
(define (make-dynamic-section/32)
(let ((bv (make-bytevector 24 0)))
(bytevector-u32-set! bv 0 DT_GUILE_RTL_VERSION endianness)
@@ -57,7 +59,7 @@
(bytevector-u32-set! bv 12 0 endianness)
(bytevector-u32-set! bv 16 DT_NULL endianness)
(bytevector-u32-set! bv 20 0 endianness)
- (values bv (make-elf-reloc 'abs32/1 12 0 '.rtl-text))))
+ (values bv (make-linker-reloc 'abs32/1 12 0 '.rtl-text))))
(define (make-dynamic-section/64)
(let ((bv (make-bytevector 48 0)))
(bytevector-u64-set! bv 0 DT_GUILE_RTL_VERSION endianness)
@@ -66,26 +68,26 @@
(bytevector-u64-set! bv 24 0 endianness)
(bytevector-u64-set! bv 32 DT_NULL endianness)
(bytevector-u64-set! bv 40 0 endianness)
- (values bv (make-elf-reloc 'abs64/1 24 0 '.rtl-text))))
+ (values bv (make-linker-reloc 'abs64/1 24 0 '.rtl-text))))
(call-with-values (lambda ()
(case word-size
((4) (make-dynamic-section/32))
((8) (make-dynamic-section/64))
(else (error "unexpected word size" word-size))))
(lambda (bv reloc)
- (make-object '.dynamic bv (list reloc)
+ (make-object index '.dynamic bv (list reloc)
#:type SHT_DYNAMIC #:flags SHF_ALLOC))))
- (define (link-string-table)
+ (define (make-string-table index)
(intern-string! ".shstrtab")
- (make-object '.shstrtab (link-elf-string-table string-table) '()
+ (make-object index '.shstrtab (link-string-table string-table) '()
#:type SHT_STRTAB #:flags 0))
(let* ((word-size (target-word-size))
(endianness (target-endianness))
- (text (make-object '.rtl-text bv '()))
- (dt (make-dynamic-section word-size endianness))
+ (text (make-object 1 '.rtl-text bv '()))
+ (dt (make-dynamic-section 2 word-size endianness))
;; This needs to be linked last, because linking other
;; sections adds entries to the string table.
- (shstrtab (link-string-table)))
+ (shstrtab (make-string-table 3)))
(link-elf (list text dt shstrtab)
#:endianness endianness #:word-size word-size))))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 040b274..b59970c 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -1,6 +1,6 @@
;;; Guile ELF reader and writer
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -16,6 +16,19 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;; Commentary:
+;;;
+;;; A module to read and write Executable and Linking Format (ELF)
+;;; files.
+;;;
+;;; This module exports a number of record types that represent the
+;;; various parts that make up ELF files. Fundamentally this is the
+;;; main header, the segment headers (program headers), and the section
+;;; headers. It also exports bindings for symbolic constants and
+;;; utilities to parse and write special kinds of ELF sections.
+;;;
+;;; See elf(5) for more information on ELF.
+;;;
;;; Code:
(define-module (system vm elf)
@@ -27,30 +40,50 @@
#:use-module (ice-9 vlist)
#:export (has-elf-header?
- make-elf elf?
+ (make-elf* . make-elf)
+ elf?
elf-bytes elf-word-size elf-byte-order
elf-abi elf-type elf-machine-type
elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx
+ elf-header-len elf-header-shoff-offset
+ write-elf-header
+
(make-elf-segment* . make-elf-segment)
elf-segment?
+ elf-segment-index
elf-segment-type elf-segment-offset elf-segment-vaddr
elf-segment-paddr elf-segment-filesz elf-segment-memsz
elf-segment-flags elf-segment-align
+ elf-program-header-len write-elf-program-header
+
+ PT_NULL PT_LOAD PT_DYNAMIC PT_INTERP PT_NOTE PT_SHLIB
+ PT_PHDR PT_TLS PT_NUM PT_LOOS PT_GNU_EH_FRAME PT_GNU_STACK
+ PT_GNU_RELRO
+
+ PF_R PF_W PF_X
+
(make-elf-section* . make-elf-section)
elf-section?
+ elf-section-index
elf-section-name elf-section-type elf-section-flags
elf-section-addr elf-section-offset elf-section-size
elf-section-link elf-section-info elf-section-addralign
elf-section-entsize
+ elf-section-header-len elf-section-header-addr-offset
+ elf-section-header-offset-offset
+ write-elf-section-header
+
make-elf-symbol elf-symbol?
elf-symbol-name elf-symbol-value elf-symbol-size
elf-symbol-info elf-symbol-other elf-symbol-shndx
elf-symbol-binding elf-symbol-type elf-symbol-visibility
+ SHN_UNDEF
+
SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB
SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY
@@ -72,6 +105,8 @@
DT_GUILE_RTL_VERSION DT_HIGUILE DT_LOOS DT_HIOS DT_LOPROC
DT_HIPROC
+ string-table-ref
+
STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU
STB_HIOS STB_LOPROC STB_HIPROC
@@ -89,23 +124,7 @@
elf-symbol-table-ref
parse-elf-note
- elf-note-name elf-note-desc elf-note-type
-
- (make-string-table . make-elf-string-table)
- (string-table-intern . elf-string-table-intern)
- (link-string-table . link-elf-string-table)
-
- (make-reloc . make-elf-reloc)
- (make-symbol . make-elf-symbol)
-
- (make-object . make-elf-object)
- (object? . elf-object?)
- (object-section . elf-object-section)
- (object-bv . elf-object-bv)
- (object-relocs . elf-object-relocs)
- (object-symbols . elf-object-symbols)
-
- link-elf))
+ elf-note-name elf-note-desc elf-note-type))
;; #define EI_NIDENT 16
@@ -133,6 +152,11 @@
((4) elf32-header-len)
((8) elf64-header-len)
(else (error "invalid word size" word-size))))
+(define (elf-header-shoff-offset word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 40)
+ (else (error "bad word size" word-size))))
(define ELFCLASS32 1) ; 32-bit objects
(define ELFCLASS64 2) ; 64-bit objects
@@ -242,6 +266,26 @@
(shnum elf-shnum)
(shstrndx elf-shstrndx))
+(define* (make-elf* #:key (bytes #f)
+ (byte-order (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE)
+ (entry 0)
+ (phoff (elf-header-len word-size))
+ (shoff -1)
+ (flags 0)
+ (ehsize (elf-header-len word-size))
+ (phentsize (elf-program-header-len word-size))
+ (phnum 0)
+ (shentsize (elf-section-header-len word-size))
+ (shnum 0)
+ (shstrndx SHN_UNDEF))
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx))
+
(define (parse-elf32 bv byte-order)
(make-elf bv 4 byte-order
(bytevector-u8-ref bv 7)
@@ -276,28 +320,27 @@
(bytevector-u8-set! bv 14 0)
(bytevector-u8-set! bv 15 0))
-(define (write-elf32 bv byte-order abi type machine-type
- entry phoff shoff flags ehsize phentsize phnum
- shentsize shnum shstrndx)
- (write-elf-ident bv ELFCLASS32
- (case byte-order
- ((little) ELFDATA2LSB)
- ((big) ELFDATA2MSB)
- (else (error "unknown endianness" byte-order)))
- abi)
- (bytevector-u16-set! bv 16 type byte-order)
- (bytevector-u16-set! bv 18 machine-type byte-order)
- (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
- (bytevector-u32-set! bv 24 entry byte-order)
- (bytevector-u32-set! bv 28 phoff byte-order)
- (bytevector-u32-set! bv 32 shoff byte-order)
- (bytevector-u32-set! bv 36 flags byte-order)
- (bytevector-u16-set! bv 40 ehsize byte-order)
- (bytevector-u16-set! bv 42 phentsize byte-order)
- (bytevector-u16-set! bv 44 phnum byte-order)
- (bytevector-u16-set! bv 46 shentsize byte-order)
- (bytevector-u16-set! bv 48 shnum byte-order)
- (bytevector-u16-set! bv 50 shstrndx byte-order))
+(define (write-elf32-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS32
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
+ (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))
(define (parse-elf64 bv byte-order)
(make-elf bv 8 byte-order
@@ -315,28 +358,27 @@
(bytevector-u16-ref bv 60 byte-order)
(bytevector-u16-ref bv 62 byte-order)))
-(define (write-elf64 bv byte-order abi type machine-type
- entry phoff shoff flags ehsize phentsize phnum
- shentsize shnum shstrndx)
- (write-elf-ident bv ELFCLASS64
- (case byte-order
- ((little) ELFDATA2LSB)
- ((big) ELFDATA2MSB)
- (else (error "unknown endianness" byte-order)))
- abi)
- (bytevector-u16-set! bv 16 type byte-order)
- (bytevector-u16-set! bv 18 machine-type byte-order)
- (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
- (bytevector-u64-set! bv 24 entry byte-order)
- (bytevector-u64-set! bv 32 phoff byte-order)
- (bytevector-u64-set! bv 40 shoff byte-order)
- (bytevector-u32-set! bv 48 flags byte-order)
- (bytevector-u16-set! bv 52 ehsize byte-order)
- (bytevector-u16-set! bv 54 phentsize byte-order)
- (bytevector-u16-set! bv 56 phnum byte-order)
- (bytevector-u16-set! bv 58 shentsize byte-order)
- (bytevector-u16-set! bv 60 shnum byte-order)
- (bytevector-u16-set! bv 62 shstrndx byte-order))
+(define (write-elf64-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS64
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
+ (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))
(define (parse-elf bv)
(cond
@@ -354,28 +396,12 @@
(else
(error "Invalid ELF" bv))))
-(define* (write-elf-header bv #:key
- (byte-order (target-endianness))
- (word-size (target-word-size))
- (abi ELFOSABI_STANDALONE)
- (type ET_DYN)
- (machine-type EM_NONE)
- (entry 0)
- (phoff (elf-header-len word-size))
- (shoff -1)
- (flags 0)
- (ehsize (elf-header-len word-size))
- (phentsize (elf-program-header-len word-size))
- (phnum 0)
- (shentsize (elf-section-header-len word-size))
- (shnum 0)
- (shstrndx SHN_UNDEF))
- ((case word-size
- ((4) write-elf32)
- ((8) write-elf64)
- (else (error "unknown word size" word-size)))
- bv byte-order abi type machine-type entry phoff shoff
- flags ehsize phentsize phnum shentsize shnum shstrndx))
+(define* (write-elf-header bv elf)
+ ((case (elf-word-size elf)
+ ((4) write-elf32-header)
+ ((8) write-elf64-header)
+ (else (error "unknown word size" (elf-word-size elf))))
+ bv elf))
;;
;; Segment types
@@ -402,8 +428,9 @@
(define PF_R (ash 1 2)) ; Segment is readable
(define-record-type <elf-segment>
- (make-elf-segment type offset vaddr paddr filesz memsz flags align)
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align)
elf-segment?
+ (index elf-segment-index)
(type elf-segment-type)
(offset elf-segment-offset)
(vaddr elf-segment-vaddr)
@@ -413,11 +440,11 @@
(flags elf-segment-flags)
(align elf-segment-align))
-(define* (make-elf-segment* #:key (type PT_LOAD) (offset 0) (vaddr 0)
+(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr
0)
(paddr 0) (filesz 0) (memsz filesz)
(flags (logior PF_W PF_R))
(align 8))
- (make-elf-segment type offset vaddr paddr filesz memsz flags align))
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align))
;; typedef struct {
;; uint32_t p_type;
@@ -430,9 +457,10 @@
;; uint32_t p_align;
;; } Elf32_Phdr;
-(define (parse-elf32-program-header bv offset byte-order)
+(define (parse-elf32-program-header index bv offset byte-order)
(if (<= (+ offset 32) (bytevector-length bv))
- (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u32-ref bv (+ offset 8) byte-order)
(bytevector-u32-ref bv (+ offset 12) byte-order)
@@ -466,9 +494,10 @@
;; NB: position of `flags' is different!
-(define (parse-elf64-program-header bv offset byte-order)
+(define (parse-elf64-program-header index bv offset byte-order)
(if (<= (+ offset 56) (bytevector-length bv))
- (make-elf-segment (bytevector-u32-ref bv offset byte-order)
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u64-ref bv (+ offset 8) byte-order)
(bytevector-u64-ref bv (+ offset 16) byte-order)
(bytevector-u64-ref bv (+ offset 24) byte-order)
@@ -519,8 +548,10 @@
(lp (1- n) (cons (elf-segment elf (1- n)) out)))))
(define-record-type <elf-section>
- (make-elf-section name type flags addr offset size link info addralign
entsize)
+ (make-elf-section index name type flags
+ addr offset size link info addralign entsize)
elf-section?
+ (index elf-section-index)
(name elf-section-name)
(type elf-section-type)
(flags elf-section-flags)
@@ -532,10 +563,10 @@
(addralign elf-section-addralign)
(entsize elf-section-entsize))
-(define* (make-elf-section* #:key (name 0) (type SHT_PROGBITS)
+(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type
SHT_PROGBITS)
(flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
(link 0) (info 0) (addralign 8) (entsize 0))
- (make-elf-section name type flags addr offset size link info addralign
+ (make-elf-section index name type flags addr offset size link info addralign
entsize))
;; typedef struct {
@@ -551,9 +582,10 @@
;; uint32_t sh_entsize;
;; } Elf32_Shdr;
-(define (parse-elf32-section-header bv offset byte-order)
+(define (parse-elf32-section-header index bv offset byte-order)
(if (<= (+ offset 40) (bytevector-length bv))
- (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u32-ref bv (+ offset 8) byte-order)
(bytevector-u32-ref bv (+ offset 12) byte-order)
@@ -597,9 +629,22 @@
((8) 64)
(else (error "bad word size" word-size))))
-(define (parse-elf64-section-header bv offset byte-order)
+(define (elf-section-header-addr-offset word-size)
+ (case word-size
+ ((4) 12)
+ ((8) 16)
+ (else (error "bad word size" word-size))))
+
+(define (elf-section-header-offset-offset word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf64-section-header index bv offset byte-order)
(if (<= (+ offset 64) (bytevector-length bv))
- (make-elf-section (bytevector-u32-ref bv offset byte-order)
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
(bytevector-u32-ref bv (+ offset 4) byte-order)
(bytevector-u64-ref bv (+ offset 8) byte-order)
(bytevector-u64-ref bv (+ offset 16) byte-order)
@@ -630,6 +675,7 @@
((4) parse-elf32-section-header)
((8) parse-elf64-section-header)
(else (error "unhandled pointer size")))
+ n
(elf-bytes elf)
(+ (elf-shoff elf) (* n (elf-shentsize elf)))
(elf-byte-order elf)))
@@ -902,354 +948,3 @@
(bytevector-copy! bv (+ offset 12) name 0 (1- namesz))
(bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz)
(make-elf-note (utf8->string name) desc type)))))
-
-
-
-
-;;;
-;;; All of that was the parser. Now, on to a linker.
-;;;
-
-;; A relocation records a reference to a symbol. When the symbol is
-;; resolved to an address, the reloc location will be updated to point
-;; to the address.
-;;
-;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
-;; Rel32/4 is a relative signed offset in 32-bit units. Either can have
-;; an arbitrary addend as well.
-;;
-(define-record-type <reloc>
- (make-reloc type loc addend symbol)
- reloc?
- (type reloc-type) ;; rel32/4, abs32/1, abs64/1
- (loc reloc-loc)
- (addend reloc-addend)
- (symbol reloc-symbol))
-
-;; A symbol is an association between a name and an address. The
-;; address is always in regard to some particular address space. When
-;; objects come into the linker, their symbols live in the object
-;; address space. When the objects are allocated into ELF segments, the
-;; symbols will be relocated into memory address space, corresponding to
-;; the position the ELF will be loaded at.
-;;
-(define-record-type <symbol>
- (make-symbol name address)
- symbol?
- (name symbol-name)
- (address symbol-address))
-
-(define-record-type <object>
- (make-object section bv relocs symbols)
- object?
- (section object-section)
- (bv object-bv)
- (relocs object-relocs)
- (symbols object-symbols))
-
-(define (make-string-table)
- '(("" 0 #vu8())))
-
-(define (string-table-length table)
- (let ((last (car table)))
- ;; The + 1 is for the trailing NUL byte.
- (+ (cadr last) (bytevector-length (caddr last)) 1)))
-
-(define (string-table-intern table str)
- (cond
- ((assoc str table)
- => (lambda (ent)
- (values table (cadr ent))))
- (else
- (let* ((next (string-table-length table)))
- (values (cons (list str next (string->utf8 str))
- table)
- next)))))
-
-(define (link-string-table table)
- (let ((out (make-bytevector (string-table-length table) 0)))
- (for-each
- (lambda (ent)
- (let ((bytes (caddr ent)))
- (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
- table)
- out))
-
-(define (segment-kind section)
- (let ((flags (elf-section-flags section)))
- (cons (cond
- ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
- ((zero? (logand SHF_ALLOC flags)) PT_NOTE)
- (else PT_LOAD))
- (logior (if (zero? (logand SHF_ALLOC flags))
- 0
- PF_R)
- (if (zero? (logand SHF_EXECINSTR flags))
- 0
- PF_X)
- (if (zero? (logand SHF_WRITE flags))
- 0
- PF_W)))))
-
-(define (group-by-cars ls)
- (let lp ((in ls) (k #f) (group #f) (out '()))
- (cond
- ((null? in)
- (reverse!
- (if group
- (cons (cons k (reverse! group)) out)
- out)))
- ((and group (equal? k (caar in)))
- (lp (cdr in) k (cons (cdar in) group) out))
- (else
- (lp (cdr in) (caar in) (list (cdar in))
- (if group
- (cons (cons k (reverse! group)) out)
- out))))))
-
-(define (collate-objects-into-segments objects)
- (group-by-cars
- (stable-sort!
- (map (lambda (o)
- (cons (segment-kind (object-section o)) o))
- objects)
- (lambda (x y)
- (let ((x-type (caar x)) (y-type (caar y))
- (x-flags (cdar x)) (y-flags (cdar y))
- (x-section (object-section (cdr x)))
- (y-section (object-section (cdr y))))
- (cond
- ((not (equal? x-flags y-flags))
- (< x-flags y-flags))
- ((not (equal? x-type y-type))
- (< x-type y-type))
- ((not (equal? (elf-section-type x-section)
- (elf-section-type y-section)))
- (cond
- ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
- ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
- (else (< (elf-section-type x-section)
- (elf-section-type y-section)))))
- (else
- (< (elf-section-size x-section)
- (elf-section-size y-section)))))))))
-
-(define (align address alignment)
- (+ address
- (modulo (- alignment (modulo address alignment)) alignment)))
-
-(define (fold1 proc ls s0)
- (let lp ((ls ls) (s0 s0))
- (if (null? ls)
- s0
- (lp (cdr ls) (proc (car ls) s0)))))
-
-(define (fold2 proc ls s0 s1)
- (let lp ((ls ls) (s0 s0) (s1 s1))
- (if (null? ls)
- (values s0 s1)
- (receive (s0 s1) (proc (car ls) s0 s1)
- (lp (cdr ls) s0 s1)))))
-
-(define (fold4 proc ls s0 s1 s2 s3)
- (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3))
- (if (null? ls)
- (values s0 s1 s2 s3)
- (receive (s0 s1 s2 s3) (proc (car ls) s0 s1 s2 s3)
- (lp (cdr ls) s0 s1 s2 s3)))))
-
-(define (fold5 proc ls s0 s1 s2 s3 s4)
- (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3) (s4 s4))
- (if (null? ls)
- (values s0 s1 s2 s3 s4)
- (receive (s0 s1 s2 s3 s4) (proc (car ls) s0 s1 s2 s3 s4)
- (lp (cdr ls) s0 s1 s2 s3 s4)))))
-
-(define (relocate-section-header sec fileaddr memaddr)
- (make-elf-section (elf-section-name sec) (elf-section-type sec)
- (elf-section-flags sec) memaddr
- fileaddr (elf-section-size sec)
- (elf-section-link sec) (elf-section-info sec)
- (elf-section-addralign sec) (elf-section-entsize sec)))
-
-(define *page-size* 4096)
-
-;; Adds object symbols to global table, relocating them from object
-;; address space to memory address space.
-(define (add-symbols symbols offset symtab)
- (fold1 (lambda (symbol symtab)
- (let ((name (symbol-name symbol))
- (addr (symbol-address symbol)))
- (vhash-consq name (make-symbol name (+ addr offset)) symtab)))
- symbols
- symtab))
-
-(define (alloc-segment type flags objects fileaddr memaddr symtab alignment)
- (let* ((loadable? (not (zero? flags)))
- (alignment (fold1 (lambda (o alignment)
- (lcm (elf-section-addralign (object-section o))
- alignment))
- objects
- alignment))
- (fileaddr (align fileaddr alignment))
- (memaddr (align memaddr alignment)))
- (receive (objects fileend memend symtab)
- (fold4 (lambda (o out fileaddr memaddr symtab)
- (let* ((section (object-section o))
- (fileaddr
- (if (= (elf-section-type section) SHT_NOBITS)
- fileaddr
- (align fileaddr (elf-section-addralign section))))
- (memaddr
- (align memaddr (elf-section-addralign section))))
- (values
- (cons (make-object (relocate-section-header section
fileaddr
- memaddr)
- (object-bv o)
- (object-relocs o)
- (object-symbols o))
- out)
- (if (= (elf-section-type section) SHT_NOBITS)
- fileaddr
- (+ fileaddr (elf-section-size section)))
- (+ memaddr (elf-section-size section))
- (add-symbols (object-symbols o) memaddr symtab))))
- objects '() fileaddr memaddr symtab)
- (values
- (make-elf-segment* #:type type #:offset fileaddr
- #:vaddr (if loadable? memaddr 0)
- #:filesz (- fileend fileaddr)
- #:memsz (if loadable? (- memend memaddr) 0)
- #:flags flags #:align alignment)
- (reverse objects)
- symtab))))
-
-(define (process-reloc reloc bv file-offset mem-offset symtab endianness)
- (let ((ent (vhash-assq (reloc-symbol reloc) symtab)))
- (unless ent
- (error "Undefined symbol" (reloc-symbol reloc)))
- (let* ((file-loc (+ (reloc-loc reloc) file-offset))
- (mem-loc (+ (reloc-loc reloc) mem-offset))
- (addr (symbol-address (cdr ent))))
- (case (reloc-type reloc)
- ((rel32/4)
- (let ((diff (- addr mem-loc)))
- (unless (zero? (modulo diff 4))
- (error "Bad offset" reloc symbol mem-offset))
- (bytevector-s32-set! bv file-loc
- (+ (/ diff 4) (reloc-addend reloc))
- endianness)))
- ((abs32/1)
- (bytevector-u32-set! bv file-loc addr endianness))
- ((abs64/1)
- (bytevector-u64-set! bv file-loc addr endianness))
- (else
- (error "bad reloc type" reloc))))))
-
-(define (write-object bv o symtab endianness)
- (let* ((section (object-section o))
- (offset (elf-section-offset section))
- (addr (elf-section-addr section))
- (len (elf-section-size section))
- (bytes (object-bv o))
- (relocs (object-relocs o)))
- (if (not (= (elf-section-type section) SHT_NOBITS))
- (begin
- (if (not (= (elf-section-size section) (bytevector-length bytes)))
- (error "unexpected length" section bytes))
- (bytevector-copy! bytes 0 bv offset len)
- (for-each (lambda (reloc)
- (process-reloc reloc bv offset addr symtab endianness))
- relocs)))))
-
-(define (compute-sections-by-name seglists)
- (let lp ((in (apply append (map cdr seglists)))
- (n 1) (out '()) (shstrtab #f))
- (if (null? in)
- (fold1 (lambda (x tail)
- (cond
- ((false-if-exception
- (string-table-ref shstrtab (car x)))
- => (lambda (str) (acons str (cdr x) tail)))
- (else tail)))
- out '())
- (let* ((section (object-section (car in)))
- (bv (object-bv (car in)))
- (name (elf-section-name section)))
- (lp (cdr in) (1+ n) (acons name n out)
- (or shstrtab
- (and (= (elf-section-type section) SHT_STRTAB)
- (equal? (false-if-exception
- (string-table-ref bv name))
- ".shstrtab")
- bv)))))))
-
-;; Given a list of section-header/bytevector pairs, collate the sections
-;; into segments, allocate the segments, allocate the ELF bytevector,
-;; and write the segments into the bytevector, relocating as we go.
-;;
-(define* (link-elf objects #:key
- (page-aligned? #t)
- (endianness (target-endianness))
- (word-size (target-word-size)))
- (let* ((seglists (collate-objects-into-segments objects))
- (sections-by-name (compute-sections-by-name seglists))
- (nsegments (length seglists))
- (nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
- (program-headers-offset (elf-header-len word-size))
- (fileaddr (+ program-headers-offset
- (* nsegments (elf-program-header-len word-size))))
- (memaddr 0))
- (receive (out fileend memend symtab _)
- (fold5
- (lambda (x out fileaddr memaddr symtab prev-flags)
- (let ((type (caar x))
- (flags (cdar x))
- (objects (cdr x)))
- (receive (segment objects symtab)
- (alloc-segment type flags objects fileaddr memaddr symtab
- (if (and page-aligned?
- (not (= flags prev-flags)))
- *page-size*
- 8))
- (values
- (cons (cons segment objects) out)
- (+ (elf-segment-offset segment) (elf-segment-filesz segment))
- (if (zero? (elf-segment-memsz segment))
- memaddr
- (+ (elf-segment-vaddr segment)
- (elf-segment-memsz segment)))
- symtab
- flags))))
- seglists '() fileaddr memaddr vlist-null 0)
- (let* ((out (reverse! out))
- (section-table-offset (+ (align fileend word-size)))
- (fileend (+ section-table-offset
- (* nsections (elf-section-header-len word-size))))
- (bv (make-bytevector fileend 0)))
- (write-elf-header bv #:byte-order endianness #:word-size word-size
- #:phoff program-headers-offset #:phnum nsegments
- #:shoff section-table-offset #:shnum nsections
- #:shstrndx (or (assoc-ref sections-by-name
".shstrtab")
- SHN_UNDEF))
- (write-elf-section-header bv section-table-offset
- endianness word-size
- (make-elf-section* #:type SHT_NULL #:flags 0
- #:addralign 0))
- (fold2 (lambda (x phidx shidx)
- (write-elf-program-header
- bv (+ program-headers-offset
- (* (elf-program-header-len word-size) phidx))
- endianness word-size (car x))
- (values
- (1+ phidx)
- (fold1 (lambda (o shidx)
- (write-object bv o symtab endianness)
- (write-elf-section-header
- bv (+ section-table-offset
- (* (elf-section-header-len word-size) shidx))
- endianness word-size (object-section o))
- (1+ shidx))
- (cdr x) shidx)))
- out 0 1)
- bv))))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
new file mode 100644
index 0000000..a5d43f2
--- /dev/null
+++ b/module/system/vm/linker.scm
@@ -0,0 +1,644 @@
+;;; Guile ELF linker
+
+;; Copyright (C) 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 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
+
+;;; Commentary:
+;;;
+;;; A linker combines several linker objects into an executable or a
+;;; loadable library.
+;;;
+;;; There are several common formats for libraries out there. Since
+;;; Guile includes its own linker and loader, we are free to choose any
+;;; format, or make up our own.
+;;;
+;;; There are essentially two requirements for a linker format:
+;;; libraries should be able to be loaded with the minimal amount of
+;;; work; and they should support introspection in some way, in order to
+;;; enable good debugging.
+;;;
+;;; These requirements are somewhat at odds, as loading should not have
+;;; to stumble over features related to introspection. It so happens
+;;; that a lot of smart people have thought about this situation, and
+;;; the ELF format embodies the outcome of their thinking. Guile uses
+;;; ELF as its format, regardless of the platform's native library
+;;; format. It's not inconceivable that Guile could interoperate with
+;;; the native dynamic loader at some point, but it's not a near-term
+;;; goal.
+;;;
+;;; Guile's linker takes a list of objects, sorts them according to
+;;; similarity from the perspective of the loader, then writes them out
+;;; into one big bytevector in ELF format.
+;;;
+;;; It is often the case that different parts of a library need to refer
+;;; to each other. For example, program text may need to refer to a
+;;; constant from writable memory. When the linker places sections
+;;; (linker objects) into specific locations in the linked bytevector,
+;;; it needs to fix up those references. This process is called
+;;; /relocation/. References needing relocations are recorded in
+;;; "linker-reloc" objects, and collected in a list in each
+;;; "linker-object". The actual definitions of the references are
+;;; stored in "linker-symbol" objects, also collected in a list in each
+;;; "linker-object".
+;;;
+;;; By default, the ELF files created by the linker include some padding
+;;; so that different parts of the file can be loaded in with different
+;;; permissions. For example, some parts of the file are read-only and
+;;; thus can be shared between processes. Some parts of the file don't
+;;; need to be loaded at all. However this padding can be too much for
+;;; interactive compilation, when the code is never written out to disk;
+;;; in that case, pass #:page-aligned? #f to `link-elf'.
+;;;
+;;; Code:
+
+(define-module (system vm linker)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (system vm elf)
+ #:export (make-linker-reloc
+ make-linker-symbol
+
+ make-linker-object
+ linker-object?
+ linker-object-section
+ linker-object-bv
+ linker-object-relocs
+ (linker-object-symbols* . linker-object-symbols)
+
+ make-string-table
+ string-table-intern
+ link-string-table
+
+ link-elf))
+
+(define-syntax fold-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ proc list seed ...)
+ (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
+ #'(let ((p proc))
+ (let lp ((l list) (s seed) ...)
+ (match l
+ (() (values s ...))
+ ((elt . l)
+ (call-with-values (lambda () (p elt s ...))
+ (lambda (s ...) (lp l s ...))))))))))))
+
+;; A relocation records a reference to a symbol. When the symbol is
+;; resolved to an address, the reloc location will be updated to point
+;; to the address.
+;;
+;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
+;; Rel32/4 is a relative signed offset in 32-bit units. Either can have
+;; an arbitrary addend as well.
+;;
+(define-record-type <linker-reloc>
+ (make-linker-reloc type loc addend symbol)
+ linker-reloc?
+ (type linker-reloc-type) ;; rel32/4, abs32/1, abs64/1
+ (loc linker-reloc-loc)
+ (addend linker-reloc-addend)
+ (symbol linker-reloc-symbol))
+
+;; A symbol is an association between a name and an address. The
+;; address is always in regard to some particular address space. When
+;; objects come into the linker, their symbols live in the object
+;; address space. When the objects are allocated into ELF segments, the
+;; symbols will be relocated into memory address space, corresponding to
+;; the position the ELF will be loaded at.
+;;
+(define-record-type <linker-symbol>
+ (make-linker-symbol name address)
+ linker-symbol?
+ (name linker-symbol-name)
+ (address linker-symbol-address))
+
+(define-record-type <linker-object>
+ (%make-linker-object section bv relocs symbols)
+ linker-object?
+ (section linker-object-section)
+ (bv linker-object-bv)
+ (relocs linker-object-relocs)
+ (symbols linker-object-symbols))
+
+(define (make-linker-object section bv relocs symbols)
+ "Create a linker object with the @code{<elf-section>} header
address@hidden, bytevector contents @var{bv}, list of linker relocations
address@hidden, and list of linker symbols @var{symbols}."
+ (%make-linker-object section bv relocs
+ ;; Hide a symbol to the beginning of the section
+ ;; in the symbols.
+ (cons (make-linker-symbol (gensym "*section*") 0)
+ symbols)))
+(define (linker-object-section-symbol object)
+ "Return the linker symbol corresponding to the start of this section."
+ (car (linker-object-symbols object)))
+(define (linker-object-symbols* object)
+ "Return the linker symbols defined by the user for this this section."
+ (cdr (linker-object-symbols object)))
+
+(define (make-string-table)
+ "Return a functional string table with one entry: the empty string."
+ '(("" 0 #vu8())))
+
+(define (string-table-length table)
+ "Return the number of bytes needed for the string table @var{table}."
+ (let ((last (car table)))
+ ;; The + 1 is for the trailing NUL byte.
+ (+ (cadr last) (bytevector-length (caddr last)) 1)))
+
+(define (string-table-intern table str)
+ "Add @var{str} to the string table @var{table}. Yields two values: a
+possibly newly allocated string table, and the byte index of the string
+in that table."
+ (cond
+ ((assoc str table)
+ => (lambda (ent)
+ (values table (cadr ent))))
+ (else
+ (let* ((next (string-table-length table)))
+ (values (cons (list str next (string->utf8 str))
+ table)
+ next)))))
+
+(define (link-string-table table)
+ "Link the functional string table @var{table} into a sequence of
+bytes, suitable for use as the contents of an ELF string table section."
+ (let ((out (make-bytevector (string-table-length table) 0)))
+ (for-each
+ (lambda (ent)
+ (let ((bytes (caddr ent)))
+ (bytevector-copy! bytes 0 out (cadr ent) (bytevector-length bytes))))
+ table)
+ out))
+
+(define (segment-kind section)
+ "Return the type of segment needed to store @var{section}, as a pair.
+The car is the @code{PT_} segment type, or @code{#f} if the section
+doesn't need to be present in a loadable segment. The cdr is a bitfield
+of associated @code{PF_} permissions."
+ (let ((flags (elf-section-flags section)))
+ (cons (cond
+ ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+ ;; Sections without SHF_ALLOC don't go in segments.
+ ((zero? flags) #f)
+ (else PT_LOAD))
+ (logior (if (zero? (logand SHF_ALLOC flags))
+ 0
+ PF_R)
+ (if (zero? (logand SHF_EXECINSTR flags))
+ 0
+ PF_X)
+ (if (zero? (logand SHF_WRITE flags))
+ 0
+ PF_W)))))
+
+(define (count-segments objects)
+ "Return the total number of segments needed to represent the linker
+objects in @var{objects}, including the segment needed for the ELF
+header and segment table."
+ (length
+ (fold-values (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (and (car kind) (not (member kind kinds)))
+ (cons kind kinds)
+ kinds)))
+ objects
+ ;; We know there will be at least one segment,
+ ;; containing at least the header and segment table.
+ (list (cons PT_LOAD PF_R)))))
+
+(define (group-by-cars ls)
+ (let lp ((ls ls) (k #f) (group #f) (out '()))
+ (match ls
+ (()
+ (reverse!
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))
+ (((k* . v) . ls)
+ (if (and group (equal? k k*))
+ (lp ls k (cons v group) out)
+ (lp ls k* (list v)
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))))))
+
+(define (collate-objects-into-segments objects)
+ "Given the list of linker objects @var{objects}, group them into
+contiguous ELF segments of the same type and flags. The result is an
+alist that maps segment types to lists of linker objects. See
address@hidden for a description of segment types. Within a
+segment, the order of the linker objects is preserved."
+ (group-by-cars
+ (stable-sort!
+ (map (lambda (o)
+ (cons (segment-kind (linker-object-section o)) o))
+ objects)
+ (lambda (x y)
+ (let* ((x-kind (car x)) (y-kind (car y))
+ (x-type (car x-kind)) (y-type (car y-kind))
+ (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
+ (x-section (linker-object-section (cdr x)))
+ (y-section (linker-object-section (cdr y))))
+ (cond
+ ((not (equal? x-kind y-kind))
+ (cond
+ ((and x-type y-type)
+ (cond
+ ((not (equal? x-flags y-flags))
+ (< x-flags y-flags))
+ (else
+ (< x-type y-type))))
+ (else
+ (not y-type))))
+ ((not (equal? (elf-section-type x-section)
+ (elf-section-type y-section)))
+ (cond
+ ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
+ ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
+ (else (< (elf-section-type x-section)
+ (elf-section-type y-section)))))
+ (else
+ ;; Leave them in the initial order. This allows us to ensure
+ ;; that the ELF header is written first.
+ #f)))))))
+
+(define (align address alignment)
+ (if (zero? alignment)
+ address
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment))))
+
+(define (relocate-section-header sec addr)
+ "Return a new section header, just like @var{sec} but with its
address@hidden and @code{offset} set to @var{addr}."
+ (make-elf-section #:index (elf-section-index sec)
+ #:name (elf-section-name sec)
+ #:type (elf-section-type sec)
+ #:flags (elf-section-flags sec)
+ #:addr addr
+ #:offset addr
+ #:size (elf-section-size sec)
+ #:link (elf-section-link sec)
+ #:info (elf-section-info sec)
+ #:addralign (elf-section-addralign sec)
+ #:entsize (elf-section-entsize sec)))
+
+(define *page-size* 4096)
+
+(define (add-symbols symbols offset symtab)
+ "Add @var{symbols} to the symbol table @var{symtab}, relocating them
+from object address space to memory address space. Returns a new symbol
+table."
+ (fold-values
+ (lambda (symbol symtab)
+ (let ((name (linker-symbol-name symbol))
+ (addr (linker-symbol-address symbol)))
+ (when (vhash-assq name symtab)
+ (error "duplicate symbol" name))
+ (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
+ symbols
+ symtab))
+
+(define (allocate-segment write-segment-header!
+ phidx type flags objects addr symtab alignment)
+ "Given a list of linker objects that should go in a segment, the type
+and flags that the segment should have, and the address at which the
+segment should start, compute the positions that each object should have
+in the segment.
+
+Returns three values: the address of the next byte after the segment, a
+list of relocated objects, and the symbol table. The symbol table is
+the same as @var{symtab}, augmented with the symbols defined in
address@hidden, relocated to their positions in the image.
+
+In what is something of a quirky interface, this routine also patches up
+the segment table using @code{write-segment-header!}."
+ (let* ((alignment (fold-values (lambda (o alignment)
+ (lcm (elf-section-addralign
+ (linker-object-section o))
+ alignment))
+ objects
+ alignment))
+ (addr (align addr alignment)))
+ (receive (objects endaddr symtab)
+ (fold-values
+ (lambda (o out addr symtab)
+ (let* ((section (linker-object-section o))
+ (addr (align addr (elf-section-addralign section))))
+ (values
+ (cons (make-linker-object
+ (relocate-section-header section addr)
+ (linker-object-bv o)
+ (linker-object-relocs o)
+ (linker-object-symbols o))
+ out)
+ (+ addr (elf-section-size section))
+ (add-symbols (linker-object-symbols o) addr symtab))))
+ objects
+ '() addr symtab)
+ (when type
+ (write-segment-header!
+ (make-elf-segment #:index phidx #:type type
+ #:offset addr #:vaddr addr
+ #:filesz (- endaddr addr) #:memsz (- endaddr addr)
+ #:flags flags #:align alignment)))
+ (values endaddr
+ (reverse objects)
+ symtab))))
+
+(define (process-reloc reloc bv section-offset symtab endianness)
+ "Process a relocation. Given that a section containing @var{reloc}
+was just written into the image @var{bv} at offset @var{section-offset},
+fix it up so that its reference points to the correct position of its
+symbol, as present in @var{symtab}."
+ (match (vhash-assq (linker-reloc-symbol reloc) symtab)
+ (#f
+ (error "Undefined symbol" (linker-reloc-symbol reloc)))
+ ((name . symbol)
+ ;; The reloc was written at LOC bytes after SECTION-OFFSET.
+ (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
+ (target (linker-symbol-address symbol)))
+ (case (linker-reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- target offset)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol offset))
+ (bytevector-s32-set! bv offset
+ (+ (/ diff 4) (linker-reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv offset target endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv offset target endianness))
+ (else
+ (error "bad reloc type" reloc)))))))
+
+(define (write-linker-object bv o symtab endianness)
+ "Write the bytevector for the section wrapped by the linker object
address@hidden into the image @var{bv}. The section header in @var{o} should
+already be relocated its final position in the image. Any relocations
+in the section will be processed to point to the correct symbol
+locations, as given in @var{symtab}."
+ (let* ((section (linker-object-section o))
+ (offset (elf-section-offset section))
+ (len (elf-section-size section))
+ (bytes (linker-object-bv o))
+ (relocs (linker-object-relocs o)))
+ (unless (= offset (elf-section-addr section))
+ (error "offset != addr" section))
+ (if (not (= (elf-section-type section) SHT_NOBITS))
+ (begin
+ (if (not (= len (bytevector-length bytes)))
+ (error "unexpected length" section bytes))
+ (bytevector-copy! bytes 0 bv offset len)
+ (for-each (lambda (reloc)
+ (process-reloc reloc bv offset symtab endianness))
+ relocs)))))
+
+(define (find-shstrndx objects)
+ "Find the section name string table in @var{objects}, and return its
+section index."
+ (or-map (lambda (object)
+ (let* ((section (linker-object-section object))
+ (bv (linker-object-bv object))
+ (name (elf-section-name section)))
+ (and (= (elf-section-type section) SHT_STRTAB)
+ (equal? (false-if-exception (string-table-ref bv name))
+ ".shstrtab")
+ (elf-section-index section))))
+ objects))
+
+(define (add-elf-objects objects endianness word-size)
+ "Given the list of linker objects supplied by the user, add linker
+objects corresponding to parts of the ELF file: the null object, the ELF
+header, and the section table.
+
+Both of these internal objects include relocs, allowing their
+inter-object references to be patched up when the final image allocation
+is known. There is special support for patching up the segment table,
+however. Because the segment table needs to know the segment sizes,
+which is the difference between two symbols in image space, and there is
+no reloc kind that is the difference between two symbols, we make a hack
+and return a closure that patches up segment table entries. It seems to
+work.
+
+Returns two values: the procedure to patch the segment table, and the
+list of objects, augmented with objects for the special ELF sections."
+ (define phoff (elf-header-len word-size))
+ (define phentsize (elf-program-header-len word-size))
+ (define shentsize (elf-section-header-len word-size))
+ (define shnum (+ (length objects) 3))
+ (define reloc-kind
+ (case word-size
+ ((4) 'abs32/1)
+ ((8) 'abs64/1)
+ (else (error "bad word size" word-size))))
+
+ ;; ELF requires that the first entry in the section table be of type
+ ;; SHT_NULL.
+ ;;
+ (define (make-null-section)
+ (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
+ #:flags 0 #:addralign 0)
+ #vu8() '() '()))
+
+ ;; The ELF header and the segment table.
+ ;;
+ (define (make-header phnum index shoff-label)
+ (let* ((header (make-elf #:byte-order endianness #:word-size word-size
+ #:phoff phoff #:phnum phnum #:phentsize phentsize
+ #:shoff 0 #:shnum shnum #:shentsize shentsize
+ #:shstrndx (or (find-shstrndx objects)
SHN_UNDEF)))
+ (shoff-reloc (make-linker-reloc reloc-kind
+ (elf-header-shoff-offset word-size)
+ 0
+ shoff-label))
+ (size (+ phoff (* phnum phentsize)))
+ (bv (make-bytevector size 0)))
+ (write-elf-header bv header)
+ ;; Leave the segment table uninitialized; it will be filled in
+ ;; later by calls to the write-segment-header! closure.
+ (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
+ #:flags SHF_ALLOC #:size size)
+ bv
+ (list shoff-reloc)
+ '())))
+
+ ;; The section table.
+ ;;
+ (define (make-footer objects shoff-label)
+ (let* ((size (* shentsize shnum))
+ (bv (make-bytevector size 0))
+ (section-table (make-elf-section #:index (length objects)
+ #:type SHT_PROGBITS
+ #:flags 0
+ #:size size)))
+ (define (write-and-reloc section-label section relocs)
+ (let ((offset (* shentsize (elf-section-index section))))
+ (write-elf-section-header bv offset endianness word-size section)
+ (if (= (elf-section-type section) SHT_NULL)
+ relocs
+ (cons* (make-linker-reloc
+ reloc-kind
+ (+ offset (elf-section-header-addr-offset word-size))
+ 0
+ section-label)
+ (make-linker-reloc
+ reloc-kind
+ (+ offset (elf-section-header-offset-offset word-size))
+ 0
+ section-label)
+ relocs))))
+ (let ((relocs (fold-values
+ (lambda (object relocs)
+ (write-and-reloc
+ (linker-symbol-name
+ (linker-object-section-symbol object))
+ (linker-object-section object)
+ relocs))
+ objects
+ (write-and-reloc shoff-label section-table '()))))
+ (%make-linker-object section-table bv relocs
+ (list (make-linker-symbol shoff-label 0))))))
+
+ (let* ((null-section (make-null-section))
+ (objects (cons null-section objects))
+
+ (shoff (gensym "*section-table*"))
+ (header (make-header (count-segments objects) (length objects) shoff))
+ (objects (cons header objects))
+
+ (footer (make-footer objects shoff))
+ (objects (cons footer objects)))
+
+ ;; The header includes the segment table, which needs offsets and
+ ;; sizes of the segments. Normally we would use relocs to rewrite
+ ;; these values, but there is no reloc type that would allow us to
+ ;; compute size. Such a reloc would need to take the difference
+ ;; between two symbols, and it's probably a bad idea architecturally
+ ;; to create one.
+ ;;
+ ;; So instead we return a closure to patch up the segment table.
+ ;; Normally we'd shy away from such destructive interfaces, but it's
+ ;; OK as we create the header section ourselves.
+ ;;
+ (define (write-segment-header! segment)
+ (let ((bv (linker-object-bv header))
+ (offset (+ phoff (* (elf-segment-index segment) phentsize))))
+ (write-elf-program-header bv offset endianness word-size segment)))
+
+ (values write-segment-header! objects)))
+
+(define (allocate-elf objects page-aligned? endianness word-size)
+ "Lay out @var{objects} into an ELF image, computing the size of the
+file, the positions of the objects, and the global symbol table.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This makes the resulting image larger. It
+is more suitable to situations where you would write a file out to disk
+and read it in with mmap. Otherwise if @var{page-aligned?} is false,
+sections default to 8-byte alignment.
+
+Returns three values: the total image size, a list of objects with
+relocated headers, and the global symbol table."
+ (receive (write-segment-header! objects)
+ (add-elf-objects objects endianness word-size)
+ (let lp ((seglists (collate-objects-into-segments objects))
+ (objects '())
+ (phidx 0)
+ (addr 0)
+ (symtab vlist-null)
+ (prev-flags 0))
+ (match seglists
+ ((((type . flags) objs-in ...) seglists ...)
+ (receive (addr objs-out symtab)
+ (allocate-segment
+ write-segment-header!
+ phidx type flags objs-in addr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags))
+ ;; Allow sections that are not in
+ ;; loadable segments to share pages
+ ;; with PF_R segments.
+ (not (and (not type) (= PF_R prev-flags))))
+ *page-size*
+ 8))
+ (lp seglists
+ (fold-values cons objs-out objects)
+ (if type (1+ phidx) phidx)
+ addr
+ symtab
+ flags)))
+ (()
+ (values addr
+ (reverse objects)
+ symtab))))))
+
+(define (check-section-numbers objects)
+ "Verify that taken as a whole, that all objects have distinct,
+contiguous section numbers, starting from 1. (Section 0 is the null
+section.)"
+ (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
+ (sections (make-vector nsections #f)))
+ (for-each (lambda (object)
+ (let ((n (elf-section-index (linker-object-section object))))
+ (cond
+ ((< n 1)
+ (error "Invalid section number" object))
+ ((>= n nsections)
+ (error "Invalid section number" object))
+ ((vector-ref sections n)
+ (error "Duplicate section" (vector-ref sections n) object))
+ (else
+ (vector-set! sections n object)))))
+ objects)))
+
+;; Given a list of linker objects, collate the objects into segments,
+;; allocate the segments, allocate the ELF bytevector, and write the
+;; segments into the bytevector, relocating as we go.
+;;
+(define* (link-elf objects #:key
+ (page-aligned? #t)
+ (endianness (target-endianness))
+ (word-size (target-word-size)))
+ "Create an ELF image from the linker objects, @var{objects}.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This is suitable for situations where you
+would write a file out to disk and read it in with @code{mmap}.
+Otherwise if @var{page-aligned?} is false, sections default to 8-byte
+alignment.
+
+Returns a bytevector."
+ (check-section-numbers objects)
+ (receive (size objects symtab)
+ (allocate-elf objects page-aligned? endianness word-size)
+ (let ((bv (make-bytevector size 0)))
+ (for-each
+ (lambda (object)
+ (write-linker-object bv object symtab endianness))
+ objects)
+ bv)))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index f939a55..e2a93d7 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -1,6 +1,6 @@
;;; Guile VM object code
-;; Copyright (C) 2001, 2010, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 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
@@ -22,7 +22,8 @@
#:export (objcode? objcode-meta
bytecode->objcode objcode->bytecode
load-thunk-from-file load-thunk-from-memory
- word-size byte-order))
+ word-size byte-order
+ find-mapped-elf-image))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_objcodes")
diff --git a/test-suite/tests/linker.test b/test-suite/tests/linker.test
new file mode 100644
index 0000000..9e63991
--- /dev/null
+++ b/test-suite/tests/linker.test
@@ -0,0 +1,88 @@
+;;;; linker.test -*- scheme -*-
+;;;;
+;;;; Copyright 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
+
+(define-module (test-suite test-linker)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system base target)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker))
+
+(define (link-elf-with-one-main-section name bytes)
+ (let ((string-table (make-string-table)))
+ (define (intern-string! string)
+ (call-with-values
+ (lambda () (string-table-intern string-table string))
+ (lambda (table idx)
+ (set! string-table table)
+ idx)))
+ (define (make-object index name bv relocs . kwargs)
+ (let ((name-idx (intern-string! (symbol->string name))))
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-linker-symbol name 0)))))
+ (define (make-string-table)
+ (intern-string! ".shstrtab")
+ (make-object 2 '.shstrtab (link-string-table string-table) '()
+ #:type SHT_STRTAB #:flags 0))
+ (let* ((word-size (target-word-size))
+ (endianness (target-endianness))
+ (sec (make-object 1 name bytes '()))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ (shstrtab (make-string-table)))
+ (link-elf (list sec shstrtab)
+ #:endianness endianness #:word-size word-size))))
+
+(with-test-prefix "simple"
+ (define foo-bytes #vu8(0 1 2 3 4 5))
+ (define bytes #f)
+ (define elf #f)
+
+ (define (bytevectors-equal? bv-a bv-b start-a start-b size)
+ (or (zero? size)
+ (and (equal? (bytevector-u8-ref bv-a start-a)
+ (bytevector-u8-ref bv-b start-b))
+ (bytevectors-equal? bv-a bv-b (1+ start-a) (1+ start-b)
+ (1- size)))))
+
+ (pass-if "linking succeeds"
+ (begin
+ (set! bytes (link-elf-with-one-main-section '.foo foo-bytes))
+ #t))
+
+ (pass-if "parsing succeeds"
+ (begin
+ (set! elf (parse-elf bytes))
+ (elf? elf)))
+
+ ;; 5 sections: the initial NULL section, .foo, .shstrtab, the initial
+ ;; header with segment table, and the section table.
+ (pass-if-equal 5 (elf-shnum elf))
+
+ (pass-if ".foo section checks out"
+ (let ((sec (assoc-ref (elf-sections-by-name elf) ".foo")))
+ (and sec
+ (= (elf-section-size sec) (bytevector-length foo-bytes))
+ (bytevectors-equal? bytes foo-bytes
+ (elf-section-offset sec) 0
+ (bytevector-length foo-bytes))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-7-gfb9600d,
Andy Wingo <=