[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.0.5-911-gc9d70fa

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=c9d70fa403a8ff5dd32e3b5ee8893d5695da22b8

The branch, wip-rtl has been updated
       via  c9d70fa403a8ff5dd32e3b5ee8893d5695da22b8 (commit)
      from  e6b369f391cd4558ce04618b369540ed3913fc03 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit c9d70fa403a8ff5dd32e3b5ee8893d5695da22b8
Author: Andy Wingo <address@hidden>
Date:   Sun Apr 21 23:13:13 2013 +0200

    assembling RTL writes a symbol table
    
    * module/system/vm/elf.scm (make-elf-symbol*): Add constructor; export
      as make-elf-symbol.
      (elf-symbol-len): New export.
      (write-elf32-symbol, write-elf64-symbol): New helpers.
      (write-elf-symbol): New export.
    
    * module/system/vm/rtl.scm (link-symtab): New function.
      (link-objects): Write a symbol table into the resulting ELF.

-----------------------------------------------------------------------

Summary of changes:
 module/system/vm/elf.scm |   41 ++++++++++++++++++++++++++++++++-
 module/system/vm/rtl.scm |   57 +++++++++++++++++++++++++++++++++++++---------
 2 files changed, 86 insertions(+), 12 deletions(-)

diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 1d3d15e..f0c0a48 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -74,11 +74,14 @@
 
             elf-section-header-len write-elf-section-header
 
-            make-elf-symbol elf-symbol?
+            (make-elf-symbol* . make-elf-symbol)
+            elf-symbol?
             elf-symbol-name elf-symbol-value elf-symbol-size
             elf-symbol-info elf-symbol-other elf-symbol-shndx
             elf-symbol-binding elf-symbol-type elf-symbol-visibility
 
+            elf-symbol-len write-elf-symbol
+
             SHN_UNDEF
 
             SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
@@ -792,6 +795,13 @@
   (other elf-symbol-other)
   (shndx elf-symbol-shndx))
 
+(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
+                           (binding STB_LOCAL) (type STT_NOTYPE)
+                           (info (logior (ash binding 4) type))
+                           (visibility STV_DEFAULT) (other visibility)
+                           (shndx SHN_UNDEF))
+  (make-elf-symbol name value size info other shndx))
+
 ;; typedef struct {
 ;;     uint32_t      st_name;
 ;;     Elf32_Addr    st_value;
@@ -801,6 +811,12 @@
 ;;     uint16_t      st_shndx;
 ;; } Elf32_Sym;
 
+(define (elf-symbol-len word-size)
+  (case word-size
+    ((4) 16)
+    ((8) 24)
+    (else (error "bad word size" word-size))))
+
 (define (parse-elf32-symbol bv offset stroff byte-order)
   (if (<= (+ offset 16) (bytevector-length bv))
       (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
@@ -814,6 +830,14 @@
                        (bytevector-u16-ref bv (+ offset 14) byte-order))
       (error "corrupt ELF (offset out of range)" offset)))
 
+(define (write-elf32-symbol bv offset byte-order sym)
+  (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+  (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
+  (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
+  (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
+  (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
+  (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))
+
 ;; typedef struct {
 ;;     uint32_t      st_name;
 ;;     unsigned char st_info;
@@ -836,6 +860,21 @@
                        (bytevector-u16-ref bv (+ offset 6) byte-order))
       (error "corrupt ELF (offset out of range)" offset)))
 
+(define (write-elf64-symbol bv offset byte-order sym)
+  (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+  (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
+  (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
+  (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
+  (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
+  (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))
+
+(define (write-elf-symbol bv offset byte-order word-size sym)
+  ((case word-size
+     ((4) write-elf32-symbol)
+     ((8) write-elf64-symbol)
+     (else (error "invalid word size" word-size)))
+   bv offset byte-order sym))
+
 (define* (elf-symbol-table-ref elf section n #:optional strtab)
   (let ((bv (elf-bytes elf))
         (byte-order (elf-byte-order elf))
diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
index 6848207..ea0cbc2 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/rtl.scm
@@ -30,6 +30,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
   #:export (make-assembler
             emit-text
             link-assembly
@@ -991,18 +992,52 @@
                 (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
                 (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
 
+(define (link-symtab text-section asm)
+  (let* ((endianness (asm-endianness asm))
+         (word-size (asm-word-size asm))
+         (size (elf-symbol-len word-size))
+         (meta (reverse (asm-meta asm)))
+         (n (length meta))
+         (strtab (make-string-table))
+         (bv (make-bytevector (* n size) 0)))
+    (define (intern-string! name)
+      (call-with-values
+          (lambda () (string-table-intern strtab (symbol->string name)))
+        (lambda (table idx)
+          (set! strtab table)
+          idx)))
+    (for-each
+     (lambda (meta n)
+       (let ((name (intern-string! (meta-name meta))))
+         (write-elf-symbol bv (* n size) endianness word-size
+                           (make-elf-symbol
+                            #:name name
+                            #:value (meta-low-pc meta)
+                            #:size (- (meta-high-pc meta) (meta-low-pc meta))
+                            #:type STT_FUNC
+                            #:visibility STV_HIDDEN
+                            #:shndx (elf-section-index text-section)))))
+     meta (iota n))
+    (values (make-object asm '.symtab
+                         bv
+                         '() '()
+                         #:type SHT_SYMTAB #:flags 0)
+            (make-object asm '.strtab
+                         (link-string-table strtab)
+                         '() '()
+                         #:type SHT_STRTAB #:flags 0))))
+
 (define (link-objects asm)
-  (call-with-values (lambda () (link-constants asm))
-    (lambda (ro rw rw-init)
-      (let* (;; Link text object after constants, so that the constants
-             ;; initializer gets included.
-             (text (link-text-object asm))
-             (dt (link-dynamic-section asm text ro rw rw-init))
-             ;; This needs to be linked last, because linking other
-             ;; sections adds entries to the string table.
-             (shstrtab (link-shstrtab asm)))
-        (filter identity
-                (list text ro rw dt shstrtab))))))
+  (let*-values (((ro rw rw-init) (link-constants asm))
+                ;; Link text object after constants, so that the
+                ;; constants initializer gets included.
+                ((text) (link-text-object asm))
+                ((dt) (link-dynamic-section asm text ro rw rw-init))
+                ((symtab strtab) (link-symtab (linker-object-section text) 
asm))
+                ;; This needs to be linked last, because linking other
+                ;; sections adds entries to the string table.
+                ((shstrtab) (link-shstrtab asm)))
+    (filter identity (list text ro rw dt symtab strtab shstrtab))))
 
 (define (link-assembly asm)
   (link-elf (link-objects asm)))


hooks/post-receive
-- 
GNU Guile