[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-307-gd8647aa

[Andy Wingo]

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=d8647aaddd13f96499eb1cf0a647fc1430f12c29

The branch, wip-rtl has been updated
       via  d8647aaddd13f96499eb1cf0a647fc1430f12c29 (commit)
       via  f94ed4d9641dd59ba7dd316c191c233a7698bbc7 (commit)
      from  690cc3f3bc15e8ccb4c76117e4713df934fc7d1d (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 d8647aaddd13f96499eb1cf0a647fc1430f12c29
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 3 23:19:35 2012 +0200

    implement an ELF loader that works on memory
    
    * libguile/objcodes.c (load_thunk_from_fd_using_mmap): Rename from
      load_thunk_from_fd.  Lift processing of the dynamic segment into a
      separate function.
      (load_thunk_from_memory): New function.
      (load_thunk_from_fd_using_read): New function, used where mmap is
      unavailable.  Reads the whole file and then calls
      load_thunk_from_memory.
      (scm_load_thunk_from_memory): Implemented an ELF loader from
      bytecode.
    
    * module/system/vm/objcode.scm (load-thunk-from-memory): Export.

commit f94ed4d9641dd59ba7dd316c191c233a7698bbc7
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 3 23:14:55 2012 +0200

    allow linker to avoid permissions and page alignment
    
    * module/system/vm/elf.scm (alloc-segment): Change to take the alignment
      arg directly.  Write the alignment into the phdr.
      (link-elf): Add page-aligned? kwarg, defaulting to #t.  Linking ELF
      for loading from memory can set it to #f, indicating that no padding
      will be allocated, and no mprotect calls will happen at runtime.

-----------------------------------------------------------------------

Summary of changes:
 libguile/objcodes.c          |  357 ++++++++++++++++++++++++++++++++++--------
 module/system/vm/elf.scm     |   12 +-
 module/system/vm/objcode.scm |    2 +-
 3 files changed, 300 insertions(+), 71 deletions(-)

diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 754362d..293647c 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -118,20 +118,28 @@ check_elf_header (const Elf_Ehdr *header)
   return NULL;
 }
 
-static char*
-map_segments (int fd, char **base,
-              const Elf_Phdr *from, const Elf_Phdr *to)
+static int
+segment_flags_to_prot (Elf_Word flags)
 {
   int prot = 0;
-  char *ret;
           
-  if (from->p_flags & PF_X)
+  if (flags & PF_X)
     prot |= PROT_EXEC;
-  if (from->p_flags & PF_W)
+  if (flags & PF_W)
     prot |= PROT_WRITE;
-  if (from->p_flags & PF_R)
+  if (flags & PF_R)
     prot |= PROT_READ;
 
+  return prot;
+}
+
+static char*
+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);
@@ -142,10 +150,76 @@ map_segments (int fd, char **base,
   return ret;
 }
 
+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_t_uint32 **init_out, scm_t_uint32 **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;
+
+  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;
+          if ((scm_t_uintptr) init % 4)
+            return "unaligned DT_INIT";
+          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;
+          if ((scm_t_uintptr) entry % 4)
+              return "unaligned DT_GUILE_ENTRY";
+          break;
+        case DT_GUILE_RTL_VERSION:
+          if (dyn[i].d_un.d_val != 0x02020000)
+            return "bad rtl version";
+          break;
+        }
+    }
+
+  if (gc_root)
+    GC_add_roots (gc_root, gc_root + gc_root_size);
+  if (!entry)
+    return "missing DT_GUILE_ENTRY";
+  *init_out = (scm_t_uint32 *) init;
+  *entry_out = (scm_t_uint32 *) 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 (int fd)
+load_thunk_from_fd_using_mmap (int fd)
 #define FUNC_NAME "load-thunk-from-disk"
 {
   Elf_Ehdr header;
@@ -157,6 +231,7 @@ load_thunk_from_fd (int fd)
   int start_segment = -1;
   int prev_segment = -1;
   int dynamic_segment = -1;
+  scm_t_uint32 *init = 0, *entry = 0;
 
   if (full_read (fd, &header, sizeof header) != sizeof header)
     ABORT ("object file too small");
@@ -168,9 +243,7 @@ load_thunk_from_fd (int fd)
     goto cleanup;
   
   n = header.e_phnum;
-  ph = malloc (n * sizeof (Elf_Phdr));
-  if (!ph)
-    goto cleanup;
+  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");
@@ -231,62 +304,15 @@ load_thunk_from_fd (int fd)
   if (dynamic_segment < 0)
     ABORT ("no PT_DYNAMIC segment");
 
-  {
-    char *dyn_addr = base + ph[dynamic_segment].p_vaddr;
-    Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr;
-    size_t dyn_size = ph[dynamic_segment].p_memsz / sizeof (Elf_Dyn);
-
-    char *init = 0, *gc_root = 0, *entry = 0;
-    scm_t_ptrdiff gc_root_size = 0;
-
-    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)
-              ABORT ("duplicate DT_INIT");
-            init = base + dyn[i].d_un.d_val;
-            if ((scm_t_uintptr) init % 4)
-              ABORT ("unaligned DT_INIT");
-            break;
-          case DT_GUILE_GC_ROOT:
-            if (gc_root)
-              ABORT ("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)
-              ABORT ("duplicate DT_GUILE_GC_ROOT_SZ");
-            gc_root_size = dyn[i].d_un.d_val;
-            break;
-          case DT_GUILE_ENTRY:
-            if (entry)
-              ABORT ("duplicate DT_GUILE_ENTRY");
-            entry = base + dyn[i].d_un.d_val;
-            if ((scm_t_uintptr) entry % 4)
-              ABORT ("unaligned DT_GUILE_ENTRY");
-            break;
-          case DT_GUILE_RTL_VERSION:
-            if (dyn[i].d_un.d_val != 0x02020000)
-              ABORT ("bad rtl version");
-            break;
-          }
-      }
+  if ((err_msg = process_dynamic_segment (base, &ph[dynamic_segment],
+                                          &init, &entry)))
+    goto cleanup;
 
-    if (init)
-      scm_call_0 (scm_i_make_rtl_program ((scm_t_uint32 *)init));
-    if (gc_root)
-      GC_add_roots (gc_root, gc_root + gc_root_size);
-    if (!entry)
-      ABORT ("missing DT_GUILE_ENTRY");
+  if (init)
+    scm_call_0 (scm_i_make_rtl_program (init));
 
-    /* Finally!  Return the thunk.  */
-    return scm_i_make_rtl_program ((scm_t_uint32 *)entry);
-  }
+  /* Finally!  Return the thunk.  */
+  return scm_i_make_rtl_program (entry);
 
   /* FIXME: munmap on error? */
  cleanup:
@@ -301,6 +327,190 @@ load_thunk_from_fd (int fd)
   }
 }
 #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_t_uint32 *init = 0, *entry = 0;
+
+  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 (init)
+    scm_call_0 (scm_i_make_rtl_program (init));
+
+  /* Finally!  Return the thunk.  */
+  return scm_i_make_rtl_program (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_disk, "load-thunk-from-disk", 1, 0, 0,
            (SCM filename),
@@ -317,10 +527,25 @@ SCM_DEFINE (scm_load_thunk_from_disk, 
"load-thunk-from-disk", 1, 0, 0,
   free (c_filename);
   if (fd < 0) SCM_SYSERROR;
 
-  return load_thunk_from_fd (fd);
+#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
 
 
 
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index dc99acf..9bdc5ef 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -917,13 +917,13 @@
          symbols
          symtab))
 
-(define (alloc-segment type flags objects fileaddr memaddr symtab prev-flags)
+(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
-                           (if (= flags prev-flags) 8 *page-size*)))
+                           alignment))
          (fileaddr (align fileaddr alignment))
          (memaddr (align memaddr alignment)))
     (receive (objects fileend memend symtab)
@@ -953,7 +953,7 @@
                           #:vaddr (if loadable? memaddr 0)
                           #:filesz (- fileend fileaddr)
                           #:memsz (if loadable? (- memend memaddr) 0)
-                          #:flags flags #:align 8)
+                          #:flags flags #:align alignment)
        (reverse objects)
        symtab))))
 
@@ -1024,6 +1024,7 @@
 ;; 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))
@@ -1042,7 +1043,10 @@
                 (objects (cdr x)))
             (receive (segment objects symtab)
                 (alloc-segment type flags objects fileaddr memaddr symtab
-                               prev-flags)
+                               (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))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
index 82a514f..d6562fc 100644
--- a/module/system/vm/objcode.scm
+++ b/module/system/vm/objcode.scm
@@ -22,7 +22,7 @@
   #:export (objcode? objcode-meta
             bytecode->objcode objcode->bytecode
             load-objcode write-objcode
-            load-thunk-from-disk
+            load-thunk-from-disk load-thunk-from-memory
             word-size byte-order))
 
 (load-extension (string-append "libguile-" (effective-version))


hooks/post-receive
-- 
GNU Guile