[Guile-commits] 01/01: Fix linker bug that could fail to find the shstrtab

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit c9e052be495de408e834018f5cc0401874f06c7d
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 8 10:03:33 2018 +0200

    Fix linker bug that could fail to find the shstrtab
    
    * module/system/vm/linker.scm (<linker-object>): Add name field.  This
      allows the linker to find sections by name, notably before having
      found the .shstrtab section.  As there can be multiple sections with
      type SHT_STRTAB, this fixes a bug whereby we could use a section
      name (a strtab index) into an unrelated strtab.  In the past this
      worked because with ASCII identifiers there won't be an exception,
      although it is possible to accidentally mistake a shared string tail;
      but with UTF-8 identifiers, it's possible for a string table index to
      point in the middle of a codepoint, which is likely not valid UTF-8
      and would raise a bug.  Keeping an additional section name field fixes
      this bug.  Adapt all callers to pass a name argument to
      make-linker-object.
      (find-shstrndx): Update to look at the name field.
    * module/system/vm/assembler.scm (make-object): Pass name to
      make-linker-object.
    
    Thanks to Daniel Llorens for the test case.
---
 module/system/vm/assembler.scm |  3 ++-
 module/system/vm/linker.scm    | 33 +++++++++++++++++----------------
 2 files changed, 19 insertions(+), 17 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index d6d3faa..f3682f7 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1550,7 +1550,8 @@ corresponding linker symbol for the start of the section."
   (let ((name-idx (intern-section-name! asm (symbol->string name)))
         (index (asm-next-section-number asm)))
     (set-asm-next-section-number! asm (1+ index))
-    (make-linker-object (apply make-elf-section
+    (make-linker-object (symbol->string name)
+                        (apply make-elf-section
                                #:index index
                                #:name name-idx
                                #:size (bytevector-length bv)
diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm
index 80c3dcf..ac1da6e 100644
--- a/module/system/vm/linker.scm
+++ b/module/system/vm/linker.scm
@@ -79,6 +79,7 @@
 
             make-linker-object
             linker-object?
+            linker-object-name
             linker-object-section
             linker-object-bv
             linker-object-relocs
@@ -133,18 +134,20 @@
   (address linker-symbol-address))
 
 (define-record-type <linker-object>
-  (%make-linker-object section bv relocs symbols)
+  (%make-linker-object name section bv relocs symbols)
   linker-object?
+  (name linker-object-name)
   (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
address@hidden, bytevector contents @var{bv}, list of linker relocations
address@hidden, and list of linker symbols @var{symbols}."
-  (%make-linker-object section bv relocs
+(define (make-linker-object name section bv relocs symbols)
+  "Create a linker object named @var{name} (a string, or #f for no name),
address@hidden<elf-section>} header @var{section}, bytevector contents @var{bv},
+list of linker relocations @var{relocs}, and list of linker symbols
address@hidden"
+  (%make-linker-object name section bv relocs
                        ;; Hide a symbol to the beginning of the section
                        ;; in the symbols.
                        (cons (make-linker-symbol (gensym "*section*") 0)
@@ -396,6 +399,7 @@ the segment table using @code{write-segment-header!}."
                   (addr (align addr (elf-section-addralign section))))
              (values
               (cons (make-linker-object
+                     (linker-object-name o)
                      (relocate-section-header section addr)
                      (linker-object-bv o)
                      (linker-object-relocs o)
@@ -474,13 +478,8 @@ locations, as given in @var{symtab}."
   "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)
-                   (< name (bytevector-length bv))
-                   (string=? (string-table-ref bv name) ".shstrtab")
-                   (elf-section-index section))))
+            (and (equal? (linker-object-name object) ".shstrtab")
+                 (elf-section-index (linker-object-section object))))
           objects))
 
 (define (add-elf-objects objects endianness word-size abi type machine-type)
@@ -513,7 +512,8 @@ list of objects, augmented with objects for the special ELF 
sections."
   ;; SHT_NULL.
   ;;
   (define (make-null-section)
-    (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
+    (make-linker-object ""
+                        (make-elf-section #:index 0 #:type SHT_NULL
                                           #:flags 0 #:addralign 0)
                         #vu8() '() '()))
 
@@ -534,7 +534,8 @@ list of objects, augmented with objects for the special ELF 
sections."
       (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
+      (make-linker-object #f
+                          (make-elf-section #:index index #:type SHT_PROGBITS
                                             #:flags SHF_ALLOC #:size size)
                           bv
                           (list shoff-reloc)
@@ -580,7 +581,7 @@ list of objects, augmented with objects for the special ELF 
sections."
                         relocs))
                      objects
                      (write-and-reloc shoff-label section-table '()))))
-        (%make-linker-object section-table bv relocs
+        (%make-linker-object #f section-table bv relocs
                              (list (make-linker-symbol shoff-label 0))))))
 
   (let* ((null-section (make-null-section))