add ELF loader

* libguile/objcodes.h:
* libguile/objcodes.c (scm_load_thunk_from_file)
  (scm_load_thunk_from_memory): New procedures.

* libguile/elf.h: Import from glibc.  Not installed.

* libguile/Makefile.am: Adapt for elf.h.

* module/system/vm/objcode.scm: (load-thunk-from-file)
  (load-thunk-from-memory): New exports.

libguile/Makefile.am

@@ -455,6 +455,7 @@ install-exec-hook:
 ## Perhaps we can deal with them normally once the merge seems to be
 ## working.
 noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c		\
+                 elf.h						\
                  srfi-14.i.c					\
                  quicksort.i.c                                  \
                  win32-uname.h win32-socket.h			\

libguile/objcodes.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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,9 +37,559 @@
 #include <full-read.h>
 
 #include "_scm.h"
+#include "elf.h"
 #include "programs.h"
 #include "objcodes.h"
 
+/* This file contains the loader for Guile's ELF format.  It is followed
+   by the old loader.  We'll remove the old loader at some point.  */
+
+#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
+
+#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 */
+
+#ifdef WORDS_BIGENDIAN
+#define ELFDATA ELFDATA2MSB
+#else
+#define ELFDATA ELFDATA2LSB
+#endif
+
+enum bytecode_kind
+  {
+    BYTECODE_KIND_NONE,
+    BYTECODE_KIND_GUILE_2_0
+  };
+
+static SCM
+pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr)
+{
+  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 ();
+    }
+}
+
+static const char*
+check_elf_header (const Elf_Ehdr *header)
+{
+  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;
+}
+
+static int
+segment_flags_to_prot (Elf_Word 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;
+}
+
+static int
+map_segments (int fd, char **base,
+              const Elf_Phdr *from, const Elf_Phdr *to)
+{
+  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++)
+    {
+      if (dyn[i].d_tag == DT_NULL)
+        break;
+
+      switch (dyn[i].d_tag)
+        {
+        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;
+          }
+        }
+    }
+
+  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)
+
+#ifdef HAVE_SYS_MMAN_H
+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;
+
+      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
+#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 (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;
+
+      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_align < alignment)
+        {
+          if (ph[i].p_align % alignment)
+            ABORT ("expected new alignment to be multiple of old");
+          alignment = ph[i].p_align;
+        }
+
+      if (ph[i].p_type == PT_DYNAMIC)
+        {
+          if (dynamic_segment >= 0)
+            ABORT ("expected only one PT_DYNAMIC segment");
+          dynamic_segment = i;
+        }
+
+      if (first_loadable < 0)
+        {
+          if (ph[i].p_vaddr)
+            ABORT ("first loadable vaddr is not 0");
+
+          first_loadable = i;
+        }
+
+      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 (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 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);
+
+  /* Finally!  Return the thunk.  */
+  return entry;
+
+ 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_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
+
+
+
 /* SCM_OBJCODE_COOKIE, defined in _scm.h, is a magic value prepended
    to objcode on disk but not in memory.
 

libguile/objcodes.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -60,6 +60,9 @@ struct scm_objcode
 #define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x))
 #define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code))
 
+SCM_API SCM scm_load_thunk_from_file (SCM filename);
+SCM_API SCM scm_load_thunk_from_memory (SCM bv);
+
 SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
 SCM_API SCM scm_load_objcode (SCM file);
 SCM_API SCM scm_objcode_p (SCM obj);

module/system/vm/objcode.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM object code
 
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 2012 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,6 +22,7 @@
   #:export (objcode? objcode-meta
             bytecode->objcode objcode->bytecode
             load-objcode write-objcode
+            load-thunk-from-file load-thunk-from-memory
             word-size byte-order))
 
 (load-extension (string-append "libguile-" (effective-version))