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/system/vm/rtl.scm (<asm>, next-section-number!, make-object):
* module/language/objcode/elf.scm (bytecode->elf): Arrange to set the
  section indexes when creating ELF sections.

* module/system/vm/linker.scm (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.

4 files changed, 229 insertions, 197 deletions

diff --git a/module/language/objcode/elf.scm b/module/language/objcode/elf.scm
index 1edfdcf98..981c398af 100644
--- a/module/language/objcode/elf.scm
+++ b/module/language/objcode/elf.scm
@@ -41,15 +41,16 @@
         (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-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 word-size endianness)
+    (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)
@@ -74,19 +75,19 @@
                             ((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 (make-string-table)
+    (define (make-string-table index)
       (intern-string! ".shstrtab")
-      (make-object '.shstrtab (link-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 (make-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 e2b245452..1d3d15e42 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -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,7 +40,8 @@
   #: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
@@ -37,6 +51,7 @@
 
             (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
@@ -51,6 +66,7 @@
 
             (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
@@ -242,6 +258,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 +312,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 +350,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 +388,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 +420,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 type index 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 +432,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 +449,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 +486,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 +540,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 +555,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 +574,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 +621,10 @@
     ((8) 64)
     (else (error "bad word size" word-size))))
 
-(define (parse-elf64-section-header bv offset byte-order)
+(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 +655,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)))
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index e9dca7171..fcb5b9e14 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -68,15 +68,13 @@
   #: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-string-table
-            string-table-intern
-            link-string-table
-
-            make-linker-reloc
+  #:export (make-linker-reloc
             make-linker-symbol
 
             make-linker-object
@@ -86,6 +84,10 @@
             linker-object-relocs
             linker-object-symbols
 
+            make-string-table
+            string-table-intern
+            link-string-table
+
             link-elf))
 
 ;; A relocation records a reference to a symbol.  When the symbol is
@@ -222,13 +224,6 @@
         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)
@@ -236,15 +231,9 @@
         (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 #:name (elf-section-name sec)
+  (make-elf-section #:index (elf-section-index sec)
+                    #:name (elf-section-name sec)
                     #:type (elf-section-type sec)
                     #:flags (elf-section-flags sec)
                     #:addr memaddr
@@ -269,7 +258,8 @@
          symbols
          symtab))
 
-(define (alloc-segment type flags objects fileaddr memaddr symtab alignment)
+(define (alloc-segment phidx type flags objects
+                       fileaddr memaddr symtab alignment)
   (let* ((loadable? (not (zero? flags)))
          (alignment (fold1 (lambda (o alignment)
                              (lcm (elf-section-addralign
@@ -303,7 +293,8 @@
                     (add-symbols (linker-object-symbols o) memaddr symtab))))
                objects '() fileaddr memaddr symtab)
       (values
-       (make-elf-segment #:type type #:offset fileaddr
+       (make-elf-segment #:index phidx
+                         #:type type #:offset fileaddr
                          #:vaddr (if loadable? memaddr 0)
                          #:filesz (- fileend fileaddr)
                          #:memsz (if loadable? (- memend memaddr) 0)
@@ -342,34 +333,97 @@
          (relocs (linker-object-relocs o)))
     (if (not (= (elf-section-type section) SHT_NOBITS))
         (begin
-          (if (not (= (elf-section-size section) (bytevector-length bytes)))
+          (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 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 (linker-object-section (car in)))
-               (bv (linker-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)))))))
+(define (find-shstrndx objects)
+  (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))
+
+;; objects ::= list of <linker-object>
+;; => 3 values: ELF header, program headers, objects
+(define (allocate-elf objects page-aligned? endianness word-size)
+  (let* ((seglists (collate-objects-into-segments objects))
+         (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))
+    (let lp ((seglists seglists)
+             (segments '())
+             (objects '())
+             (phidx 0)
+             (fileaddr fileaddr)
+             (memaddr memaddr)
+             (symtab vlist-null)
+             (prev-flags 0))
+      (match seglists
+        ((((type . flags) objs-in ...) seglists ...)
+         (receive (segment objs-out symtab)
+             (alloc-segment phidx type flags objs-in fileaddr memaddr symtab
+                            (if (and page-aligned?
+                                     (not (= flags prev-flags)))
+                                *page-size*
+                                8))
+           (lp seglists
+               (cons segment segments)
+               (fold1 cons objs-out objects)
+               (1+ phidx)
+               (+ (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)))
+        (()
+         (let ((section-table-offset (+ (align fileaddr word-size))))
+           (values
+            (make-elf #:byte-order endianness #:word-size word-size
+                      #:phoff program-headers-offset #:phnum nsegments
+                      #:shoff section-table-offset #:shnum nsections
+                      #:shstrndx (or (find-shstrndx objects) SHN_UNDEF))
+            (reverse segments)
+            (let ((null-section (make-elf-section #:index 0 #:type SHT_NULL
+                                                  #:flags 0 #:addralign 0)))
+              (cons (make-linker-object null-section #vu8() '() '())
+                    (reverse objects)))
+            symtab)))))))
+
+(define (write-elf header segments objects symtab)
+  (define (phoff n)
+    (+ (elf-phoff header) (* n (elf-phentsize header))))
+  (define (shoff n)
+    (+ (elf-shoff header) (* n (elf-shentsize header))))
+  (let ((endianness (elf-byte-order header))
+        (word-size (elf-word-size header))
+        (bv (make-bytevector (shoff (elf-shnum header)) 0)))
+    (write-elf-header bv header)
+    (for-each
+     (lambda (segment)
+       (write-elf-program-header bv (phoff (elf-segment-index segment))
+                                 endianness word-size segment))
+     segments)
+    (for-each
+     (lambda (object)
+       (let ((section (linker-object-section object)))
+         (write-elf-section-header bv (shoff (elf-section-index section))
+                                   endianness word-size section))
+       (write-linker-object bv object symtab endianness))
+     objects)
+    bv))
 
 ;; Given a list of section-header/bytevector pairs, collate the sections
 ;; into segments, allocate the segments, allocate the ELF bytevector,
@@ -379,64 +433,6 @@
                    (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-linker-object bv o symtab endianness)
-                           (write-elf-section-header
-                            bv (+ section-table-offset
-                                  (* (elf-section-header-len word-size) shidx))
-                            endianness word-size (linker-object-section o))
-                           (1+ shidx))
-                         (cdr x) shidx)))
-               out 0 1)
-        bv))))
+  (receive (header segments objects symtab)
+      (allocate-elf objects page-aligned? endianness word-size)
+    (write-elf header segments objects symtab)))
diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
index def19bfd1..684820731 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/rtl.scm
@@ -104,7 +104,8 @@
             word-size endianness
             constants inits
             string-table
-            meta)
+            meta
+            next-section-number)
   asm?
   (cur asm-cur set-asm-cur!)
   (idx asm-idx set-asm-idx!)
@@ -119,7 +120,8 @@
   (constants asm-constants set-asm-constants!)
   (inits asm-inits set-asm-inits!)
   (string-table asm-string-table set-asm-string-table!)
-  (meta asm-meta set-asm-meta!))
+  (meta asm-meta set-asm-meta!)
+  (next-section-number asm-next-section-number set-asm-next-section-number!))
 
 (define-inlinable (fresh-block)
   (make-u32vector *block-size*))
@@ -131,7 +133,8 @@
             word-size endianness
             vlist-null '()
             (make-string-table)
-            '()))
+            '()
+            1))
 
 (define (intern-string! asm string)
   (call-with-values
@@ -704,9 +707,15 @@
          (endianness little))
         (lp (+ pos 4))))))
 
+(define (next-section-number! asm)
+  (let ((n (asm-next-section-number asm)))
+    (set-asm-next-section-number! asm (1+ n))
+    n))
+
 (define (make-object asm name bv relocs labels . kwargs)
   (let ((name-idx (intern-string! asm (symbol->string name))))
     (make-linker-object (apply make-elf-section
+                               #:index (next-section-number! asm)
                                #:name name-idx
                                #:size (bytevector-length bv)
                                kwargs)