PT_DYNAMIC inside some other PT_LOAD segment

* libguile/loader.c (load_thunk_from_memory): Only load PT_LOAD
  segments, as libc does.  The PT_DYNAMIC segment should be inside some
  other PT_LOAD segment.

* module/system/vm/linker.scm (segment-kind): Give the .dynamic segment
  PT_LOAD kind, so that it is written in a PT_LOAD segment.
  (count-segments): Add one if there is a SHT_DYNAMIC segment.
  (allocate-segment): Set the paddr to the addr, as binutils do.
  (record-special-segments): New routine, to write out special segments
  like PT_DYNAMIC.
  (allocate-elf): Call record-special-segments.

libguile/loader.c

@@ -392,8 +392,12 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
           if (dynamic_segment >= 0)
             ABORT ("expected only one PT_DYNAMIC segment");
           dynamic_segment = i;
+          continue;
         }
 
+      if (ph[i].p_type != PT_LOAD)
+        ABORT ("unknown segment type");
+
       if (i == 0)
         {
           if (ph[i].p_vaddr != 0)
@@ -421,6 +425,8 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
 #ifdef HAVE_SYS_MMAN_H
       for (i = 0; i < n; i++)
         {
+          if (ph[i].p_type != PT_LOAD)
+            continue;
           if (ph[i].p_flags == PF_R)
             continue;
           if (ph[i].p_align != 4096)

module/system/vm/linker.scm

@@ -209,31 +209,29 @@ 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
+    ;; Sections without SHF_ALLOC don't go in segments.
-           ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+    (cons (if (zero? flags) #f PT_LOAD)
-           ;; Sections without SHF_ALLOC don't go in segments.
+          (logior (if (logtest SHF_ALLOC flags) PF_R 0)
-           ((zero? flags) #f)
+                  (if (logtest SHF_EXECINSTR flags) PF_X 0)
-           (else PT_LOAD))
+                  (if (logtest SHF_WRITE flags) PF_W 0)))))
-          (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."
+  (define (adjoin x xs)
+    (if (member x xs) xs (cons x xs)))
   (length
    (fold-values (lambda (object kinds)
                   (let ((kind (segment-kind (linker-object-section object))))
-                    (if (and (car kind) (not (member kind kinds)))
+                    (if (= (elf-section-type (linker-object-section object))
-                        (cons kind kinds)
+                           SHT_DYNAMIC)
-                        kinds)))
+                        ;; The dynamic section is part of a loadable
+                        ;; segment, and also gets the additional
+                        ;; PT_DYNAMIC segment header.
+                        (cons (cons PT_DYNAMIC (cdr kind))
+                              (adjoin kind kinds))
+                        (if (car kind) (adjoin kind kinds) kinds))))
                 objects
                 ;; We know there will be at least one segment,
                 ;; containing at least the header and segment table.
@@ -375,7 +373,7 @@ the segment table using @code{write-segment-header!}."
       (when type
         (write-segment-header!
          (make-elf-segment #:index phidx #:type type
-                           #:offset addr #:vaddr addr
+                           #:offset addr #:vaddr addr #:paddr addr
                            #:filesz (- endaddr addr) #:memsz (- endaddr addr)
                            #:flags flags #:align alignment)))
       (values endaddr
@@ -580,6 +578,27 @@ list of objects, augmented with objects for the special ELF sections."
 
     (values write-segment-header! objects)))
 
+(define (record-special-segments write-segment-header! phidx all-objects)
+  (let lp ((phidx phidx) (objects all-objects))
+    (match objects
+      (() #t)
+      ((object . objects)
+       (let ((section (linker-object-section object)))
+         (cond
+          ((eqv? (elf-section-type section) SHT_DYNAMIC)
+           (let ((addr (elf-section-offset section))
+                 (size (elf-section-size section))
+                 (align (elf-section-addralign section))
+                 (flags (cdr (segment-kind section))))
+             (write-segment-header!
+              (make-elf-segment #:index phidx #:type PT_DYNAMIC
+                                #:offset addr #:vaddr addr #:paddr addr
+                                #:filesz size #:memsz size
+                                #:flags flags #:align align))
+             (lp (1+ phidx) objects)))
+          (else
+           (lp phidx objects))))))))
+
 (define (allocate-elf objects page-aligned? endianness word-size
                       abi type machine-type)
   "Lay out @var{objects} into an ELF image, computing the size of the
@@ -623,6 +642,7 @@ relocated headers, and the global symbol table."
                symtab
                flags)))
         (()
+         (record-special-segments write-segment-header! phidx objects)
          (values addr
                  (reverse objects)
                  symtab))))))