1 ;;; Guile RTL assembler
3 ;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Lesser General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 3 of the License, or (at your option) any later version.
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Lesser General Public License for more details.
15 ;;; You should have received a copy of the GNU Lesser General Public
16 ;;; License along with this library; if not, write to the Free Software
17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; This module implements an assembler that creates an ELF image from
22 ;;; RTL assembly and macro-assembly. The input can be given in
23 ;;; s-expression form, like ((OP ARG ...) ...). Internally there is a
24 ;;; procedural interface, the emit-OP procedures, but that is not
25 ;;; currently exported.
27 ;;; "Primitive instructions" correspond to RTL VM operations.
28 ;;; Assemblers for primitive instructions are generated programmatically
29 ;;; from (rtl-instruction-list), which itself is derived from the VM
30 ;;; sources. There are also "macro-instructions" like "label" or
31 ;;; "load-constant" that expand to 0 or more primitive instructions.
33 ;;; The assembler also handles some higher-level tasks, like creating
34 ;;; the symbol table, other metadata sections, creating a constant table
35 ;;; for the whole compilation unit, and writing the dynamic section of
36 ;;; the ELF file along with the appropriate initialization routines.
38 ;;; Most compilers will want to use the trio of make-assembler,
39 ;;; emit-text, and link-assembly. That will result in the creation of
40 ;;; an ELF image as a bytevector, which can then be loaded using
41 ;;; load-thunk-from-memory, or written to disk as a .go file.
45 (define-module (system vm assembler)
46 #:use-module (system base target)
47 #:use-module (system vm instruction)
48 #:use-module (system vm elf)
49 #:use-module (system vm linker)
50 #:use-module (system vm objcode)
51 #:use-module (rnrs bytevectors)
52 #:use-module (ice-9 vlist)
53 #:use-module (ice-9 match)
54 #:use-module (srfi srfi-1)
55 #:use-module (srfi srfi-4)
56 #:use-module (srfi srfi-9)
57 #:use-module (srfi srfi-11)
58 #:export (make-assembler
66 ;;; RTL code consists of 32-bit units, often subdivided in some way.
67 ;;; These helpers create one 32-bit unit from multiple components.
69 (define-syntax-rule (pack-u8-u24 x y)
72 (define-syntax-rule (pack-u8-s24 x y)
78 (else (error "out of range" y)))
81 (define-syntax-rule (pack-u1-u7-u24 x y z)
82 (logior x (ash y 1) (ash z 8)))
84 (define-syntax-rule (pack-u8-u12-u12 x y z)
85 (logior x (ash y 8) (ash z 20)))
87 (define-syntax-rule (pack-u8-u8-u16 x y z)
88 (logior x (ash y 8) (ash z 16)))
90 (define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
91 (logior x (ash y 8) (ash z 16) (ash w 24)))
93 (define-syntax pack-flags
95 ;; Add clauses as needed.
96 ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
97 (if f2 (ash 2 0) 0)))))
99 ;;; Helpers to read and write 32-bit units in a buffer.
101 (define-syntax-rule (u32-ref buf n)
102 (bytevector-u32-native-ref buf (* n 4)))
104 (define-syntax-rule (u32-set! buf n val)
105 (bytevector-u32-native-set! buf (* n 4) val))
107 (define-syntax-rule (s32-ref buf n)
108 (bytevector-s32-native-ref buf (* n 4)))
110 (define-syntax-rule (s32-set! buf n val)
111 (bytevector-s32-native-set! buf (* n 4) val))
116 ;;; A <meta> entry collects metadata for one procedure. Procedures are
117 ;;; written as contiguous ranges of RTL code.
119 (define-syntax-rule (assert-match arg pattern kind)
121 (unless (match x (pattern #t) (_ #f))
122 (error (string-append "expected " kind) x))))
124 (define-record-type <meta>
125 (%make-meta label properties low-pc high-pc arities)
128 (properties meta-properties set-meta-properties!)
130 (high-pc meta-high-pc set-meta-high-pc!)
131 (arities meta-arities set-meta-arities!))
133 (define (make-meta label properties low-pc)
134 (assert-match label (? symbol?) "symbol")
135 (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
136 (%make-meta label properties low-pc #f '()))
138 (define (meta-name meta)
139 (assq-ref (meta-properties meta) 'name))
141 ;; Metadata for one <lambda-case>.
142 (define-record-type <arity>
143 (make-arity req opt rest kw-indices allow-other-keys?
149 (kw-indices arity-kw-indices)
150 (allow-other-keys? arity-allow-other-keys?)
151 (low-pc arity-low-pc)
152 (high-pc arity-high-pc set-arity-high-pc!))
154 (define-syntax *block-size* (identifier-syntax 32))
156 ;;; An assembler collects all of the words emitted during assembly, and
157 ;;; also maintains ancillary information such as the constant table, a
158 ;;; relocation list, and so on.
160 ;;; RTL code consists of 32-bit units. We emit RTL code using native
161 ;;; endianness. If we're targeting a foreign endianness, we byte-swap
162 ;;; the bytevector as a whole instead of conditionalizing each access.
164 (define-record-type <asm>
165 (make-asm cur idx start prev written
169 shstrtab next-section-number
173 ;; We write RTL code into what is logically a growable vector,
174 ;; implemented as a list of blocks. asm-cur is the current block, and
175 ;; asm-idx is the current index into that block, in 32-bit units.
177 (cur asm-cur set-asm-cur!)
178 (idx asm-idx set-asm-idx!)
180 ;; asm-start is an absolute position, indicating the offset of the
181 ;; beginning of an instruction (in u32 units). It is updated after
182 ;; writing all the words for one primitive instruction. It models the
183 ;; position of the instruction pointer during execution, given that
184 ;; the RTL VM updates the IP only at the end of executing the
185 ;; instruction, and is thus useful for computing offsets between two
186 ;; points in a program.
188 (start asm-start set-asm-start!)
190 ;; The list of previously written blocks.
192 (prev asm-prev set-asm-prev!)
194 ;; The number of u32 words written in asm-prev, which is the same as
195 ;; the offset of the current block.
197 (written asm-written set-asm-written!)
199 ;; An alist of symbol -> position pairs, indicating the labels defined
200 ;; in this compilation unit.
202 (labels asm-labels set-asm-labels!)
204 ;; A list of relocations needed by the program text. We use an
205 ;; internal representation for relocations, and handle textualn
206 ;; relative relocations in the assembler. Other kinds of relocations
207 ;; are later reified as linker relocations and resolved by the linker.
209 (relocs asm-relocs set-asm-relocs!)
211 ;; Target information.
213 (word-size asm-word-size)
214 (endianness asm-endianness)
216 ;; The constant table, as a vhash of object -> label. All constants
217 ;; get de-duplicated and written into separate sections -- either the
218 ;; .rodata section, for read-only data, or .data, for constants that
219 ;; need initialization at load-time (like symbols). Constants can
220 ;; depend on other constants (e.g. a symbol depending on a stringbuf),
221 ;; so order in this table is important.
223 (constants asm-constants set-asm-constants!)
225 ;; A list of RTL instructions needed to initialize the constants.
226 ;; Will run in a thunk with 2 local variables.
228 (inits asm-inits set-asm-inits!)
230 ;; The shstrtab, for section names.
232 (shstrtab asm-shstrtab set-asm-shstrtab!)
234 ;; The section number for the next section to be written.
236 (next-section-number asm-next-section-number set-asm-next-section-number!)
238 ;; A list of <meta>, corresponding to procedure metadata.
240 (meta asm-meta set-asm-meta!))
242 (define-inlinable (fresh-block)
243 (make-u32vector *block-size*))
245 (define* (make-assembler #:key (word-size (target-word-size))
246 (endianness (target-endianness)))
247 "Create an assembler for a given target @var{word-size} and
248 @var{endianness}, falling back to appropriate values for the configured
250 (make-asm (fresh-block) 0 0 '() 0
254 (make-string-table) 1
257 (define (intern-section-name! asm string)
258 "Add a string to the section name table (shstrtab)."
259 (string-table-intern! (asm-shstrtab asm) string))
261 (define-inlinable (asm-pos asm)
262 "The offset of the next word to be written into the code buffer, in
264 (+ (asm-idx asm) (asm-written asm)))
266 (define (allocate-new-block asm)
267 "Close off the current block, and arrange for the next word to be
268 written to a fresh block."
269 (let ((new (fresh-block)))
270 (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm)))
271 (set-asm-written! asm (asm-pos asm))
272 (set-asm-cur! asm new)
273 (set-asm-idx! asm 0)))
275 (define-inlinable (emit asm u32)
276 "Emit one 32-bit word into the instruction stream. Assumes that there
277 is space for the word, and ensures that there is space for the next
279 (u32-set! (asm-cur asm) (asm-idx asm) u32)
280 (set-asm-idx! asm (1+ (asm-idx asm)))
281 (if (= (asm-idx asm) *block-size*)
282 (allocate-new-block asm)))
284 (define-inlinable (make-reloc type label base word)
285 "Make an internal relocation of type @var{type} referencing symbol
286 @var{label}, @var{word} words after position @var{start}. @var{type}
287 may be x8-s24, indicating a 24-bit relative label reference that can be
288 fixed up by the assembler, or s32, indicating a 32-bit relative
289 reference that needs to be fixed up by the linker."
290 (list type label base word))
292 (define-inlinable (reset-asm-start! asm)
293 "Reset the asm-start after writing the words for one instruction."
294 (set-asm-start! asm (asm-pos asm)))
296 (define (emit-exported-label asm label)
297 "Define a linker symbol associating @var{label} with the current
299 (set-asm-labels! asm (acons label (asm-start asm) (asm-labels asm))))
301 (define (record-label-reference asm label)
302 "Record an x8-s24 local label reference. This value will get patched
303 up later by the assembler."
304 (let* ((start (asm-start asm))
306 (reloc (make-reloc 'x8-s24 label start (- pos start))))
307 (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
309 (define* (record-far-label-reference asm label #:optional (offset 0))
310 "Record an s32 far label reference. This value will get patched up
311 later by the linker."
312 (let* ((start (- (asm-start asm) offset))
314 (reloc (make-reloc 's32 label start (- pos start))))
315 (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
321 ;;; Primitive assemblers are defined by expanding `assembler' for each
322 ;;; opcode in `(rtl-instruction-list)'.
325 (eval-when (expand compile load eval)
326 (define (id-append ctx a b)
327 (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
329 (define-syntax assembler
331 (define-syntax op-case
334 ((_ asm name ((type arg ...) code ...) clause ...)
335 #`(if (eq? name 'type)
336 (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
339 (op-case asm name clause ...)))
341 #'(error "unmatched name" name)))))
343 (define (pack-first-word asm opcode type)
344 (with-syntax ((opcode opcode))
350 (emit asm (pack-u8-u24 opcode arg)))
352 (record-label-reference asm label)
355 (emit asm (pack-u8-u24 opcode (list rest)))
356 (for-each (lambda (x) (emit asm x)) rest))
358 (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
360 (emit asm (pack-u8-u12-u12 opcode a b)))
362 (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
364 (define (pack-tail-word asm type)
368 (emit asm (pack-u8-u24 a b)))
370 (record-label-reference asm label)
373 (emit asm (pack-u8-u24 a (length rest)))
374 (for-each (lambda (x) (emit asm x)) rest))
376 (emit asm (pack-u8-u8-u16 a b (object-address imm))))
378 (emit asm (pack-u8-u12-u12 a b c)))
379 ((U8_U8_U8_U8 a b c d)
380 (emit asm (pack-u8-u8-u8-u8 a b c d)))
384 (let ((val (object-address imm)))
385 (unless (zero? (ash val -32))
386 (error "FIXME: enable truncation of negative fixnums when cross-compiling"))
389 (unless (= (asm-word-size asm) 8)
390 (error "make-long-immediate unavailable for this target"))
391 (emit asm (ash (object-address imm) -32))
392 (emit asm (logand (object-address imm) (1- (ash 1 32)))))
395 (record-far-label-reference asm label)
398 (record-far-label-reference asm label)
401 (record-far-label-reference asm label)
404 (record-far-label-reference asm label
405 (* offset (/ (asm-word-size asm) 4)))
408 (emit asm (pack-u8-u24 0 a)))
410 (emit asm (pack-u8-u12-u12 0 a b)))
412 (emit asm (pack-u8-u24 0 (length rest)))
413 (for-each (lambda (x) (emit asm x)) rest))
415 (record-label-reference asm label)
418 (record-label-reference asm label)
419 (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
420 ((B1_U7_L24 a b label)
421 (record-label-reference asm label)
422 (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))))
425 ((_ name opcode word0 word* ...)
426 (with-syntax ((((formal0 ...)
428 (pack-first-word #'asm
429 (syntax->datum #'opcode)
430 (syntax->datum #'word0)))
433 (map (lambda (word) (pack-tail-word #'asm word))
434 (syntax->datum #'(word* ...)))))
435 #'(lambda (asm formal0 ... formal* ... ...)
436 (unless (asm? asm) (error "not an asm"))
439 (reset-asm-start! asm)))))))
441 (define assemblers (make-hash-table))
443 (define-syntax define-assembler
446 ((_ name opcode arg ...)
447 (with-syntax ((emit (id-append #'name #'emit- #'name)))
449 (let ((emit (assembler name opcode arg ...)))
450 (hashq-set! assemblers 'name emit)
453 (define-syntax visit-opcodes
456 ((visit-opcodes macro arg ...)
457 (with-syntax (((inst ...)
458 (map (lambda (x) (datum->syntax #'macro x))
459 (rtl-instruction-list))))
461 (macro arg ... . inst)
464 (visit-opcodes define-assembler)
466 (define (emit-text asm instructions)
467 "Assemble @var{instructions} using the assembler @var{asm}.
468 @var{instructions} is a sequence of RTL instructions, expressed as a
469 list of lists. This procedure can be called many times before calling
470 @code{link-assembly}."
471 (for-each (lambda (inst)
472 (apply (or (hashq-ref assemblers (car inst))
473 (error 'bad-instruction inst))
481 ;;; The constant table records a topologically sorted set of literal
482 ;;; constants used by a program. For example, a pair uses its car and
483 ;;; cdr, a string uses its stringbuf, etc.
485 ;;; Some things we want to add to the constant table are not actually
486 ;;; Scheme objects: for example, stringbufs, cache cells for toplevel
487 ;;; references, or cache cells for non-closure procedures. For these we
488 ;;; define special record types and add instances of those record types
492 (define-inlinable (immediate? x)
493 "Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise."
494 (not (zero? (logand (object-address x) 6))))
496 (define-record-type <stringbuf>
497 (make-stringbuf string)
499 (string stringbuf-string))
501 (define-record-type <static-procedure>
502 (make-static-procedure code)
504 (code static-procedure-code))
506 (define-record-type <cache-cell>
507 (make-cache-cell scope key)
509 (scope cache-cell-scope)
510 (key cache-cell-key))
512 (define (statically-allocatable? x)
513 "Return @code{#t} if a non-immediate constant can be allocated
514 statically, and @code{#f} if it would need some kind of runtime
516 (or (pair? x) (vector? x) (string? x) (stringbuf? x) (static-procedure? x)))
518 (define (intern-constant asm obj)
519 "Add an object to the constant table, and return a label that can be
520 used to reference it. If the object is already present in the constant
521 table, its existing label is used directly."
523 (intern-constant asm obj))
524 (define (field dst n obj)
525 (let ((src (recur obj)))
527 (list (if (statically-allocatable? obj)
528 `(make-non-immediate 0 ,src)
529 `(static-ref 0 ,src))
530 `(static-set! 0 ,dst ,n))
532 (define (intern obj label)
535 (append (field label 0 (car obj))
536 (field label 1 (cdr obj))))
538 (let lp ((i 0) (inits '()))
539 (if (< i (vector-length obj))
541 (append-reverse (field label (1+ i) (vector-ref obj i))
544 ((stringbuf? obj) '())
545 ((static-procedure? obj)
546 `((make-non-immediate 0 ,label)
547 (link-procedure! 0 ,(static-procedure-code obj))))
548 ((cache-cell? obj) '())
550 `((make-non-immediate 0 ,(recur (symbol->string obj)))
552 (static-set! 0 ,label 0)))
554 `((make-non-immediate 0 ,(recur (make-stringbuf obj)))
555 (static-set! 0 ,label 1)))
557 `((static-ref 0 ,(recur (keyword->symbol obj)))
558 (symbol->keyword 0 0)
559 (static-set! 0 ,label 0)))
561 `((make-non-immediate 0 ,(recur (number->string obj)))
563 (static-set! 0 ,label 0)))
565 (error "don't know how to intern" obj))))
567 ((immediate? obj) #f)
568 ((vhash-assoc obj (asm-constants asm)) => cdr)
570 ;; Note that calling intern may mutate asm-constants and
571 ;; asm-constant-inits.
572 (let* ((label (gensym "constant"))
573 (inits (intern obj label)))
574 (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
575 (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
578 (define (intern-non-immediate asm obj)
579 "Intern a non-immediate into the constant table, and return its
581 (when (immediate? obj)
582 (error "expected a non-immediate" obj))
583 (intern-constant asm obj))
585 (define (intern-cache-cell asm scope key)
586 "Intern a cache cell into the constant table, and return its label.
587 If there is already a cache cell with the given scope and key, it is
589 (intern-constant asm (make-cache-cell scope key)))
591 ;; Return the label of the cell that holds the module for a scope.
592 (define (intern-module-cache-cell asm scope)
593 "Intern a cache cell for a module, and return its label."
594 (intern-cache-cell asm scope #t))
600 ;;; Macro assemblers bridge the gap between primitive instructions and
601 ;;; some higher-level operations.
604 (define-syntax define-macro-assembler
607 ((_ (name arg ...) body body* ...)
608 (with-syntax ((emit (id-append #'name #'emit- #'name)))
610 (let ((emit (lambda (arg ...) body body* ...)))
611 (hashq-set! assemblers 'name emit)
614 (define-macro-assembler (load-constant asm dst obj)
617 (let ((bits (object-address obj)))
619 ((and (< dst 256) (zero? (ash bits -16)))
620 (emit-make-short-immediate asm dst obj))
621 ((zero? (ash bits -32))
622 (emit-make-long-immediate asm dst obj))
624 (emit-make-long-long-immediate asm dst obj)))))
625 ((statically-allocatable? obj)
626 (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
628 (emit-static-ref asm dst (intern-non-immediate asm obj)))))
630 (define-macro-assembler (load-static-procedure asm dst label)
631 (let ((loc (intern-constant asm (make-static-procedure label))))
632 (emit-make-non-immediate asm dst loc)))
634 (define-macro-assembler (begin-program asm label properties)
635 (emit-label asm label)
636 (let ((meta (make-meta label properties (asm-start asm))))
637 (set-asm-meta! asm (cons meta (asm-meta asm)))))
639 (define-macro-assembler (end-program asm)
640 (let ((meta (car (asm-meta asm))))
641 (set-meta-high-pc! meta (asm-start asm))
642 (set-meta-arities! meta (reverse (meta-arities meta)))))
644 (define-macro-assembler (begin-standard-arity asm req nlocals alternate)
645 (emit-begin-opt-arity asm req '() #f nlocals alternate))
647 (define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
648 (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
650 (define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
651 allow-other-keys? nlocals alternate)
652 (assert-match req ((? symbol?) ...) "list of symbols")
653 (assert-match opt ((? symbol?) ...) "list of symbols")
654 (assert-match rest (or #f (? symbol?)) "#f or symbol")
655 (assert-match kw-indices (((? symbol?) . (? integer?)) ...)
656 "alist of symbol -> integer")
657 (assert-match allow-other-keys? (? boolean?) "boolean")
658 (assert-match nlocals (? integer?) "integer")
659 (assert-match alternate (or #f (? symbol?)) "#f or symbol")
660 (let* ((meta (car (asm-meta asm)))
661 (arity (make-arity req opt rest kw-indices allow-other-keys?
665 (rest? (->bool rest)))
666 (set-meta-arities! meta (cons arity (meta-arities meta)))
668 ((or allow-other-keys? (pair? kw-indices))
669 (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
671 ((or rest? (pair? opt))
672 (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
674 (emit-standard-prelude asm nreq nlocals alternate)))))
676 (define-macro-assembler (end-arity asm)
677 (let ((arity (car (meta-arities (car (asm-meta asm))))))
678 (set-arity-high-pc! arity (asm-start asm))))
680 (define-macro-assembler (standard-prelude asm nreq nlocals alternate)
683 (emit-br-if-nargs-ne asm nreq alternate)
684 (emit-reserve-locals asm nlocals))
685 ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
686 (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
688 (emit-assert-nargs-ee asm nreq)
689 (emit-reserve-locals asm nlocals))))
691 (define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
693 (emit-br-if-nargs-lt asm nreq alternate)
694 (emit-assert-nargs-ge asm nreq))
697 (emit-bind-rest asm (+ nreq nopt)))
699 (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
701 (emit-assert-nargs-le asm (+ nreq nopt))))
702 (emit-reserve-locals asm nlocals))
704 (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
705 allow-other-keys? nlocals alternate)
707 (emit-br-if-nargs-lt asm nreq alternate)
708 (emit-assert-nargs-ge asm nreq))
709 (let ((ntotal (fold (lambda (kw ntotal)
711 (((? keyword?) . idx)
712 (max (1+ idx) ntotal))))
713 (+ nreq nopt) kw-indices)))
714 ;; FIXME: port 581f410f
715 (emit-bind-kwargs asm nreq
716 (pack-flags allow-other-keys? rest?)
720 (emit-reserve-locals asm nlocals)))
722 (define-macro-assembler (label asm sym)
723 (set-asm-labels! asm (acons sym (asm-start asm) (asm-labels asm))))
725 (define-macro-assembler (cache-current-module! asm tmp scope)
726 (let ((mod-label (intern-module-cache-cell asm scope)))
727 (emit-current-module asm tmp)
728 (emit-static-set! asm tmp mod-label 0)))
730 (define-macro-assembler (cached-toplevel-ref asm dst scope sym)
731 (let ((sym-label (intern-non-immediate asm sym))
732 (mod-label (intern-module-cache-cell asm scope))
733 (cell-label (intern-cache-cell asm scope sym)))
734 (emit-toplevel-ref asm dst cell-label mod-label sym-label)))
736 (define-macro-assembler (cached-toplevel-set! asm src scope sym)
737 (let ((sym-label (intern-non-immediate asm sym))
738 (mod-label (intern-module-cache-cell asm scope))
739 (cell-label (intern-cache-cell asm scope sym)))
740 (emit-toplevel-set! asm src cell-label mod-label sym-label)))
742 (define-macro-assembler (cached-module-ref asm dst module-name public? sym)
743 (let* ((sym-label (intern-non-immediate asm sym))
744 (key (cons public? module-name))
745 (mod-name-label (intern-constant asm key))
746 (cell-label (intern-cache-cell asm key sym)))
747 (emit-module-ref asm dst cell-label mod-name-label sym-label)))
749 (define-macro-assembler (cached-module-set! asm src module-name public? sym)
750 (let* ((sym-label (intern-non-immediate asm sym))
751 (key (cons public? module-name))
752 (mod-name-label (intern-non-immediate asm key))
753 (cell-label (intern-cache-cell asm key sym)))
754 (emit-module-set! asm src cell-label mod-name-label sym-label)))
760 ;;; Helper for linking objects.
763 (define (make-object asm name bv relocs labels . kwargs)
764 "Make a linker object. This helper handles interning the name in the
765 shstrtab, assigning the size, allocating a fresh index, and defining a
766 corresponding linker symbol for the start of the section."
767 (let ((name-idx (intern-section-name! asm (symbol->string name)))
768 (index (asm-next-section-number asm)))
769 (set-asm-next-section-number! asm (1+ index))
770 (make-linker-object (apply make-elf-section
773 #:size (bytevector-length bv)
776 (cons (make-linker-symbol name 0) labels))))
782 ;;; Linking the constant table. This code is somewhat intertwingled
783 ;;; with the intern-constant code above, as that procedure also
784 ;;; residualizes instructions to initialize constants at load time.
787 (define (write-immediate asm buf pos x)
788 (let ((val (object-address x))
789 (endianness (asm-endianness asm)))
790 (case (asm-word-size asm)
791 ((4) (bytevector-u32-set! buf pos val endianness))
792 ((8) (bytevector-u64-set! buf pos val endianness))
793 (else (error "bad word size" asm)))))
795 (define (emit-init-constants asm)
796 "If there is writable data that needs initialization at runtime, emit
797 a procedure to do that and return its label. Otherwise return
799 (let ((inits (asm-inits asm)))
800 (and (not (null? inits))
801 (let ((label (gensym "init-constants")))
803 `((begin-program ,label ())
804 (assert-nargs-ee/locals 0 1)
806 (load-constant 0 ,*unspecified*)
811 (define (link-data asm data name)
812 "Link the static data for a program into the @var{name} section (which
813 should be .data or .rodata), and return the resulting linker object.
814 @var{data} should be a vhash mapping objects to labels."
815 (define (align address alignment)
817 (modulo (- alignment (modulo address alignment)) alignment)))
819 (define tc7-vector 13)
820 (define tc7-narrow-stringbuf 39)
821 (define tc7-wide-stringbuf (+ 39 #x400))
822 (define tc7-ro-string (+ 21 #x200))
823 (define tc7-rtl-program 69)
825 (let ((word-size (asm-word-size asm))
826 (endianness (asm-endianness asm)))
827 (define (byte-length x)
830 (let ((x (stringbuf-string x)))
832 (case (string-bytes-per-char x)
833 ((1) (1+ (string-length x)))
834 ((4) (* (1+ (string-length x)) 4))
835 (else (error "bad string bytes per char" x))))))
836 ((static-procedure? x)
843 (* (1+ (vector-length x)) word-size))
847 (define (write-constant-reference buf pos x)
848 ;; The asm-inits will fix up any reference to a non-immediate.
849 (write-immediate asm buf pos (if (immediate? x) x #f)))
851 (define (write buf pos obj)
854 (let* ((x (stringbuf-string obj))
855 (len (string-length x))
856 (tag (if (= (string-bytes-per-char x) 1)
858 tc7-wide-stringbuf)))
861 (bytevector-u32-set! buf pos tag endianness)
862 (bytevector-u32-set! buf (+ pos 4) len endianness))
864 (bytevector-u64-set! buf pos tag endianness)
865 (bytevector-u64-set! buf (+ pos 8) len endianness))
867 (error "bad word size" asm)))
868 (let ((pos (+ pos (* word-size 2))))
869 (case (string-bytes-per-char x)
873 (let ((u8 (char->integer (string-ref x i))))
874 (bytevector-u8-set! buf (+ pos i) u8)
876 (bytevector-u8-set! buf (+ pos i) 0))))
880 (let ((u32 (char->integer (string-ref x i))))
881 (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
883 (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
884 (else (error "bad string bytes per char" x))))))
886 ((static-procedure? obj)
889 (bytevector-u32-set! buf pos tc7-rtl-program endianness)
890 (bytevector-u32-set! buf (+ pos 4) 0 endianness))
892 (bytevector-u64-set! buf pos tc7-rtl-program endianness)
893 (bytevector-u64-set! buf (+ pos 8) 0 endianness))
894 (else (error "bad word size"))))
897 (write-immediate asm buf pos #f))
900 (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
903 (bytevector-u32-set! buf pos tc7-ro-string endianness)
904 (write-immediate asm buf (+ pos 4) #f) ; stringbuf
905 (bytevector-u32-set! buf (+ pos 8) 0 endianness)
906 (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
908 (bytevector-u64-set! buf pos tc7-ro-string endianness)
909 (write-immediate asm buf (+ pos 8) #f) ; stringbuf
910 (bytevector-u64-set! buf (+ pos 16) 0 endianness)
911 (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
912 (else (error "bad word size")))))
915 (write-constant-reference buf pos (car obj))
916 (write-constant-reference buf (+ pos word-size) (cdr obj)))
919 (let* ((len (vector-length obj))
920 (tag (logior tc7-vector (ash len 8))))
922 ((4) (bytevector-u32-set! buf pos tag endianness))
923 ((8) (bytevector-u64-set! buf pos tag endianness))
924 (else (error "bad word size")))
926 (when (< i (vector-length obj))
927 (let ((pos (+ pos word-size (* i word-size)))
928 (elt (vector-ref obj i)))
929 (write-constant-reference buf pos elt)
933 (write-immediate asm buf pos #f))
936 (write-immediate asm buf pos #f))
939 (write-immediate asm buf pos #f))
942 (error "unrecognized object" obj))))
945 ((vlist-null? data) #f)
947 (let* ((byte-len (vhash-fold (lambda (k v len)
948 (+ (byte-length k) (align len 8)))
950 (buf (make-bytevector byte-len 0)))
951 (let lp ((i 0) (pos 0) (labels '()))
952 (if (< i (vlist-length data))
953 (let* ((pair (vlist-ref data i))
955 (obj-label (cdr pair)))
958 (align (+ (byte-length obj) pos) 8)
959 (cons (make-linker-symbol obj-label pos) labels)))
960 (make-object asm name buf '() labels))))))))
962 (define (link-constants asm)
963 "Link sections to hold constants needed by the program text emitted
966 Returns three values: an object for the .rodata section, an object for
967 the .data section, and a label for an initialization procedure. Any of
968 these may be @code{#f}."
969 (define (shareable? x)
973 (and (immediate? (car x)) (immediate? (cdr x))))
976 (or (= i (vector-length x))
977 (and (immediate? (vector-ref x i))
980 (let* ((constants (asm-constants asm))
981 (len (vlist-length constants)))
986 (values (link-data asm ro '.rodata)
987 (link-data asm rw '.data)
988 (emit-init-constants asm))
989 (let ((pair (vlist-ref constants i)))
990 (if (shareable? (car pair))
991 (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
992 (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
997 ;;; Linking program text.
1000 (define (process-relocs buf relocs labels)
1001 "Patch up internal x8-s24 relocations, and any s32 relocations that
1002 reference symbols in the text section. Return a list of linker
1003 relocations for references to symbols defined outside the text section."
1005 (lambda (reloc tail)
1007 ((type label base word)
1008 (let ((abs (assq-ref labels label))
1009 (dst (+ base word)))
1013 (let ((rel (- abs base)))
1014 (s32-set! buf dst rel)
1016 (cons (make-linker-reloc 'rel32/4 (* dst 4) word label)
1020 (error "unbound near relocation" reloc))
1021 (let ((rel (- abs base))
1022 (u32 (u32-ref buf dst)))
1023 (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel))
1025 (else (error "bad relocation kind" reloc)))))))
1029 (define (process-labels labels)
1030 "Define linker symbols for the label-offset pairs in @var{labels}.
1031 The offsets are expected to be expressed in words."
1033 (make-linker-symbol (car pair) (* (cdr pair) 4)))
1036 (define (swap-bytes! buf)
1037 "Patch up the text buffer @var{buf}, swapping the endianness of each
1039 (unless (zero? (modulo (bytevector-length buf) 4))
1040 (error "unexpected length"))
1041 (let ((byte-len (bytevector-length buf)))
1043 (unless (= pos byte-len)
1044 (bytevector-u32-set!
1046 (bytevector-u32-ref buf pos (endianness big))
1047 (endianness little))
1050 (define (link-text-object asm)
1051 "Link the .rtl-text section, swapping the endianness of the bytes if
1053 (let ((buf (make-u32vector (asm-pos asm))))
1054 (let lp ((pos 0) (prev (reverse (asm-prev asm))))
1056 (let ((byte-size (* (asm-idx asm) 4)))
1057 (bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
1058 (unless (eq? (asm-endianness asm) (native-endianness))
1060 (make-object asm '.rtl-text
1062 (process-relocs buf (asm-relocs asm)
1064 (process-labels (asm-labels asm))))
1065 (let ((len (* *block-size* 4)))
1066 (bytevector-copy! (car prev) 0 buf pos len)
1067 (lp (+ pos len) (cdr prev)))))))
1073 ;;; Linking other sections of the ELF file, like the dynamic segment,
1074 ;;; the symbol table, etc.
1077 (define (link-dynamic-section asm text rw rw-init)
1078 "Link the dynamic section for an ELF image with RTL text, given the
1079 writable data section @var{rw} needing fixup from the procedure with
1080 label @var{rw-init}. @var{rw-init} may be false. If @var{rw} is true,
1081 it will be added to the GC roots at runtime."
1082 (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
1083 (let* ((endianness (asm-endianness asm))
1084 (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
1087 (%set-uword! bv (* i word-size) uword endianness)))
1091 (set! relocs (cons (make-linker-reloc 'reloc-type
1092 (* i word-size) 0 label)
1094 (%set-uword! bv (* i word-size) 0 endianness))))
1095 (set-uword! 0 DT_GUILE_RTL_VERSION)
1096 (set-uword! 1 #x02020000)
1097 (set-uword! 2 DT_GUILE_ENTRY)
1098 (set-label! 3 '.rtl-text)
1102 (set-uword! 4 DT_GUILE_GC_ROOT)
1103 (set-label! 5 '.data)
1104 (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
1105 (set-uword! 7 (bytevector-length (linker-object-bv rw)))
1108 (set-uword! 8 DT_INIT) ; constants
1109 (set-label! 9 rw-init)
1110 (set-uword! 10 DT_NULL)
1113 (set-uword! 8 DT_NULL)
1116 (set-uword! 4 DT_NULL)
1118 (make-object asm '.dynamic bv relocs '()
1119 #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
1120 (case (asm-word-size asm)
1121 ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
1122 ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
1123 (else (error "bad word size" asm))))
1125 (define (link-shstrtab asm)
1126 "Link the string table for the section headers."
1127 (intern-section-name! asm ".shstrtab")
1128 (make-object asm '.shstrtab
1129 (link-string-table! (asm-shstrtab asm))
1131 #:type SHT_STRTAB #:flags 0))
1133 (define (link-symtab text-section asm)
1134 (let* ((endianness (asm-endianness asm))
1135 (word-size (asm-word-size asm))
1136 (size (elf-symbol-len word-size))
1137 (meta (reverse (asm-meta asm)))
1139 (strtab (make-string-table))
1140 (bv (make-bytevector (* n size) 0)))
1141 (define (intern-string! name)
1142 (string-table-intern! strtab (if name (symbol->string name) "")))
1145 (let ((name (intern-string! (meta-name meta))))
1146 (write-elf-symbol bv (* n size) endianness word-size
1149 ;; Symbol value and size are measured in
1151 #:value (* 4 (meta-low-pc meta))
1152 #:size (* 4 (- (meta-high-pc meta)
1153 (meta-low-pc meta)))
1155 #:visibility STV_HIDDEN
1156 #:shndx (elf-section-index text-section)))))
1158 (let ((strtab (make-object asm '.strtab
1159 (link-string-table! strtab)
1161 #:type SHT_STRTAB #:flags 0)))
1162 (values (make-object asm '.symtab
1165 #:type SHT_SYMTAB #:flags 0 #:entsize size
1166 #:link (elf-section-index
1167 (linker-object-section strtab)))
1170 ;;; The .guile.arities section describes the arities that a function can
1171 ;;; have. It is in two parts: a sorted array of headers describing
1172 ;;; basic arities, and an array of links out to a string table (and in
1173 ;;; the case of keyword arguments, to the data section) for argument
1174 ;;; names. The whole thing is prefixed by a uint32 indicating the
1175 ;;; offset of the end of the headers array.
1177 ;;; The arity headers array is a packed array of structures of the form:
1179 ;;; struct arity_header {
1180 ;;; uint32_t low_pc;
1181 ;;; uint32_t high_pc;
1182 ;;; uint32_t offset;
1188 ;;; All of the offsets and addresses are 32 bits. We can expand in the
1189 ;;; future to use 64-bit offsets if appropriate, but there are other
1190 ;;; aspects of RTL that constrain us to a total image that fits in 32
1191 ;;; bits, so for the moment we'll simplify the problem space.
1193 ;;; The following flags values are defined:
1196 ;;; #x2: allow-other-keys?
1197 ;;; #x4: has-keyword-args?
1198 ;;; #x8: is-case-lambda?
1200 ;;; Functions with a single arity specify their number of required and
1201 ;;; optional arguments in nreq and nopt, and do not have the
1202 ;;; is-case-lambda? flag set. Their "offset" member links to an array
1203 ;;; of pointers into the associated .guile.arities.strtab string table,
1204 ;;; identifying the argument names. This offset is relative to the
1205 ;;; start of the .guile.arities section. Links for required arguments
1206 ;;; are first, in order, as uint32 values. Next follow the optionals,
1207 ;;; then the rest link if has-rest? is set, then a link to the "keyword
1208 ;;; indices" literal if has-keyword-args? is set. Unlike the other
1209 ;;; links, the kw-indices link points into the data section, and is
1210 ;;; relative to the ELF image as a whole.
1212 ;;; Functions with no arities have no arities information present in the
1213 ;;; .guile.arities section.
1215 ;;; Functions with multiple arities are preceded by a header with
1216 ;;; is-case-lambda? set. All other fields are 0, except low-pc and
1217 ;;; high-pc which should be the bounds of the whole function. Headers
1218 ;;; for the individual arities follow. In this way the whole headers
1219 ;;; array is sorted in increasing low-pc order, and case-lambda clauses
1220 ;;; are contained within the [low-pc, high-pc] of the case-lambda
1223 ;; Length of the prefix to the arities section, in bytes.
1224 (define arities-prefix-len 4)
1226 ;; Length of an arity header, in bytes.
1227 (define arity-header-len (* 6 4))
1229 ;; The offset of "offset" within arity header, in bytes.
1230 (define arity-header-offset-offset (* 2 4))
1232 (define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
1233 has-keyword-args? is-case-lambda?)
1234 (logior (if has-rest? (ash 1 0) 0)
1235 (if allow-other-keys? (ash 1 1) 0)
1236 (if has-keyword-args? (ash 1 2) 0)
1237 (if is-case-lambda? (ash 1 3) 0)))
1239 (define (meta-arities-size meta)
1240 (define (lambda-size arity)
1242 (* 4 ;; name pointers
1243 (+ (length (arity-req arity))
1244 (length (arity-opt arity))
1245 (if (arity-rest arity) 1 0)
1246 (if (pair? (arity-kw-indices arity)) 1 0)))))
1247 (define (case-lambda-size arities)
1249 arity-header-len ;; case-lambda header
1250 (map lambda-size arities))) ;; the cases
1251 (match (meta-arities meta)
1253 ((arity) (lambda-size arity))
1254 (arities (case-lambda-size arities))))
1256 (define (write-arity-headers metas bv endianness)
1257 (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
1258 (bytevector-u32-set! bv pos low-pc endianness)
1259 (bytevector-u32-set! bv (+ pos 4) high-pc endianness)
1260 (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
1261 (bytevector-u32-set! bv (+ pos 12) flags endianness)
1262 (bytevector-u32-set! bv (+ pos 16) nreq endianness)
1263 (bytevector-u32-set! bv (+ pos 20) nopt endianness))
1264 (define (write-arity-header pos arity)
1265 (write-arity-header* pos (arity-low-pc arity)
1266 (arity-high-pc arity)
1267 (pack-arity-flags (arity-rest arity)
1268 (arity-allow-other-keys? arity)
1269 (pair? (arity-kw-indices arity))
1271 (length (arity-req arity))
1272 (length (arity-opt arity))))
1273 (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
1276 ;; Fill in the prefix.
1277 (bytevector-u32-set! bv 0 pos endianness)
1278 (values pos (reverse offsets)))
1280 (match (meta-arities meta)
1281 (() (lp metas pos offsets))
1283 (write-arity-header pos arity)
1285 (+ pos arity-header-len)
1286 (acons arity (+ pos arity-header-offset-offset) offsets)))
1288 ;; Write a case-lambda header, then individual arities.
1289 ;; The case-lambda header's offset link is 0.
1290 (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
1291 (pack-arity-flags #f #f #f #t) 0 0)
1292 (let lp* ((arities arities) (pos (+ pos arity-header-len))
1295 (() (lp metas pos offsets))
1297 (write-arity-header pos arity)
1299 (+ pos arity-header-len)
1301 (+ pos arity-header-offset-offset)
1304 (define (write-arity-links asm bv pos arity-offset-pairs strtab)
1305 (define (write-symbol sym pos)
1306 (bytevector-u32-set! bv pos
1307 (string-table-intern! strtab (symbol->string sym))
1308 (asm-endianness asm))
1310 (define (write-kw-indices pos kw-indices)
1311 ;; FIXME: Assert that kw-indices is already interned.
1312 (make-linker-reloc 'abs32/1 pos 0
1313 (intern-constant asm kw-indices)))
1314 (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
1317 (unless (= pos (bytevector-length bv))
1318 (error "expected to fully fill the bytevector"
1319 pos (bytevector-length bv)))
1321 (((arity . offset) . pairs)
1322 (bytevector-u32-set! bv offset pos (asm-endianness asm))
1323 (let ((pos (fold write-symbol
1325 (append (arity-req arity)
1328 ((arity-rest arity) => list)
1330 (match (arity-kw-indices arity)
1331 (() (lp pos pairs relocs))
1335 (cons (write-kw-indices pos kw-indices) relocs)))))))))
1337 (define (link-arities asm)
1338 (let* ((endianness (asm-endianness asm))
1339 (metas (reverse (asm-meta asm)))
1340 (size (fold (lambda (meta size)
1341 (+ size (meta-arities-size meta)))
1344 (strtab (make-string-table))
1345 (bv (make-bytevector size 0)))
1346 (let ((kw-indices-relocs
1349 (write-arity-headers metas bv endianness))
1350 (lambda (pos arity-offset-pairs)
1351 (write-arity-links asm bv pos arity-offset-pairs strtab)))))
1352 (let ((strtab (make-object asm '.guile.arities.strtab
1353 (link-string-table! strtab)
1355 #:type SHT_STRTAB #:flags 0)))
1356 (values (make-object asm '.guile.arities
1358 kw-indices-relocs '()
1359 #:type SHT_PROGBITS #:flags 0
1360 #:link (elf-section-index
1361 (linker-object-section strtab)))
1365 ;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
1366 ;;; values. Pc and str are both 32 bits wide. (Either could change to
1367 ;;; 64 bits if appropriate in the future.) Pc is the address of the
1368 ;;; entry to a program, relative to the start of the text section, and
1369 ;;; str is an index into the associated .guile.docstrs.strtab string
1373 ;; The size of a docstrs entry, in bytes.
1374 (define docstr-size 8)
1376 (define (link-docstrs asm)
1377 (define (find-docstrings)
1378 (filter-map (lambda (meta)
1379 (define (is-documentation? pair)
1380 (eq? (car pair) 'documentation))
1381 (let* ((props (meta-properties meta))
1382 (tail (find-tail is-documentation? props)))
1384 (not (find-tail is-documentation? (cdr tail)))
1385 (string? (cdar tail))
1386 (cons (meta-low-pc meta) (cdar tail)))))
1387 (reverse (asm-meta asm))))
1388 (let* ((endianness (asm-endianness asm))
1389 (docstrings (find-docstrings))
1390 (strtab (make-string-table))
1391 (bv (make-bytevector (* (length docstrings) docstr-size) 0)))
1392 (fold (lambda (pair pos)
1395 (bytevector-u32-set! bv pos pc endianness)
1396 (bytevector-u32-set! bv (+ pos 4)
1397 (string-table-intern! strtab string)
1399 (+ pos docstr-size))))
1402 (let ((strtab (make-object asm '.guile.docstrs.strtab
1403 (link-string-table! strtab)
1405 #:type SHT_STRTAB #:flags 0)))
1406 (values (make-object asm '.guile.docstrs
1409 #:type SHT_PROGBITS #:flags 0
1410 #:link (elf-section-index
1411 (linker-object-section strtab)))
1415 ;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
1416 ;;; values. Pc and addr are both 32 bits wide. (Either could change to
1417 ;;; 64 bits if appropriate in the future.) Pc is the address of the
1418 ;;; entry to a program, relative to the start of the text section, and
1419 ;;; addr is the address of the associated properties alist, relative to
1420 ;;; the start of the ELF image.
1422 ;;; Since procedure properties are stored in the data sections, we need
1423 ;;; to link the procedures property section first. (Note that this
1424 ;;; constraint does not apply to the arities section, which may
1425 ;;; reference the data sections via the kw-indices literal, because
1426 ;;; assembling the text section already makes sure that the kw-indices
1430 ;; The size of a procprops entry, in bytes.
1431 (define procprops-size 8)
1433 (define (link-procprops asm)
1434 (define (assoc-remove-one alist key value-pred)
1437 ((((? (lambda (x) (eq? x key))) . value) . alist)
1438 (if (value-pred value)
1440 (acons key value alist)))
1442 (acons k v (assoc-remove-one alist key value-pred)))))
1443 (define (props-without-name-or-docstring meta)
1445 (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
1448 (define (find-procprops)
1449 (filter-map (lambda (meta)
1450 (let ((props (props-without-name-or-docstring meta)))
1452 (cons (meta-low-pc meta) props))))
1453 (reverse (asm-meta asm))))
1454 (let* ((endianness (asm-endianness asm))
1455 (procprops (find-procprops))
1456 (bv (make-bytevector (* (length procprops) procprops-size) 0)))
1457 (let lp ((procprops procprops) (pos 0) (relocs '()))
1460 (make-object asm '.guile.procprops
1463 #:type SHT_PROGBITS #:flags 0))
1464 (((pc . props) . procprops)
1465 (bytevector-u32-set! bv pos pc endianness)
1467 (+ pos procprops-size)
1468 (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
1469 (intern-constant asm props))
1472 (define (link-objects asm)
1473 (let*-values (;; Link procprops before constants, because it probably
1474 ;; interns more constants.
1475 ((procprops) (link-procprops asm))
1476 ((ro rw rw-init) (link-constants asm))
1477 ;; Link text object after constants, so that the
1478 ;; constants initializer gets included.
1479 ((text) (link-text-object asm))
1480 ((dt) (link-dynamic-section asm text rw rw-init))
1481 ((symtab strtab) (link-symtab (linker-object-section text) asm))
1482 ((arities arities-strtab) (link-arities asm))
1483 ((docstrs docstrs-strtab) (link-docstrs asm))
1484 ;; This needs to be linked last, because linking other
1485 ;; sections adds entries to the string table.
1486 ((shstrtab) (link-shstrtab asm)))
1488 (list text ro rw dt symtab strtab arities arities-strtab
1489 docstrs docstrs-strtab procprops shstrtab))))
1495 ;;; High-level public interfaces.
1498 (define* (link-assembly asm #:key (page-aligned? #t))
1499 "Produce an ELF image from the code and data emitted into @var{asm}.
1500 The result is a bytevector, by default linked so that read-only and
1501 writable data are on separate pages. Pass @code{#:page-aligned? #f} to
1502 disable this behavior."
1503 (link-elf (link-objects asm) #:page-aligned? page-aligned?))
1505 (define (assemble-program instructions)
1506 "Take the sequence of instructions @var{instructions}, assemble them
1507 into RTL code, link an image, and load that image from memory. Returns
1509 (let ((asm (make-assembler)))
1510 (emit-text asm instructions)
1511 (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))