linker.scm 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698
  1. ;;; Guile ELF linker
  2. ;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 3 of the License, or (at your option) any later version.
  7. ;;;;
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;; Commentary:
  17. ;;;
  18. ;;; A linker combines several linker objects into an executable or a
  19. ;;; loadable library.
  20. ;;;
  21. ;;; There are several common formats for libraries out there. Since
  22. ;;; Guile includes its own linker and loader, we are free to choose any
  23. ;;; format, or make up our own.
  24. ;;;
  25. ;;; There are essentially two requirements for a linker format:
  26. ;;; libraries should be able to be loaded with the minimal amount of
  27. ;;; work; and they should support introspection in some way, in order to
  28. ;;; enable good debugging.
  29. ;;;
  30. ;;; These requirements are somewhat at odds, as loading should not have
  31. ;;; to stumble over features related to introspection. It so happens
  32. ;;; that a lot of smart people have thought about this situation, and
  33. ;;; the ELF format embodies the outcome of their thinking. Guile uses
  34. ;;; ELF as its format, regardless of the platform's native library
  35. ;;; format. It's not inconceivable that Guile could interoperate with
  36. ;;; the native dynamic loader at some point, but it's not a near-term
  37. ;;; goal.
  38. ;;;
  39. ;;; Guile's linker takes a list of objects, sorts them according to
  40. ;;; similarity from the perspective of the loader, then writes them out
  41. ;;; into one big bytevector in ELF format.
  42. ;;;
  43. ;;; It is often the case that different parts of a library need to refer
  44. ;;; to each other. For example, program text may need to refer to a
  45. ;;; constant from writable memory. When the linker places sections
  46. ;;; (linker objects) into specific locations in the linked bytevector,
  47. ;;; it needs to fix up those references. This process is called
  48. ;;; /relocation/. References needing relocations are recorded in
  49. ;;; "linker-reloc" objects, and collected in a list in each
  50. ;;; "linker-object". The actual definitions of the references are
  51. ;;; stored in "linker-symbol" objects, also collected in a list in each
  52. ;;; "linker-object".
  53. ;;;
  54. ;;; By default, the ELF files created by the linker include some padding
  55. ;;; so that different parts of the file can be loaded in with different
  56. ;;; permissions. For example, some parts of the file are read-only and
  57. ;;; thus can be shared between processes. Some parts of the file don't
  58. ;;; need to be loaded at all. However this padding can be too much for
  59. ;;; interactive compilation, when the code is never written out to disk;
  60. ;;; in that case, pass #:page-aligned? #f to `link-elf'.
  61. ;;;
  62. ;;; Code:
  63. (define-module (system vm linker)
  64. #:use-module (rnrs bytevectors)
  65. #:use-module (system foreign)
  66. #:use-module (system base target)
  67. #:use-module ((srfi srfi-1) #:select (append-map))
  68. #:use-module (srfi srfi-9)
  69. #:use-module (ice-9 receive)
  70. #:use-module (ice-9 vlist)
  71. #:use-module (ice-9 match)
  72. #:use-module (system vm elf)
  73. #:export (make-linker-reloc
  74. make-linker-symbol
  75. make-linker-object
  76. linker-object?
  77. linker-object-section
  78. linker-object-bv
  79. linker-object-relocs
  80. (linker-object-symbols* . linker-object-symbols)
  81. make-string-table
  82. string-table-intern!
  83. link-string-table!
  84. link-elf))
  85. (define-syntax fold-values
  86. (lambda (x)
  87. (syntax-case x ()
  88. ((_ proc list seed ...)
  89. (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
  90. #'(let ((p proc))
  91. (let lp ((l list) (s seed) ...)
  92. (match l
  93. (() (values s ...))
  94. ((elt . l)
  95. (call-with-values (lambda () (p elt s ...))
  96. (lambda (s ...) (lp l s ...))))))))))))
  97. ;; A relocation records a reference to a symbol. When the symbol is
  98. ;; resolved to an address, the reloc location will be updated to point
  99. ;; to the address.
  100. ;;
  101. ;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
  102. ;; Rel32/1 and Rel32/1 are relative signed offsets, in 8-bit or 32-bit
  103. ;; units, respectively. Either can have an arbitrary addend as well.
  104. ;;
  105. (define-record-type <linker-reloc>
  106. (make-linker-reloc type loc addend symbol)
  107. linker-reloc?
  108. (type linker-reloc-type) ;; rel32/1, rel32/4, abs32/1, abs64/1
  109. (loc linker-reloc-loc)
  110. (addend linker-reloc-addend)
  111. (symbol linker-reloc-symbol))
  112. ;; A symbol is an association between a name and an address. The
  113. ;; address is always in regard to some particular address space. When
  114. ;; objects come into the linker, their symbols live in the object
  115. ;; address space. When the objects are allocated into ELF segments, the
  116. ;; symbols will be relocated into memory address space, corresponding to
  117. ;; the position the ELF will be loaded at.
  118. ;;
  119. (define-record-type <linker-symbol>
  120. (make-linker-symbol name address)
  121. linker-symbol?
  122. (name linker-symbol-name)
  123. (address linker-symbol-address))
  124. (define-record-type <linker-object>
  125. (%make-linker-object section bv relocs symbols)
  126. linker-object?
  127. (section linker-object-section)
  128. (bv linker-object-bv)
  129. (relocs linker-object-relocs)
  130. (symbols linker-object-symbols))
  131. (define (make-linker-object section bv relocs symbols)
  132. "Create a linker object with the @code{<elf-section>} header
  133. @var{section}, bytevector contents @var{bv}, list of linker relocations
  134. @var{relocs}, and list of linker symbols @var{symbols}."
  135. (%make-linker-object section bv relocs
  136. ;; Hide a symbol to the beginning of the section
  137. ;; in the symbols.
  138. (cons (make-linker-symbol (gensym "*section*") 0)
  139. symbols)))
  140. (define (linker-object-section-symbol object)
  141. "Return the linker symbol corresponding to the start of this section."
  142. (car (linker-object-symbols object)))
  143. (define (linker-object-symbols* object)
  144. "Return the linker symbols defined by the user for this this section."
  145. (cdr (linker-object-symbols object)))
  146. (define-record-type <string-table>
  147. (%make-string-table strings linked?)
  148. string-table?
  149. (strings string-table-strings set-string-table-strings!)
  150. (linked? string-table-linked? set-string-table-linked?!))
  151. (define (make-string-table)
  152. "Return a string table with one entry: the empty string."
  153. (%make-string-table '(("" 0 #vu8())) #f))
  154. (define (string-table-length strings)
  155. "Return the number of bytes needed for the @var{strings}."
  156. (match strings
  157. (((str pos bytes) . _)
  158. ;; The + 1 is for the trailing NUL byte.
  159. (+ pos (bytevector-length bytes) 1))))
  160. (define (string-table-intern! table str)
  161. "Ensure that @var{str} is present in the string table @var{table}.
  162. Returns the byte index of the string in that table."
  163. (match table
  164. (($ <string-table> strings linked?)
  165. (match (assoc str strings)
  166. ((_ pos _) pos)
  167. (#f
  168. (let ((next (string-table-length strings)))
  169. (when linked?
  170. (error "string table already linked, can't intern" table str))
  171. (set-string-table-strings! table
  172. (cons (list str next (string->utf8 str))
  173. strings))
  174. next))))))
  175. (define (link-string-table! table)
  176. "Link the functional string table @var{table} into a sequence of
  177. bytes, suitable for use as the contents of an ELF string table section."
  178. (match table
  179. (($ <string-table> strings #f)
  180. (let ((out (make-bytevector (string-table-length strings) 0)))
  181. (for-each
  182. (match-lambda
  183. ((_ pos bytes)
  184. (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
  185. strings)
  186. (set-string-table-linked?! table #t)
  187. out))))
  188. (define (segment-kind section)
  189. "Return the type of segment needed to store @var{section}, as a pair.
  190. The car is the @code{PT_} segment type, or @code{#f} if the section
  191. doesn't need to be present in a loadable segment. The cdr is a bitfield
  192. of associated @code{PF_} permissions."
  193. (let ((flags (elf-section-flags section)))
  194. ;; Sections without SHF_ALLOC don't go in segments.
  195. (cons (if (zero? flags) #f PT_LOAD)
  196. (logior (if (logtest SHF_ALLOC flags) PF_R 0)
  197. (if (logtest SHF_EXECINSTR flags) PF_X 0)
  198. (if (logtest SHF_WRITE flags) PF_W 0)))))
  199. (define (count-segments objects)
  200. "Return the total number of segments needed to represent the linker
  201. objects in @var{objects}, including the segment needed for the ELF
  202. header and segment table."
  203. (define (adjoin x xs)
  204. (if (member x xs) xs (cons x xs)))
  205. (length
  206. (fold-values (lambda (object kinds)
  207. (let ((kind (segment-kind (linker-object-section object))))
  208. (if (= (elf-section-type (linker-object-section object))
  209. SHT_DYNAMIC)
  210. ;; The dynamic section is part of a loadable
  211. ;; segment, and also gets the additional
  212. ;; PT_DYNAMIC segment header.
  213. (cons (cons PT_DYNAMIC (cdr kind))
  214. (adjoin kind kinds))
  215. (if (car kind) (adjoin kind kinds) kinds))))
  216. objects
  217. ;; We know there will be at least one segment,
  218. ;; containing at least the header and segment table.
  219. (list (cons PT_LOAD PF_R)))))
  220. (define (group-by-cars ls)
  221. (let lp ((ls ls) (k #f) (group #f) (out '()))
  222. (match ls
  223. (()
  224. (reverse!
  225. (if group
  226. (cons (cons k (reverse! group)) out)
  227. out)))
  228. (((k* . v) . ls)
  229. (if (and group (equal? k k*))
  230. (lp ls k (cons v group) out)
  231. (lp ls k* (list v)
  232. (if group
  233. (cons (cons k (reverse! group)) out)
  234. out)))))))
  235. (define (collate-objects-into-segments objects)
  236. "Given the list of linker objects @var{objects}, group them into
  237. contiguous ELF segments of the same type and flags. The result is an
  238. alist that maps segment types to lists of linker objects. See
  239. @code{segment-type} for a description of segment types. Within a
  240. segment, the order of the linker objects is preserved."
  241. (group-by-cars
  242. (stable-sort!
  243. (map (lambda (o)
  244. (cons (segment-kind (linker-object-section o)) o))
  245. objects)
  246. (lambda (x y)
  247. (let* ((x-kind (car x)) (y-kind (car y))
  248. (x-type (car x-kind)) (y-type (car y-kind))
  249. (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
  250. (x-section (linker-object-section (cdr x)))
  251. (y-section (linker-object-section (cdr y))))
  252. (cond
  253. ((not (equal? x-kind y-kind))
  254. (cond
  255. ((and x-type y-type)
  256. (cond
  257. ((not (equal? x-flags y-flags))
  258. (< x-flags y-flags))
  259. (else
  260. (< x-type y-type))))
  261. (else
  262. (not y-type))))
  263. ((not (equal? (elf-section-type x-section)
  264. (elf-section-type y-section)))
  265. (cond
  266. ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
  267. ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
  268. (else (< (elf-section-type x-section)
  269. (elf-section-type y-section)))))
  270. (else
  271. ;; Leave them in the initial order. This allows us to ensure
  272. ;; that the ELF header is written first.
  273. #f)))))))
  274. (define (align address alignment)
  275. (if (zero? alignment)
  276. address
  277. (+ address
  278. (modulo (- alignment (modulo address alignment)) alignment))))
  279. (define (relocate-section-header sec offset)
  280. "Return a new section header, just like @var{sec} but with its
  281. @code{offset} (and @code{addr} if it is loadable) set to @var{offset}."
  282. (make-elf-section #:index (elf-section-index sec)
  283. #:name (elf-section-name sec)
  284. #:type (elf-section-type sec)
  285. #:flags (elf-section-flags sec)
  286. #:addr (if (zero? (logand SHF_ALLOC
  287. (elf-section-flags sec)))
  288. 0
  289. offset)
  290. #:offset offset
  291. #:size (elf-section-size sec)
  292. #:link (elf-section-link sec)
  293. #:info (elf-section-info sec)
  294. #:addralign (elf-section-addralign sec)
  295. #:entsize (elf-section-entsize sec)))
  296. (define *page-size* 4096)
  297. (define (add-symbols symbols offset symtab)
  298. "Add @var{symbols} to the symbol table @var{symtab}, relocating them
  299. from object address space to memory address space. Returns a new symbol
  300. table."
  301. (fold-values
  302. (lambda (symbol symtab)
  303. (let ((name (linker-symbol-name symbol))
  304. (addr (linker-symbol-address symbol)))
  305. (when (vhash-assq name symtab)
  306. (error "duplicate symbol" name))
  307. (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
  308. symbols
  309. symtab))
  310. (define (allocate-segment write-segment-header!
  311. phidx type flags objects addr symtab alignment)
  312. "Given a list of linker objects that should go in a segment, the type
  313. and flags that the segment should have, and the address at which the
  314. segment should start, compute the positions that each object should have
  315. in the segment.
  316. Returns three values: the address of the next byte after the segment, a
  317. list of relocated objects, and the symbol table. The symbol table is
  318. the same as @var{symtab}, augmented with the symbols defined in
  319. @var{objects}, relocated to their positions in the image.
  320. In what is something of a quirky interface, this routine also patches up
  321. the segment table using @code{write-segment-header!}."
  322. (let* ((alignment (fold-values (lambda (o alignment)
  323. (lcm (elf-section-addralign
  324. (linker-object-section o))
  325. alignment))
  326. objects
  327. alignment))
  328. (addr (align addr alignment)))
  329. (receive (objects endaddr symtab)
  330. (fold-values
  331. (lambda (o out addr symtab)
  332. (let* ((section (linker-object-section o))
  333. (addr (align addr (elf-section-addralign section))))
  334. (values
  335. (cons (make-linker-object
  336. (relocate-section-header section addr)
  337. (linker-object-bv o)
  338. (linker-object-relocs o)
  339. (linker-object-symbols o))
  340. out)
  341. (+ addr (elf-section-size section))
  342. (add-symbols (linker-object-symbols o) addr symtab))))
  343. objects
  344. '() addr symtab)
  345. (when type
  346. (write-segment-header!
  347. (make-elf-segment #:index phidx #:type type
  348. #:offset addr #:vaddr addr #:paddr addr
  349. #:filesz (- endaddr addr) #:memsz (- endaddr addr)
  350. #:flags flags #:align alignment)))
  351. (values endaddr
  352. (reverse objects)
  353. symtab))))
  354. (define (process-reloc reloc bv section-offset symtab endianness)
  355. "Process a relocation. Given that a section containing @var{reloc}
  356. was just written into the image @var{bv} at offset @var{section-offset},
  357. fix it up so that its reference points to the correct position of its
  358. symbol, as present in @var{symtab}."
  359. (match (vhash-assq (linker-reloc-symbol reloc) symtab)
  360. (#f
  361. (error "Undefined symbol" (linker-reloc-symbol reloc)))
  362. ((name . symbol)
  363. ;; The reloc was written at LOC bytes after SECTION-OFFSET.
  364. (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
  365. (target (linker-symbol-address symbol)))
  366. (case (linker-reloc-type reloc)
  367. ((rel32/4)
  368. (let ((diff (+ (- target offset) (linker-reloc-addend reloc))))
  369. (unless (zero? (modulo diff 4))
  370. (error "Bad offset" reloc symbol offset))
  371. (bytevector-s32-set! bv offset (/ diff 4) endianness)))
  372. ((rel32/1)
  373. (let ((diff (- target offset)))
  374. (bytevector-s32-set! bv offset
  375. (+ diff (linker-reloc-addend reloc))
  376. endianness)))
  377. ((abs32/1)
  378. (bytevector-u32-set! bv offset target endianness))
  379. ((abs64/1)
  380. (bytevector-u64-set! bv offset target endianness))
  381. (else
  382. (error "bad reloc type" reloc)))))))
  383. (define (write-linker-object bv o symtab endianness)
  384. "Write the bytevector for the section wrapped by the linker object
  385. @var{o} into the image @var{bv}. The section header in @var{o} should
  386. already be relocated its final position in the image. Any relocations
  387. in the section will be processed to point to the correct symbol
  388. locations, as given in @var{symtab}."
  389. (let* ((section (linker-object-section o))
  390. (offset (elf-section-offset section))
  391. (len (elf-section-size section))
  392. (bytes (linker-object-bv o))
  393. (relocs (linker-object-relocs o)))
  394. (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
  395. (unless (zero? (elf-section-addr section))
  396. (error "non-loadable section has non-zero addr" section))
  397. (unless (= offset (elf-section-addr section))
  398. (error "loadable section has offset != addr" section)))
  399. (if (not (= (elf-section-type section) SHT_NOBITS))
  400. (begin
  401. (if (not (= len (bytevector-length bytes)))
  402. (error "unexpected length" section bytes))
  403. (bytevector-copy! bytes 0 bv offset len)
  404. (for-each (lambda (reloc)
  405. (process-reloc reloc bv offset symtab endianness))
  406. relocs)))))
  407. (define (find-shstrndx objects)
  408. "Find the section name string table in @var{objects}, and return its
  409. section index."
  410. (or-map (lambda (object)
  411. (let* ((section (linker-object-section object))
  412. (bv (linker-object-bv object))
  413. (name (elf-section-name section)))
  414. (and (= (elf-section-type section) SHT_STRTAB)
  415. (equal? (false-if-exception (string-table-ref bv name))
  416. ".shstrtab")
  417. (elf-section-index section))))
  418. objects))
  419. (define (add-elf-objects objects endianness word-size abi type machine-type)
  420. "Given the list of linker objects supplied by the user, add linker
  421. objects corresponding to parts of the ELF file: the null object, the ELF
  422. header, and the section table.
  423. Both of these internal objects include relocs, allowing their
  424. inter-object references to be patched up when the final image allocation
  425. is known. There is special support for patching up the segment table,
  426. however. Because the segment table needs to know the segment sizes,
  427. which is the difference between two symbols in image space, and there is
  428. no reloc kind that is the difference between two symbols, we make a hack
  429. and return a closure that patches up segment table entries. It seems to
  430. work.
  431. Returns two values: the procedure to patch the segment table, and the
  432. list of objects, augmented with objects for the special ELF sections."
  433. (define phoff (elf-header-len word-size))
  434. (define phentsize (elf-program-header-len word-size))
  435. (define shentsize (elf-section-header-len word-size))
  436. (define shnum (+ (length objects) 3))
  437. (define reloc-kind
  438. (case word-size
  439. ((4) 'abs32/1)
  440. ((8) 'abs64/1)
  441. (else (error "bad word size" word-size))))
  442. ;; ELF requires that the first entry in the section table be of type
  443. ;; SHT_NULL.
  444. ;;
  445. (define (make-null-section)
  446. (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
  447. #:flags 0 #:addralign 0)
  448. #vu8() '() '()))
  449. ;; The ELF header and the segment table.
  450. ;;
  451. (define (make-header phnum index shoff-label)
  452. (let* ((header (make-elf #:byte-order endianness #:word-size word-size
  453. #:abi abi #:type type #:machine-type machine-type
  454. #:phoff phoff #:phnum phnum #:phentsize phentsize
  455. #:shoff 0 #:shnum shnum #:shentsize shentsize
  456. #:shstrndx (or (find-shstrndx objects) SHN_UNDEF)))
  457. (shoff-reloc (make-linker-reloc reloc-kind
  458. (elf-header-shoff-offset word-size)
  459. 0
  460. shoff-label))
  461. (size (+ phoff (* phnum phentsize)))
  462. (bv (make-bytevector size 0)))
  463. (write-elf-header bv header)
  464. ;; Leave the segment table uninitialized; it will be filled in
  465. ;; later by calls to the write-segment-header! closure.
  466. (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
  467. #:flags SHF_ALLOC #:size size)
  468. bv
  469. (list shoff-reloc)
  470. '())))
  471. ;; The section table.
  472. ;;
  473. (define (make-footer objects shoff-label)
  474. (let* ((size (* shentsize shnum))
  475. (bv (make-bytevector size 0))
  476. (section-table (make-elf-section #:index (length objects)
  477. #:type SHT_PROGBITS
  478. #:flags 0
  479. #:size size)))
  480. (define (write-and-reloc section-label section relocs)
  481. (let ((offset (* shentsize (elf-section-index section))))
  482. (write-elf-section-header bv offset endianness word-size section)
  483. (if (= (elf-section-type section) SHT_NULL)
  484. relocs
  485. (let ((relocs
  486. (cons (make-linker-reloc
  487. reloc-kind
  488. (+ offset
  489. (elf-section-header-offset-offset word-size))
  490. 0
  491. section-label)
  492. relocs)))
  493. (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
  494. relocs
  495. (cons (make-linker-reloc
  496. reloc-kind
  497. (+ offset
  498. (elf-section-header-addr-offset word-size))
  499. 0
  500. section-label)
  501. relocs))))))
  502. (let ((relocs (fold-values
  503. (lambda (object relocs)
  504. (write-and-reloc
  505. (linker-symbol-name
  506. (linker-object-section-symbol object))
  507. (linker-object-section object)
  508. relocs))
  509. objects
  510. (write-and-reloc shoff-label section-table '()))))
  511. (%make-linker-object section-table bv relocs
  512. (list (make-linker-symbol shoff-label 0))))))
  513. (let* ((null-section (make-null-section))
  514. (objects (cons null-section objects))
  515. (shoff (gensym "*section-table*"))
  516. (header (make-header (count-segments objects) (length objects) shoff))
  517. (objects (cons header objects))
  518. (footer (make-footer objects shoff))
  519. (objects (cons footer objects)))
  520. ;; The header includes the segment table, which needs offsets and
  521. ;; sizes of the segments. Normally we would use relocs to rewrite
  522. ;; these values, but there is no reloc type that would allow us to
  523. ;; compute size. Such a reloc would need to take the difference
  524. ;; between two symbols, and it's probably a bad idea architecturally
  525. ;; to create one.
  526. ;;
  527. ;; So instead we return a closure to patch up the segment table.
  528. ;; Normally we'd shy away from such destructive interfaces, but it's
  529. ;; OK as we create the header section ourselves.
  530. ;;
  531. (define (write-segment-header! segment)
  532. (let ((bv (linker-object-bv header))
  533. (offset (+ phoff (* (elf-segment-index segment) phentsize))))
  534. (write-elf-program-header bv offset endianness word-size segment)))
  535. (values write-segment-header! objects)))
  536. (define (record-special-segments write-segment-header! phidx all-objects)
  537. (let lp ((phidx phidx) (objects all-objects))
  538. (match objects
  539. (() #t)
  540. ((object . objects)
  541. (let ((section (linker-object-section object)))
  542. (cond
  543. ((eqv? (elf-section-type section) SHT_DYNAMIC)
  544. (let ((addr (elf-section-offset section))
  545. (size (elf-section-size section))
  546. (align (elf-section-addralign section))
  547. (flags (cdr (segment-kind section))))
  548. (write-segment-header!
  549. (make-elf-segment #:index phidx #:type PT_DYNAMIC
  550. #:offset addr #:vaddr addr #:paddr addr
  551. #:filesz size #:memsz size
  552. #:flags flags #:align align))
  553. (lp (1+ phidx) objects)))
  554. (else
  555. (lp phidx objects))))))))
  556. (define (allocate-elf objects page-aligned? endianness word-size
  557. abi type machine-type)
  558. "Lay out @var{objects} into an ELF image, computing the size of the
  559. file, the positions of the objects, and the global symbol table.
  560. If @var{page-aligned?} is true, read-only and writable data are
  561. separated so that only those writable parts of the image need be mapped
  562. with writable permissions. This makes the resulting image larger. It
  563. is more suitable to situations where you would write a file out to disk
  564. and read it in with mmap. Otherwise if @var{page-aligned?} is false,
  565. sections default to 8-byte alignment.
  566. Returns three values: the total image size, a list of objects with
  567. relocated headers, and the global symbol table."
  568. (receive (write-segment-header! objects)
  569. (add-elf-objects objects endianness word-size abi type machine-type)
  570. (let lp ((seglists (collate-objects-into-segments objects))
  571. (objects '())
  572. (phidx 0)
  573. (addr 0)
  574. (symtab vlist-null)
  575. (prev-flags 0))
  576. (match seglists
  577. ((((type . flags) objs-in ...) seglists ...)
  578. (receive (addr objs-out symtab)
  579. (allocate-segment
  580. write-segment-header!
  581. phidx type flags objs-in addr symtab
  582. (if (and page-aligned?
  583. (not (= flags prev-flags))
  584. ;; Allow sections that are not in
  585. ;; loadable segments to share pages
  586. ;; with PF_R segments.
  587. (not (and (not type) (= PF_R prev-flags))))
  588. *page-size*
  589. 8))
  590. (lp seglists
  591. (fold-values cons objs-out objects)
  592. (if type (1+ phidx) phidx)
  593. addr
  594. symtab
  595. flags)))
  596. (()
  597. (record-special-segments write-segment-header! phidx objects)
  598. (values addr
  599. (reverse objects)
  600. symtab))))))
  601. (define (check-section-numbers objects)
  602. "Verify that taken as a whole, that all objects have distinct,
  603. contiguous section numbers, starting from 1. (Section 0 is the null
  604. section.)"
  605. (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
  606. (sections (make-vector nsections #f)))
  607. (for-each (lambda (object)
  608. (let ((n (elf-section-index (linker-object-section object))))
  609. (cond
  610. ((< n 1)
  611. (error "Invalid section number" object))
  612. ((>= n nsections)
  613. (error "Invalid section number" object))
  614. ((vector-ref sections n)
  615. (error "Duplicate section" (vector-ref sections n) object))
  616. (else
  617. (vector-set! sections n object)))))
  618. objects)))
  619. ;; Given a list of linker objects, collate the objects into segments,
  620. ;; allocate the segments, allocate the ELF bytevector, and write the
  621. ;; segments into the bytevector, relocating as we go.
  622. ;;
  623. (define* (link-elf objects #:key
  624. (page-aligned? #t)
  625. (endianness (target-endianness))
  626. (word-size (target-word-size))
  627. (abi ELFOSABI_STANDALONE)
  628. (type ET_DYN)
  629. (machine-type EM_NONE))
  630. "Create an ELF image from the linker objects, @var{objects}.
  631. If @var{page-aligned?} is true, read-only and writable data are
  632. separated so that only those writable parts of the image need be mapped
  633. with writable permissions. This is suitable for situations where you
  634. would write a file out to disk and read it in with @code{mmap}.
  635. Otherwise if @var{page-aligned?} is false, sections default to 8-byte
  636. alignment.
  637. Returns a bytevector."
  638. (check-section-numbers objects)
  639. (receive (size objects symtab)
  640. (allocate-elf objects page-aligned? endianness word-size
  641. abi type machine-type)
  642. (let ((bv (make-bytevector size 0)))
  643. (for-each
  644. (lambda (object)
  645. (write-linker-object bv object symtab endianness))
  646. objects)
  647. bv)))