guile/module/system/vm/linker.scm

;;; Guile ELF linker

;; Copyright (C)  2011, 2012, 2013 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; 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 linker combines several linker objects into an executable or a
;;; loadable library.
;;;
;;; There are several common formats for libraries out there.  Since
;;; Guile includes its own linker and loader, we are free to choose any
;;; format, or make up our own.
;;;
;;; There are essentially two requirements for a linker format:
;;; libraries should be able to be loaded with the minimal amount of
;;; work; and they should support introspection in some way, in order to
;;; enable good debugging.
;;;
;;; These requirements are somewhat at odds, as loading should not have
;;; to stumble over features related to introspection.  It so happens
;;; that a lot of smart people have thought about this situation, and
;;; the ELF format embodies the outcome of their thinking.  Guile uses
;;; ELF as its format, regardless of the platform's native library
;;; format.  It's not inconceivable that Guile could interoperate with
;;; the native dynamic loader at some point, but it's not a near-term
;;; goal.
;;;
;;; Guile's linker takes a list of objects, sorts them according to
;;; similarity from the perspective of the loader, then writes them out
;;; into one big bytevector in ELF format.
;;;
;;; It is often the case that different parts of a library need to refer
;;; to each other.  For example, program text may need to refer to a
;;; constant from writable memory.  When the linker places sections
;;; (linker objects) into specific locations in the linked bytevector,
;;; it needs to fix up those references.  This process is called
;;; /relocation/.  References needing relocations are recorded in
;;; "linker-reloc" objects, and collected in a list in each
;;; "linker-object".  The actual definitions of the references are
;;; stored in "linker-symbol" objects, also collected in a list in each
;;; "linker-object".
;;;
;;; By default, the ELF files created by the linker include some padding
;;; so that different parts of the file can be loaded in with different
;;; permissions.  For example, some parts of the file are read-only and
;;; thus can be shared between processes.  Some parts of the file don't
;;; need to be loaded at all.  However this padding can be too much for
;;; interactive compilation, when the code is never written out to disk;
;;; in that case, pass #:page-aligned? #f to `link-elf'.
;;;
;;; Code:

(define-module (system vm linker)
  #: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-linker-reloc
            make-linker-symbol

            make-linker-object
            linker-object?
            linker-object-section
            linker-object-bv
            linker-object-relocs
            (linker-object-symbols* . linker-object-symbols)

            make-string-table
            string-table-intern!
            link-string-table!

            link-elf))

(define-syntax fold-values
  (lambda (x)
    (syntax-case x ()
      ((_ proc list seed ...)
       (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
         #'(let ((p proc))
             (let lp ((l list) (s seed) ...)
               (match l
                 (() (values s ...))
                 ((elt . l)
                  (call-with-values (lambda () (p elt s ...))
                    (lambda (s ...) (lp l s ...))))))))))))

;; A relocation records a reference to a symbol.  When the symbol is
;; resolved to an address, the reloc location will be updated to point
;; to the address.
;;
;; Two types.  Abs32/1 and Abs64/1 are absolute offsets in bytes.
;; Rel32/4 is a relative signed offset in 32-bit units.  Either can have
;; an arbitrary addend as well.
;;
(define-record-type <linker-reloc>
  (make-linker-reloc type loc addend symbol)
  linker-reloc?
  (type linker-reloc-type) ;; rel32/4, abs32/1, abs64/1
  (loc linker-reloc-loc)
  (addend linker-reloc-addend)
  (symbol linker-reloc-symbol))

;; A symbol is an association between a name and an address.  The
;; address is always in regard to some particular address space.  When
;; objects come into the linker, their symbols live in the object
;; address space.  When the objects are allocated into ELF segments, the
;; symbols will be relocated into memory address space, corresponding to
;; the position the ELF will be loaded at.
;;
(define-record-type <linker-symbol>
  (make-linker-symbol name address)
  linker-symbol?
  (name linker-symbol-name)
  (address linker-symbol-address))

(define-record-type <linker-object>
  (%make-linker-object section bv relocs symbols)
  linker-object?
  (section linker-object-section)
  (bv linker-object-bv)
  (relocs linker-object-relocs)
  (symbols linker-object-symbols))

(define (make-linker-object section bv relocs symbols)
  "Create a linker object with the @code{<elf-section>} header
@var{section}, bytevector contents @var{bv}, list of linker relocations
@var{relocs}, and list of linker symbols @var{symbols}."
  (%make-linker-object section bv relocs
                       ;; Hide a symbol to the beginning of the section
                       ;; in the symbols.
                       (cons (make-linker-symbol (gensym "*section*") 0)
                             symbols)))
(define (linker-object-section-symbol object)
  "Return the linker symbol corresponding to the start of this section."
  (car (linker-object-symbols object)))
(define (linker-object-symbols* object)
  "Return the linker symbols defined by the user for this this section."
  (cdr (linker-object-symbols object)))

(define-record-type <string-table>
  (%make-string-table strings linked?)
  string-table?
  (strings string-table-strings set-string-table-strings!)
  (linked? string-table-linked? set-string-table-linked?!))

(define (make-string-table)
  "Return a string table with one entry: the empty string."
  (%make-string-table '(("" 0 #vu8())) #f))

(define (string-table-length strings)
  "Return the number of bytes needed for the @var{strings}."
  (match strings
    (((str pos bytes) . _)
     ;; The + 1 is for the trailing NUL byte.
     (+ pos (bytevector-length bytes) 1))))

(define (string-table-intern! table str)
  "Ensure that @var{str} is present in the string table @var{table}.
Returns the byte index of the string in that table."
  (match table
    (($ <string-table> strings linked?)
     (match (assoc str strings)
       ((_ pos _) pos)
       (#f
        (let ((next (string-table-length strings)))
          (when linked?
            (error "string table already linked, can't intern" table str))
          (set-string-table-strings! table
                                     (cons (list str next (string->utf8 str))
                                           strings))
          next))))))

(define (link-string-table! table)
  "Link the functional string table @var{table} into a sequence of
bytes, suitable for use as the contents of an ELF string table section."
  (match table
    (($ <string-table> strings #f)
     (let ((out (make-bytevector (string-table-length strings) 0)))
       (for-each
        (match-lambda
         ((_ pos bytes)
          (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
        strings)
       (set-string-table-linked?! table #t)
       out))))

(define (segment-kind section)
  "Return the type of segment needed to store @var{section}, as a pair.
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
           ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
           ;; Sections without SHF_ALLOC don't go in segments.
           ((zero? flags) #f)
           (else PT_LOAD))
          (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."
  (length
   (fold-values (lambda (object kinds)
                  (let ((kind (segment-kind (linker-object-section object))))
                    (if (and (car kind) (not (member kind kinds)))
                        (cons kind kinds)
                        kinds)))
                objects
                ;; We know there will be at least one segment,
                ;; containing at least the header and segment table.
                (list (cons PT_LOAD PF_R)))))

(define (group-by-cars ls)
  (let lp ((ls ls) (k #f) (group #f) (out '()))
    (match ls
      (()
       (reverse!
        (if group
            (cons (cons k (reverse! group)) out)
            out)))
      (((k* . v) . ls)
       (if (and group (equal? k k*))
           (lp ls k (cons v group) out)
           (lp ls k* (list v)
               (if group
                   (cons (cons k (reverse! group)) out)
                   out)))))))

(define (collate-objects-into-segments objects)
  "Given the list of linker objects @var{objects}, group them into
contiguous ELF segments of the same type and flags.  The result is an
alist that maps segment types to lists of linker objects.  See
@code{segment-type} for a description of segment types.  Within a
segment, the order of the linker objects is preserved."
  (group-by-cars
   (stable-sort!
    (map (lambda (o)
           (cons (segment-kind (linker-object-section o)) o))
         objects)
    (lambda (x y)
      (let* ((x-kind (car x)) (y-kind (car y))
             (x-type (car x-kind)) (y-type (car y-kind))
             (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
             (x-section (linker-object-section (cdr x)))
             (y-section (linker-object-section (cdr y))))
        (cond
         ((not (equal? x-kind y-kind))
          (cond
           ((and x-type y-type)
            (cond
             ((not (equal? x-flags y-flags))
              (< x-flags y-flags))
             (else
              (< x-type y-type))))
           (else
            (not y-type))))
         ((not (equal? (elf-section-type x-section)
                       (elf-section-type y-section)))
          (cond
           ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
           ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
           (else (< (elf-section-type x-section)
                    (elf-section-type y-section)))))
         (else
          ;; Leave them in the initial order.  This allows us to ensure
          ;; that the ELF header is written first.
          #f)))))))

(define (align address alignment)
  (if (zero? alignment)
      address
      (+ address
         (modulo (- alignment (modulo address alignment)) alignment))))

(define (relocate-section-header sec addr)
  "Return a new section header, just like @var{sec} but with its
@code{addr} and @code{offset} set to @var{addr}."
  (make-elf-section #:index (elf-section-index sec)
                    #:name (elf-section-name sec)
                    #:type (elf-section-type sec)
                    #:flags (elf-section-flags sec)
                    #:addr addr
                    #:offset addr
                    #:size (elf-section-size sec)
                    #:link (elf-section-link sec)
                    #:info (elf-section-info sec)
                    #:addralign (elf-section-addralign sec)
                    #:entsize (elf-section-entsize sec)))

(define *page-size* 4096)

(define (add-symbols symbols offset symtab)
  "Add @var{symbols} to the symbol table @var{symtab}, relocating them
from object address space to memory address space.  Returns a new symbol
table."
  (fold-values
   (lambda (symbol symtab)
     (let ((name (linker-symbol-name symbol))
           (addr (linker-symbol-address symbol)))
       (when (vhash-assq name symtab)
         (error "duplicate symbol" name))
       (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
   symbols
   symtab))

(define (allocate-segment write-segment-header!
                          phidx type flags objects addr symtab alignment)
  "Given a list of linker objects that should go in a segment, the type
and flags that the segment should have, and the address at which the
segment should start, compute the positions that each object should have
in the segment.

Returns three values: the address of the next byte after the segment, a
list of relocated objects, and the symbol table.  The symbol table is
the same as @var{symtab}, augmented with the symbols defined in
@var{objects}, relocated to their positions in the image.

In what is something of a quirky interface, this routine also patches up
the segment table using @code{write-segment-header!}."
  (let* ((alignment (fold-values (lambda (o alignment)
                                   (lcm (elf-section-addralign
                                         (linker-object-section o))
                                        alignment))
                                 objects
                                 alignment))
         (addr (align addr alignment)))
    (receive (objects endaddr symtab)
        (fold-values
         (lambda (o out addr symtab)
           (let* ((section (linker-object-section o))
                  (addr (align addr (elf-section-addralign section))))
             (values
              (cons (make-linker-object
                     (relocate-section-header section addr)
                     (linker-object-bv o)
                     (linker-object-relocs o)
                     (linker-object-symbols o))
                    out)
              (+ addr (elf-section-size section))
              (add-symbols (linker-object-symbols o) addr symtab))))
         objects
         '() addr symtab)
      (when type
        (write-segment-header!
         (make-elf-segment #:index phidx #:type type
                           #:offset addr #:vaddr addr
                           #:filesz (- endaddr addr) #:memsz (- endaddr addr)
                           #:flags flags #:align alignment)))
      (values endaddr
              (reverse objects)
              symtab))))

(define (process-reloc reloc bv section-offset symtab endianness)
  "Process a relocation.  Given that a section containing @var{reloc}
was just written into the image @var{bv} at offset @var{section-offset},
fix it up so that its reference points to the correct position of its
symbol, as present in @var{symtab}."
  (match (vhash-assq (linker-reloc-symbol reloc) symtab)
    (#f
     (error "Undefined symbol" (linker-reloc-symbol reloc)))
    ((name . symbol)
     ;; The reloc was written at LOC bytes after SECTION-OFFSET.
     (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
            (target (linker-symbol-address symbol)))
       (case (linker-reloc-type reloc)
         ((rel32/4)
          (let ((diff (- target offset)))
            (unless (zero? (modulo diff 4))
              (error "Bad offset" reloc symbol offset))
            (bytevector-s32-set! bv offset
                                 (+ (/ diff 4) (linker-reloc-addend reloc))
                                 endianness)))
         ((abs32/1)
          (bytevector-u32-set! bv offset target endianness))
         ((abs64/1)
          (bytevector-u64-set! bv offset target endianness))
         (else
          (error "bad reloc type" reloc)))))))

(define (write-linker-object bv o symtab endianness)
  "Write the bytevector for the section wrapped by the linker object
@var{o} into the image @var{bv}.  The section header in @var{o} should
already be relocated its final position in the image.  Any relocations
in the section will be processed to point to the correct symbol
locations, as given in @var{symtab}."
  (let* ((section (linker-object-section o))
         (offset (elf-section-offset section))
         (len (elf-section-size section))
         (bytes (linker-object-bv o))
         (relocs (linker-object-relocs o)))
    (unless (= offset (elf-section-addr section))
      (error "offset != addr" section))
    (if (not (= (elf-section-type section) SHT_NOBITS))
        (begin
          (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 symtab endianness))
                    relocs)))))

(define (find-shstrndx objects)
  "Find the section name string table in @var{objects}, and return its
section index."
  (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))

(define (add-elf-objects objects endianness word-size)
  "Given the list of linker objects supplied by the user, add linker
objects corresponding to parts of the ELF file: the null object, the ELF
header, and the section table.

Both of these internal objects include relocs, allowing their
inter-object references to be patched up when the final image allocation
is known.  There is special support for patching up the segment table,
however.  Because the segment table needs to know the segment sizes,
which is the difference between two symbols in image space, and there is
no reloc kind that is the difference between two symbols, we make a hack
and return a closure that patches up segment table entries.  It seems to
work.

Returns two values: the procedure to patch the segment table, and the
list of objects, augmented with objects for the special ELF sections."
  (define phoff (elf-header-len word-size))
  (define phentsize (elf-program-header-len word-size))
  (define shentsize (elf-section-header-len word-size))
  (define shnum (+ (length objects) 3))
  (define reloc-kind
    (case word-size
      ((4) 'abs32/1)
      ((8) 'abs64/1)
      (else (error "bad word size" word-size))))

  ;; ELF requires that the first entry in the section table be of type
  ;; SHT_NULL.
  ;;
  (define (make-null-section)
    (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
                                          #:flags 0 #:addralign 0)
                        #vu8() '() '()))

  ;; The ELF header and the segment table.
  ;;
  (define (make-header phnum index shoff-label)
    (let* ((header (make-elf #:byte-order endianness #:word-size word-size
                             #:phoff phoff #:phnum phnum #:phentsize phentsize
                             #:shoff 0 #:shnum shnum #:shentsize shentsize
                             #:shstrndx (or (find-shstrndx objects) SHN_UNDEF)))
           (shoff-reloc (make-linker-reloc reloc-kind
                                           (elf-header-shoff-offset word-size)
                                           0
                                           shoff-label))
           (size (+ phoff (* phnum phentsize)))
           (bv (make-bytevector size 0)))
      (write-elf-header bv header)
      ;; Leave the segment table uninitialized; it will be filled in
      ;; later by calls to the write-segment-header! closure.
      (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
                                            #:flags SHF_ALLOC #:size size)
                          bv
                          (list shoff-reloc)
                          '())))

  ;; The section table.
  ;;
  (define (make-footer objects shoff-label)
    (let* ((size (* shentsize shnum))
           (bv (make-bytevector size 0))
           (section-table (make-elf-section #:index (length objects)
                                            #:type SHT_PROGBITS
                                            #:flags 0
                                            #:size size)))
      (define (write-and-reloc section-label section relocs)
        (let ((offset (* shentsize (elf-section-index section))))
          (write-elf-section-header bv offset endianness word-size section)
          (if (= (elf-section-type section) SHT_NULL)
              relocs
              (cons* (make-linker-reloc
                      reloc-kind
                      (+ offset (elf-section-header-addr-offset word-size))
                      0
                      section-label)
                     (make-linker-reloc
                      reloc-kind
                      (+ offset (elf-section-header-offset-offset word-size))
                      0
                      section-label)
                     relocs))))
      (let ((relocs (fold-values
                     (lambda (object relocs)
                       (write-and-reloc
                        (linker-symbol-name
                         (linker-object-section-symbol object))
                        (linker-object-section object)
                        relocs))
                     objects
                     (write-and-reloc shoff-label section-table '()))))
        (%make-linker-object section-table bv relocs
                             (list (make-linker-symbol shoff-label 0))))))

  (let* ((null-section (make-null-section))
         (objects (cons null-section objects))

         (shoff (gensym "*section-table*"))
         (header (make-header (count-segments objects) (length objects) shoff))
         (objects (cons header objects))

         (footer (make-footer objects shoff))
         (objects (cons footer objects)))

    ;; The header includes the segment table, which needs offsets and
    ;; sizes of the segments.  Normally we would use relocs to rewrite
    ;; these values, but there is no reloc type that would allow us to
    ;; compute size.  Such a reloc would need to take the difference
    ;; between two symbols, and it's probably a bad idea architecturally
    ;; to create one.
    ;;
    ;; So instead we return a closure to patch up the segment table.
    ;; Normally we'd shy away from such destructive interfaces, but it's
    ;; OK as we create the header section ourselves.
    ;;
    (define (write-segment-header! segment)
      (let ((bv (linker-object-bv header))
            (offset (+ phoff (* (elf-segment-index segment) phentsize))))
        (write-elf-program-header bv offset endianness word-size segment)))

    (values write-segment-header! objects)))

(define (allocate-elf objects page-aligned? endianness word-size)
  "Lay out @var{objects} into an ELF image, computing the size of the
file, the positions of the objects, and the global symbol table.

If @var{page-aligned?} is true, read-only and writable data are
separated so that only those writable parts of the image need be mapped
with writable permissions.  This makes the resulting image larger.  It
is more suitable to situations where you would write a file out to disk
and read it in with mmap.  Otherwise if @var{page-aligned?} is false,
sections default to 8-byte alignment.

Returns three values: the total image size, a list of objects with
relocated headers, and the global symbol table."
  (receive (write-segment-header! objects)
      (add-elf-objects objects endianness word-size)
    (let lp ((seglists (collate-objects-into-segments objects))
             (objects '())
             (phidx 0)
             (addr 0)
             (symtab vlist-null)
             (prev-flags 0))
      (match seglists
        ((((type . flags) objs-in ...) seglists ...)
         (receive (addr objs-out symtab)
             (allocate-segment
              write-segment-header!
              phidx type flags objs-in addr symtab
              (if (and page-aligned?
                       (not (= flags prev-flags))
                       ;; Allow sections that are not in
                       ;; loadable segments to share pages
                       ;; with PF_R segments.
                       (not (and (not type) (= PF_R prev-flags))))
                  *page-size*
                  8))
           (lp seglists
               (fold-values cons objs-out objects)
               (if type (1+ phidx) phidx)
               addr
               symtab
               flags)))
        (()
         (values addr
                 (reverse objects)
                 symtab))))))

(define (check-section-numbers objects)
  "Verify that taken as a whole, that all objects have distinct,
contiguous section numbers, starting from 1.  (Section 0 is the null
section.)"
  (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
         (sections (make-vector nsections #f)))
    (for-each (lambda (object)
                (let ((n (elf-section-index (linker-object-section object))))
                  (cond
                   ((< n 1)
                    (error "Invalid section number" object))
                   ((>= n nsections)
                    (error "Invalid section number" object))
                   ((vector-ref sections n)
                    (error "Duplicate section" (vector-ref sections n) object))
                   (else
                    (vector-set! sections n object)))))
              objects)))

;; Given a list of linker objects, collate the objects into segments,
;; allocate the segments, allocate the ELF bytevector, 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)))
  "Create an ELF image from the linker objects, @var{objects}.

If @var{page-aligned?} is true, read-only and writable data are
separated so that only those writable parts of the image need be mapped
with writable permissions.  This is suitable for situations where you
would write a file out to disk and read it in with @code{mmap}.
Otherwise if @var{page-aligned?} is false, sections default to 8-byte
alignment.

Returns a bytevector."
  (check-section-numbers objects)
  (receive (size objects symtab)
      (allocate-elf objects page-aligned? endianness word-size)
    (let ((bv (make-bytevector size 0)))
      (for-each
       (lambda (object)
         (write-linker-object bv object symtab endianness))
       objects)
      bv)))