From 3cd64feb2e069042f453305a0736f8ae277b2015 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 8 Jan 2023 23:32:34 +0100 Subject: 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. --- module/language/bytecode/spec.scm | 17 ++++++++-- module/system/vm/linker.scm | 70 +++++++++++++++++++++++++++++++++------ test-suite/tests/linker.test | 1 + 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" -- cgit v1.2.1