[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-304-g302b643
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-304-g302b643 |
|
Date: |
Fri, 01 Jun 2012 14:47:45 +0000 |
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=302b6436da882ea95dcce36dc54f36822b4114f3
The branch, wip-rtl has been updated
via 302b6436da882ea95dcce36dc54f36822b4114f3 (commit)
via dc3f9730d2d850f2c1a594bcff4193a4801022c3 (commit)
via 541eee314d67a5268691747aa2f0e6ee5f0bb455 (commit)
from 41dcd5ad8bf3e046f7a06d57de08d4d59d6b2106 (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 302b6436da882ea95dcce36dc54f36822b4114f3
Author: Andy Wingo <address@hidden>
Date: Fri Jun 1 16:47:29 2012 +0200
emit a PT_DYNAMIC segment for ELF loading
* module/system/vm/elf.scm (<reloc>): Give relocs a type, which
implicitly includes the unit-size.
(segment-kind): Add support for PT_DYNAMIC, and conditionalize PF_R on
SHF_ALLOC.
(collate-objects-into-segments): Sort by flags first, then segment
type. Should reduce the number of pages.
(alloc-segment): Only align on a new page boundary if the flags differ
from the previously written segment.
(process-reloc): Handle relocs by type. Add support for absolute
relocs.
(link-elf): Thread prev-flags through the alloc-segment loop. Give
the first section header a #:flags 0.
* module/system/vm/rtl.scm (process-relocs): Adapt to elf reloc change.
(make-object): New helper.
(link-text-object): Use the new helper.
(link-dynamic-section): New function.
(link-string-table): Use the helper.
(link-data): Rework to return sections as values.
(link-objects): Refactoring to emit a PT_DYNAMIC segment.
commit dc3f9730d2d850f2c1a594bcff4193a4801022c3
Author: Andy Wingo <address@hidden>
Date: Thu May 31 11:26:35 2012 +0200
elf: reserve section 0
* module/system/vm/elf.scm (compute-sections-by-name, link-elf): Reserve
section 0, to pacify readelf.
commit 541eee314d67a5268691747aa2f0e6ee5f0bb455
Author: Andy Wingo <address@hidden>
Date: Thu May 31 11:25:53 2012 +0200
fix segment permissions
* module/system/vm/elf.scm (segment-kind): Fix permissions for program
segments.
-----------------------------------------------------------------------
Summary of changes:
module/system/vm/elf.scm | 181 +++++++++++++++++++++++++++++++++------------
module/system/vm/rtl.scm | 184 ++++++++++++++++++++++++++++++----------------
2 files changed, 252 insertions(+), 113 deletions(-)
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 7424227..dc99acf 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -56,6 +56,17 @@
SHF_INFO_LINK SHF_LINK_ORDER SHF_OS_NONCONFORMING SHF_GROUP
SHF_TLS
+ DT_NULL DT_NEEDED DT_PLTRELSZ DT_PLTGOT DT_HASH DT_STRTAB
+ DT_SYMTAB DT_RELA DT_RELASZ DT_RELAENT DT_STRSZ DT_SYMENT
+ DT_INIT DT_FINI DT_SONAME DT_RPATH DT_SYMBOLIC DT_REL
+ DT_RELSZ DT_RELENT DT_PLTREL DT_DEBUG DT_TEXTREL DT_JMPREL
+ DT_BIND_NOW DT_INIT_ARRAY DT_FINI_ARRAY DT_INIT_ARRAYSZ
+ DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
+ DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
+ DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
+ DT_GUILE_RTL_VERSION DT_HIGUILE DT_LOOS DT_HIOS DT_LOPROC
+ DT_HIPROC
+
parse-elf
elf-segment elf-segments
elf-section elf-sections elf-sections-by-name
@@ -66,7 +77,13 @@
(make-reloc . make-elf-reloc)
(make-symbol . make-elf-symbol)
+
(make-object . make-elf-object)
+ (object? . elf-object?)
+ (object-section . elf-object-section)
+ (object-bv . elf-object-bv)
+ (object-relocs . elf-object-relocs)
+ (object-symbols . elf-object-symbols)
link-elf))
@@ -652,6 +669,56 @@
(define SHF_GROUP (ash 1 9)) ; Section is member of a group.
(define SHF_TLS (ash 1 10)) ; Section hold thread-local data.
+;;
+;; Dynamic entry types. The DT_GUILE types are non-standard.
+;;
+(define DT_NULL 0) ; Marks end of dynamic section
+(define DT_NEEDED 1) ; Name of needed library
+(define DT_PLTRELSZ 2) ; Size in bytes of PLT relocs
+(define DT_PLTGOT 3) ; Processor defined value
+(define DT_HASH 4) ; Address of symbol hash table
+(define DT_STRTAB 5) ; Address of string table
+(define DT_SYMTAB 6) ; Address of symbol table
+(define DT_RELA 7) ; Address of Rela relocs
+(define DT_RELASZ 8) ; Total size of Rela relocs
+(define DT_RELAENT 9) ; Size of one Rela reloc
+(define DT_STRSZ 10) ; Size of string table
+(define DT_SYMENT 11) ; Size of one symbol table entry
+(define DT_INIT 12) ; Address of init function
+(define DT_FINI 13) ; Address of termination
function
+(define DT_SONAME 14) ; Name of shared object
+(define DT_RPATH 15) ; Library search path (deprecated)
+(define DT_SYMBOLIC 16) ; Start symbol search here
+(define DT_REL 17) ; Address of Rel relocs
+(define DT_RELSZ 18) ; Total size of Rel relocs
+(define DT_RELENT 19) ; Size of one Rel reloc
+(define DT_PLTREL 20) ; Type of reloc in PLT
+(define DT_DEBUG 21) ; For debugging ; unspecified
+(define DT_TEXTREL 22) ; Reloc might modify .text
+(define DT_JMPREL 23) ; Address of PLT relocs
+(define DT_BIND_NOW 24) ; Process relocations of object
+(define DT_INIT_ARRAY 25) ; Array with addresses of init
fct
+(define DT_FINI_ARRAY 26) ; Array with addresses of fini
fct
+(define DT_INIT_ARRAYSZ 27) ; Size in bytes of DT_INIT_ARRAY
+(define DT_FINI_ARRAYSZ 28) ; Size in bytes of DT_FINI_ARRAY
+(define DT_RUNPATH 29) ; Library search path
+(define DT_FLAGS 30) ; Flags for the object being loaded
+(define DT_ENCODING 32) ; Start of encoded range
+(define DT_PREINIT_ARRAY 32) ; Array with addresses of preinit fc
+(define DT_PREINIT_ARRAYSZ 33) ; size in bytes of DT_PREINIT_ARRAY
+(define DT_NUM 34) ; Number used
+(define DT_LOGUILE #x37146000) ; Start of Guile-specific
+(define DT_GUILE_GC_ROOT #x37146000) ; Offset of GC roots
+(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
+(define DT_GUILE_ENTRY #x37146002) ; Address of entry thunk
+(define DT_GUILE_RTL_VERSION #x37146003); Bytecode version
+(define DT_HIGUILE #x37146fff) ; End of Guile-specific
+(define DT_LOOS #x6000000d) ; Start of OS-specific
+(define DT_HIOS #x6ffff000) ; End of OS-specific
+(define DT_LOPROC #x70000000) ; Start of processor-specific
+(define DT_HIPROC #x7fffffff) ; End of processor-specific
+
+
(define (string-table-ref bv offset)
(let lp ((end offset))
(if (zero? (bytevector-u8-ref bv end))
@@ -679,19 +746,16 @@
;; resolved to an address, the reloc location will be updated to point
;; to the address.
;;
-;; There are a couple of wrinkles. One is that the distance between the
-;; address and the reloc can be measured in units other than bytes. For
-;; example, to measure the distance in uint32 units, unit-size can be 4.
-;; The other is that an arbitrary value (the addend) can be added on to
-;; the reloc after processing.
+;; 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 <reloc>
- (make-reloc loc addend unit-size symbol)
+ (make-reloc type loc addend symbol)
reloc?
- ;; could add a type here
+ (type reloc-type) ;; rel32/4, abs32/1, abs64/1
(loc reloc-loc)
(addend reloc-addend)
- (unit-size reloc-unit-size)
(symbol reloc-symbol))
;; A symbol is an association between a name and an address. The
@@ -745,21 +809,19 @@
(define (segment-kind section)
(let ((flags (elf-section-flags section)))
- (cons (if (zero? (logand SHF_ALLOC flags))
- PT_NOTE
- PT_LOAD)
- (logior PF_R
+ (cons (cond
+ ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+ ((zero? (logand SHF_ALLOC flags)) PT_NOTE)
+ (else PT_LOAD))
+ (logior (if (zero? (logand SHF_ALLOC flags))
+ 0
+ PF_R)
(if (zero? (logand SHF_EXECINSTR flags))
- PF_X
- 0)
+ 0
+ PF_X)
(if (zero? (logand SHF_WRITE flags))
- PF_W
- 0)))))
-
-(define (section-kind< a b)
- (if (= (car a) (car b))
- (< (cdr a) (cdr b))
- (< (car a) (car b))))
+ 0
+ PF_W)))))
(define (group-by-cars ls)
(let lp ((in ls) (k #f) (group #f) (out '()))
@@ -784,18 +846,20 @@
(cons (segment-kind (object-section o)) o))
objects)
(lambda (x y)
- (let ((x-kind (car x))
- (y-kind (car y))
+ (let ((x-type (caar x)) (y-type (caar y))
+ (x-flags (cdar x)) (y-flags (cdar y))
(x-section (object-section (cdr x)))
(y-section (object-section (cdr y))))
(cond
- ((not (equal? x-kind y-kind))
- (section-kind< x-kind y-kind))
+ ((not (equal? x-flags y-flags))
+ (< x-flags y-flags))
+ ((not (equal? x-type y-type))
+ (< x-type 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 x-section) SHT_NOBITS) #f)
+ ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
(else (< (elf-section-type x-section)
(elf-section-type y-section)))))
(else
@@ -826,6 +890,13 @@
(receive (s0 s1 s2 s3) (proc (car ls) s0 s1 s2 s3)
(lp (cdr ls) s0 s1 s2 s3)))))
+(define (fold5 proc ls s0 s1 s2 s3 s4)
+ (let lp ((ls ls) (s0 s0) (s1 s1) (s2 s2) (s3 s3) (s4 s4))
+ (if (null? ls)
+ (values s0 s1 s2 s3 s4)
+ (receive (s0 s1 s2 s3 s4) (proc (car ls) s0 s1 s2 s3 s4)
+ (lp (cdr ls) s0 s1 s2 s3 s4)))))
+
(define (relocate-section-header sec fileaddr memaddr)
(make-elf-section (elf-section-name sec) (elf-section-type sec)
(elf-section-flags sec) memaddr
@@ -846,13 +917,13 @@
symbols
symtab))
-(define (alloc-segment type flags objects fileaddr memaddr symtab)
- (let* ((loadable? (= type PT_LOAD))
+(define (alloc-segment type flags objects fileaddr memaddr symtab prev-flags)
+ (let* ((loadable? (not (zero? flags)))
(alignment (fold1 (lambda (o alignment)
(lcm (elf-section-addralign (object-section o))
alignment))
objects
- (if loadable? *page-size* 8)))
+ (if (= flags prev-flags) 8 *page-size*)))
(fileaddr (align fileaddr alignment))
(memaddr (align memaddr alignment)))
(receive (objects fileend memend symtab)
@@ -892,17 +963,23 @@
(error "Undefined symbol" (reloc-symbol reloc)))
(let* ((file-loc (+ (reloc-loc reloc) file-offset))
(mem-loc (+ (reloc-loc reloc) mem-offset))
- (addr (symbol-address (cdr ent)))
- (diff (- addr mem-loc))
- (unit-size (reloc-unit-size reloc)))
- (unless (zero? (modulo diff unit-size))
- (error "Bad offset" reloc symbol mem-offset))
- (pk reloc file-offset mem-offset)
- (pk file-loc mem-loc addr diff unit-size)
- ;; Currently we only do signed relative 32-bit relocs.
- (bytevector-s32-set! bv file-loc
- (+ (/ diff unit-size) (reloc-addend reloc))
- endianness))))
+ (addr (symbol-address (cdr ent))))
+ (case (reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- addr mem-loc)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol mem-offset))
+ (pk reloc file-offset mem-offset)
+ (pk file-loc mem-loc addr diff)
+ (bytevector-s32-set! bv file-loc
+ (+ (/ diff 4) (reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv file-loc addr endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv file-loc addr endianness))
+ (else
+ (error "bad reloc type" reloc))))))
(define (write-object bv o symtab endianness)
(let* ((section (object-section o))
@@ -922,7 +999,7 @@
(define (compute-sections-by-name seglists)
(let lp ((in (apply append (map cdr seglists)))
- (n 0) (out '()) (shstrtab #f))
+ (n 1) (out '()) (shstrtab #f))
(if (null? in)
(fold1 (lambda (x tail)
(cond
@@ -952,19 +1029,20 @@
(let* ((seglists (collate-objects-into-segments objects))
(sections-by-name (compute-sections-by-name seglists))
(nsegments (length seglists))
- (nsections (length objects))
+ (nsections (1+ (length objects))) ;; 1+ for the first reserved entry.
(program-headers-offset (elf-header-len word-size))
(fileaddr (+ program-headers-offset
(* nsegments (elf-program-header-len word-size))))
(memaddr 0))
- (receive (out fileend memend symtab)
- (fold4
- (lambda (x out fileaddr memaddr symtab)
+ (receive (out fileend memend symtab _)
+ (fold5
+ (lambda (x out fileaddr memaddr symtab prev-flags)
(let ((type (caar x))
(flags (cdar x))
(objects (cdr x)))
(receive (segment objects symtab)
- (alloc-segment type flags objects fileaddr memaddr symtab)
+ (alloc-segment type flags objects fileaddr memaddr symtab
+ prev-flags)
(values
(cons (cons segment objects) out)
(+ (elf-segment-offset segment) (elf-segment-filesz segment))
@@ -972,8 +1050,9 @@
memaddr
(+ (elf-segment-vaddr segment)
(elf-segment-memsz segment)))
- symtab))))
- seglists '() fileaddr memaddr vlist-null)
+ symtab
+ flags))))
+ seglists '() fileaddr memaddr vlist-null 0)
(let* ((out (reverse! out))
(section-table-offset (+ (align fileend word-size)))
(fileend (+ section-table-offset
@@ -984,6 +1063,10 @@
#:shoff section-table-offset #:shnum nsections
#:shstrndx (or (assoc-ref sections-by-name
".shstrtab")
SHN_UNDEF))
+ (write-elf-section-header bv section-table-offset
+ endianness word-size
+ (make-elf-section* #:type SHT_NULL #:flags 0
+ #:addralign 0))
(fold2 (lambda (x phidx shidx)
(write-elf-program-header
bv (+ program-headers-offset
@@ -999,5 +1082,5 @@
endianness word-size (object-section o))
(1+ shidx))
(cdr x) shidx)))
- out 0 0)
+ out 0 1)
bv))))
diff --git a/module/system/vm/rtl.scm b/module/system/vm/rtl.scm
index 9df4f85..a98b749 100644
--- a/module/system/vm/rtl.scm
+++ b/module/system/vm/rtl.scm
@@ -539,7 +539,7 @@
(let ((rel (- abs (caddr reloc))))
(s32-set! buf dst rel)
tail)
- (cons (make-elf-reloc (* dst 4) (cadddr reloc) 4 (cadr reloc))
+ (cons (make-elf-reloc 'rel32/4 (* dst 4) (cadddr reloc) (cadr
reloc))
tail)))
((x8-s24)
(unless abs
@@ -569,6 +569,15 @@
(endianness little))
(lp (+ pos 4))))))
+(define (make-object asm name bv relocs labels . kwargs)
+ (let ((name-idx (intern-string! asm (symbol->string name))))
+ (make-elf-object (apply make-elf-section
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (cons (make-elf-symbol name 0) labels))))
+
(define (link-text-object asm)
(let ((buf (make-u32vector (asm-pos asm))))
(let lp ((pos 0) (prev (asm-prev asm)))
@@ -577,25 +586,65 @@
(bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
(unless (eq? (asm-endianness asm) (native-endianness))
(swap-bytes! buf))
- (make-elf-object (make-elf-section
- #:name (intern-string! asm ".rtl-text")
- #:size byte-size)
- buf
- (process-relocs buf (asm-relocs asm)
- (asm-labels asm))
- (process-labels (asm-labels asm))))
+ (make-object asm '.rtl-text
+ buf
+ (process-relocs buf (asm-relocs asm)
+ (asm-labels asm))
+ (process-labels (asm-labels asm))))
(let ((len (* *block-size* 4)))
(bytevector-copy! (car prev) 0 buf pos len)
(lp (+ pos len) (cdr prev)))))))
+(define (link-dynamic-section asm text ro rw rw-init)
+ (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
+ (let* ((endianness (asm-endianness asm))
+ (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
+ (set-uword!
+ (lambda (i uword)
+ (%set-uword! bv (* i word-size) uword endianness)))
+ (relocs '())
+ (set-label!
+ (lambda (i label)
+ (set! relocs (cons (make-elf-reloc 'reloc-type
+ (* i word-size) 0 label)
+ relocs))
+ (%set-uword! bv (* i word-size) 0 endianness))))
+ (set-uword! 0 DT_GUILE_RTL_VERSION)
+ (set-uword! 1 #x02020000)
+ (set-uword! 2 DT_GUILE_ENTRY)
+ (set-label! 3 '.rtl-text)
+ (cond
+ (rw
+ ;; Add roots to GC.
+ (set-uword! 4 DT_GUILE_GC_ROOT)
+ (set-label! 5 '.data)
+ (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
+ (set-uword! 7 (bytevector-length (elf-object-bv rw)))
+ (cond
+ (rw-init
+ (set-uword! 8 DT_INIT) ; constants
+ (set-label! 9 '.rtl-init)
+ (set-uword! 10 DT_NULL)
+ (set-uword! 11 0))
+ (else
+ (set-uword! 8 DT_NULL)
+ (set-uword! 9 0))))
+ (else
+ (set-uword! 4 DT_NULL)
+ (set-uword! 5 0)))
+ (make-object asm '.dynamic bv relocs '()
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
+ (case (asm-word-size asm)
+ ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
+ ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
+ (else (error "bad word size" asm))))
+
(define (link-string-table asm)
- (let* ((name (intern-string! asm ".shstrtab"))
- (bv (link-elf-string-table (asm-string-table asm))))
- (make-elf-object (make-elf-section #:name name
- #:type SHT_STRTAB
- #:flags 0
- #:size (bytevector-length bv))
- bv '() '())))
+ (intern-string! asm ".shstrtab")
+ (make-object asm '.shstrtab
+ (link-elf-string-table (asm-string-table asm))
+ '() '()
+ #:type SHT_STRTAB #:flags 0))
(define (align address alignment)
(+ address
@@ -727,7 +776,8 @@
inits))
(define (link-inits asm inits)
- '())
+ ;; FIXME
+ #f)
(define (link-data asm data strings-are-stringbufs?)
(define (statically-allocatable? x)
@@ -751,42 +801,44 @@
(else
(asm-word-size asm))))
- (let* ((byte-len (vhash-fold (lambda (k v len)
- (+ (byte-length k) (align len 8)))
- 0 data))
- (buf (make-bytevector byte-len 0))
- (name (intern-string! asm
- (if strings-are-stringbufs? ".rodata"
".data"))))
- (let lp ((i 0) (pos 0) (labels '()) (inits '()))
- (if (< i (vlist-length data))
- (let* ((pair (vlist-ref data i))
- (obj (car pair))
- (obj-label (cdr pair)))
- (lp (1+ i)
- (align (+ (byte-length obj) pos) 8)
- (cons (make-elf-symbol (cdr pair) pos) labels)
- (cond
- ((string? obj)
- (if strings-are-stringbufs?
- (write-stringbuf asm buf pos obj obj-label inits)
- (write-string asm buf pos obj obj-label inits)))
- ((pair? obj)
- (write-pair asm buf pos obj obj-label inits))
- ((vector? obj)
- (write-vector asm buf pos obj obj-label inits))
- ((symbol? obj)
- (write-symbol asm buf pos obj obj-label inits))
- ((keyword? obj)
- (write-keyword asm buf pos obj obj-label inits))
- ((number? obj)
- (write-number asm buf pos obj obj-label inits))
- (else
- (error "unrecognized object" obj)))))
- (cons (make-elf-object (make-elf-section #:name name #:size byte-len)
- buf '() labels)
- (if (null? inits)
- '()
- (link-inits asm (reverse inits))))))))
+ (cond
+ ((vlist-null? data)
+ (values #f #f))
+ (else
+ (let* ((byte-len (vhash-fold (lambda (k v len)
+ (+ (byte-length k) (align len 8)))
+ 0 data))
+ (buf (make-bytevector byte-len 0))
+ (name (if strings-are-stringbufs? '.rodata '.data)))
+ (let lp ((i 0) (pos 0) (labels '())
+ (inits '()))
+ (if (< i (vlist-length data))
+ (let* ((pair (vlist-ref data i))
+ (obj (car pair))
+ (obj-label (cdr pair)))
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (cons (make-elf-symbol (cdr pair) pos) labels)
+ (cond
+ ((string? obj)
+ (if strings-are-stringbufs?
+ (write-stringbuf asm buf pos obj obj-label inits)
+ (write-string asm buf pos obj obj-label inits)))
+ ((pair? obj)
+ (write-pair asm buf pos obj obj-label inits))
+ ((vector? obj)
+ (write-vector asm buf pos obj obj-label inits))
+ ((symbol? obj)
+ (write-symbol asm buf pos obj obj-label inits))
+ ((keyword? obj)
+ (write-keyword asm buf pos obj obj-label inits))
+ ((number? obj)
+ (write-number asm buf pos obj obj-label inits))
+ (else
+ (error "unrecognized object" obj)))))
+ (values (make-object asm name buf '() labels)
+ (and (not (null? inits))
+ (link-inits asm (reverse inits))))))))))
;; Hummm
;;
@@ -813,24 +865,28 @@
(ro (archive-stringbufs archive))
(rw vlist-null))
(if (= i len)
- (append (if (vlist-null? ro)
- '()
- (link-data asm ro #t))
- (if (vlist-null? rw)
- '()
- (link-data asm rw #f)))
+ (call-with-values (lambda () (link-data asm ro #t))
+ (lambda (ro ro-init)
+ (when ro-init
+ (error "read-only data should have no initializers!"))
+ (call-with-values (lambda () (link-data asm rw #f))
+ (lambda (rw rw-init)
+ (values ro rw rw-init)))))
(let ((pair (vlist-ref constants i)))
(if (shareable? (car pair))
(lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
(lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
(define (link-objects asm)
- (let* ((text (link-text-object asm))
- (constants (link-constants asm))
- ;; This needs to be linked last, because linking other sections
- ;; adds entries to the string table.
- (shstrtab (link-string-table asm)))
- (cons* shstrtab text constants)))
+ (let ((text (link-text-object asm)))
+ (call-with-values (lambda () (link-constants asm))
+ (lambda (ro rw rw-init)
+ (let* ((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-string-table asm)))
+ (filter identity
+ (list text ro rw rw-init dt shstrtab)))))))
(define (link-assembly asm)
(link-elf (link-objects asm)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl, updated. v2.1.0-304-g302b643,
Andy Wingo <=