linker: Do not store entire ELF in memory when writing to a file.

This reduces the amount of memory that needs to be allocated while
writing the ELF file to disk.

Note: We're abusing #:page-aligned? in 'link-elf' to choose whether to
return a bytevector or a procedure.

* module/system/vm/linker.scm (process-reloc): Subtract SECTION-OFFSET
when writing to BV.
(write-linker-object): Pass BV directly to the linker object writer.
(link-elf): When PAGE-ALIGNED? is false, call 'bytevector-slice' from
here.  When it is true, return a procedure that takes a port and writes
to it, without having to allocate a bytevector for the whole ELF
container.
* module/language/bytecode/spec.scm (bytecode->value): Handle X being a
procedure instead of a bytevector.
(bytecode) <#:printer>: Likewise.
* test-suite/tests/linker.test (link-elf-with-one-main-section): Pass
 #:page-aligned? #f.

3 files changed, 74 insertions, 14 deletions

diff --git a/module/language/bytecode/spec.scm b/module/language/bytecode/spec.scm
index 89256c5c2..6f77dc359 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -1,6 +1,6 @@
 ;;; Bytecode
 
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2023 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
@@ -21,11 +21,19 @@
 (define-module (language bytecode spec)
   #:use-module (system base language)
   #:use-module (system vm loader)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
+  #:use-module (srfi srfi-71)
   #:export (bytecode))
 
 (define (bytecode->value x e opts)
-  (let ((thunk (load-thunk-from-memory x)))
+  (let ((thunk (load-thunk-from-memory
+                (if (bytevector? x)
+                    x
+                    (let ((port get-bv (open-bytevector-output-port)))
+                      (x port)
+                      (close-port port)
+                      (get-bv))))))
     (if (eq? e (current-module))
         ;; save a cons in this case
         (values (thunk) e e)
@@ -37,6 +45,9 @@
 (define-language bytecode
   #:title	"Bytecode"
   #:compilers   `((value . ,bytecode->value))
-  #:printer	(lambda (bytecode port) (put-bytevector port bytecode))
+  #:printer	(lambda (bytecode port)
+                  (if (bytevector? bytecode)
+                      (put-bytevector port bytecode)
+                      (bytecode port)))
   #:reader      get-bytevector-all
   #:for-humans? #f)
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index 6858850ef..e126cfb0d 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -71,6 +71,7 @@
   #:use-module (system base target)
   #:use-module ((srfi srfi-1) #:select (append-map))
   #:use-module (srfi srfi-9)
+  #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
@@ -446,16 +447,16 @@ symbol, as present in @var{symtab}."
           (let ((diff (+ (- target offset) (linker-reloc-addend reloc))))
             (unless (zero? (modulo diff 4))
               (error "Bad offset" reloc symbol offset))
-            (bytevector-s32-set! bv offset (/ diff 4) endianness)))
+            (bytevector-s32-set! bv (- offset section-offset) (/ diff 4) endianness)))
          ((rel32/1)
           (let ((diff (- target offset)))
-            (bytevector-s32-set! bv offset
+            (bytevector-s32-set! bv (- offset section-offset)
                                  (+ diff (linker-reloc-addend reloc))
                                  endianness)))
          ((abs32/1)
-          (bytevector-u32-set! bv offset target endianness))
+          (bytevector-u32-set! bv (- offset section-offset) target endianness))
          ((abs64/1)
-          (bytevector-u64-set! bv offset target endianness))
+          (bytevector-u64-set! bv (- offset section-offset) target endianness))
          (else
           (error "bad reloc type" reloc)))))))
 
@@ -478,7 +479,7 @@ locations, as given in @var{symtab}."
         (begin
           (unless (= len (linker-object-size o))
             (error "unexpected length" section o))
-          ((linker-object-writer o) (bytevector-slice bv offset len))
+          ((linker-object-writer o) bv)
           (for-each (lambda (reloc)
                       (process-reloc reloc bv offset symtab endianness))
                     relocs)))))
@@ -755,9 +756,56 @@ Returns a bytevector."
   (receive (size objects symtab)
       (allocate-elf objects page-aligned? endianness word-size
                     abi type machine-type)
-    (let ((bv (make-bytevector size 0)))       ;TODO: Remove allocation.
-      (for-each
-       (lambda (object)
-         (write-linker-object bv object symtab endianness))
-       objects)
-      bv)))
+    ;; XXX: When PAGE-ALIGNED? is false, assume the caller expects to
+    ;; see a bytevector.  Otherwise return a procedure that will write
+    ;; the ELF stream to the given port.
+    (if (not page-aligned?)
+        (let ((bv (make-bytevector size 0)))
+          (for-each
+           (lambda (object)
+             (let* ((section (linker-object-section object))
+                    (offset (elf-section-offset section))
+                    (len (elf-section-size section)))
+               (write-linker-object (bytevector-slice bv offset len)
+                                    object symtab endianness)))
+           objects)
+          bv)
+        (lambda (port)
+          (define write-padding
+            (let ((blank (make-bytevector 4096 0)))
+              (lambda (port size)
+                ;; Write SIZE bytes of padding to PORT.
+                (let loop ((size size))
+                  (unless (zero? size)
+                    (let ((count (min size
+                                      (bytevector-length blank))))
+                     (put-bytevector port blank 0 count)
+                     (loop (- size count))))))))
+
+          (define (compute-padding objects)
+            ;; Return the list of padding in between OBJECTS--the list
+            ;; of sizes of padding to be inserted before each object.
+            (define object-offset
+              (compose elf-section-offset linker-object-section))
+
+            (let loop ((objects objects)
+                       (offset  0)
+                       (result '()))
+              (match objects
+                (()
+                 (reverse result))
+                ((object . tail)
+                 (loop tail
+                       (+ (linker-object-size object)
+                          (object-offset object))
+                       (cons (- (object-offset object) offset)
+                             result))))))
+
+          (for-each
+           (lambda (object padding)
+             (let ((bv (make-bytevector (linker-object-size object) 0)))
+               (write-padding port padding)
+               (write-linker-object bv object symtab endianness)
+               (put-bytevector port bv)))
+           objects
+           (compute-padding objects))))))
diff --git a/test-suite/tests/linker.test b/test-suite/tests/linker.test
index 2dc70963d..b77982dfa 100644
--- a/test-suite/tests/linker.test
+++ b/test-suite/tests/linker.test
@@ -55,6 +55,7 @@
            ;; sections adds entries to the string table.
            (shstrtab (make-shstrtab)))
       (link-elf (list sec shstrtab)
+                #:page-aligned? #f                ;return a bytevector
                 #:endianness endianness #:word-size word-size))))
 
 (with-test-prefix "simple"