Linux iad1-shared-b7-18 6.6.49-grsec-jammy+ #10 SMP Thu Sep 12 23:23:08 UTC 2024 x86_64
Apache
: 67.205.6.31 | : 216.73.216.47
Cant Read [ /etc/named.conf ]
8.2.29
fernandoquevedo
Terminal
AUTO ROOT
Adminer
Backdoor Destroyer
Linux Exploit
Lock Shell
Lock File
Create User
CREATE RDP
PHP Mailer
BACKCONNECT
UNLOCK SHELL
HASH IDENTIFIER
README
+ Create Folder
+ Create File
/
usr /
share /
guile /
3.0 /
system /
vm /
[ HOME SHELL ]
Name
Size
Permission
Action
assembler.scm
115.76
KB
-rw-r--r--
coverage.scm
14.05
KB
-rw-r--r--
debug.scm
30.05
KB
-rw-r--r--
disassembler.scm
24.97
KB
-rw-r--r--
dwarf.scm
57.82
KB
-rw-r--r--
elf.scm
41.89
KB
-rw-r--r--
frame.scm
18.06
KB
-rw-r--r--
inspect.scm
5.91
KB
-rw-r--r--
linker.scm
31.04
KB
-rw-r--r--
loader.scm
1.09
KB
-rw-r--r--
program.scm
11.5
KB
-rw-r--r--
trace.scm
4.77
KB
-rw-r--r--
trap-state.scm
10.08
KB
-rw-r--r--
traps.scm
21.15
KB
-rw-r--r--
vm.scm
1.35
KB
-rw-r--r--
Delete
Unzip
Zip
${this.title}
Close
Code Editor : assembler.scm
;;; Guile bytecode assembler ;;; Copyright (C) 2001, 2009-2021 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public ;;; License as published by the Free Software Foundation; either ;;; version 3 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public ;;; License along with this library; if not, write to the Free Software ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Commentary: ;;; ;;; This module implements an assembler that creates an ELF image from ;;; bytecode assembly and macro-assembly. The input can be given in ;;; s-expression form, like ((OP ARG ...) ...). Internally there is a ;;; procedural interface, the emit-OP procedures, but that is not ;;; currently exported. ;;; ;;; "Primitive instructions" correspond to VM operations. Assemblers ;;; for primitive instructions are generated programmatically from ;;; (instruction-list), which itself is derived from the VM sources. ;;; There are also "macro-instructions" like "label" or "load-constant" ;;; that expand to 0 or more primitive instructions. ;;; ;;; The assembler also handles some higher-level tasks, like creating ;;; the symbol table, other metadata sections, creating a constant table ;;; for the whole compilation unit, and writing the dynamic section of ;;; the ELF file along with the appropriate initialization routines. ;;; ;;; Most compilers will want to use the trio of make-assembler, ;;; emit-text, and link-assembly. That will result in the creation of ;;; an ELF image as a bytevector, which can then be loaded using ;;; load-thunk-from-memory, or written to disk as a .go file. ;;; ;;; Code: (define-module (system vm assembler) #:use-module (system base target) #:use-module (system base types internal) #:use-module (system vm dwarf) #:use-module (system vm elf) #:use-module (system vm linker) #:use-module (system syntax internal) #:use-module (language bytecode) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:export (make-assembler (emit-receive* . emit-receive) (emit-mov* . emit-mov) (emit-fmov* . emit-fmov) emit-u64=? emit-u64<? emit-u64-imm<? emit-imm-u64<? emit-s64-imm=? emit-s64<? emit-s64-imm<? emit-imm-s64<? emit-f64=? emit-f64<? emit-=? emit-<? emit-arguments<=? emit-positional-arguments<=? emit-immediate-tag=? emit-heap-tag=? emit-eq? emit-eq-immediate? emit-heap-numbers-equal? emit-j emit-jl emit-je emit-jnl emit-jne emit-jge emit-jnge emit-jtable emit-fixnum? emit-heap-object? emit-char? emit-undefined? emit-null? emit-false? emit-nil? emit-untag-fixnum emit-tag-fixnum emit-untag-char emit-tag-char emit-s64->f64 emit-throw (emit-throw/value* . emit-throw/value) (emit-throw/value+data* . emit-throw/value+data) emit-pair? emit-struct? emit-symbol? emit-variable? emit-vector? emit-mutable-vector? emit-immutable-vector? emit-weak-vector? emit-string? emit-heap-number? emit-hash-table? emit-pointer? emit-fluid? emit-stringbuf? emit-dynamic-state? emit-frame? emit-keyword? emit-syntax? emit-program? emit-vm-continuation? emit-bytevector? emit-weak-set? emit-weak-table? emit-array? emit-bitvector? emit-port? emit-smob? emit-bignum? emit-flonum? emit-compnum? emit-fracnum? emit-allocate-words emit-allocate-words/immediate emit-allocate-pointerless-words emit-allocate-pointerless-words/immediate emit-scm-ref emit-scm-set! emit-scm-ref/tag emit-scm-set!/tag emit-scm-ref/immediate emit-scm-set!/immediate emit-word-ref emit-word-set! emit-word-ref/immediate emit-word-set!/immediate emit-pointer-ref/immediate emit-pointer-set!/immediate emit-tail-pointer-ref/immediate emit-u8-ref emit-s8-ref emit-u16-ref emit-s16-ref emit-u32-ref emit-s32-ref emit-u64-ref emit-s64-ref emit-f32-ref emit-f64-ref emit-u8-set! emit-s8-set! emit-u16-set! emit-s16-set! emit-u32-set! emit-s32-set! emit-u64-set! emit-s64-set! emit-f32-set! emit-f64-set! emit-atomic-scm-ref/immediate emit-atomic-scm-set!/immediate emit-atomic-scm-swap!/immediate emit-atomic-scm-compare-and-swap!/immediate ;; Intrinsics. emit-add emit-add/immediate emit-sub emit-sub/immediate emit-mul emit-div emit-quo emit-rem emit-mod emit-inexact emit-abs emit-sqrt emit-floor emit-ceiling emit-sin emit-cos emit-tan emit-asin emit-acos emit-atan emit-atan2 emit-fabs emit-fsqrt emit-ffloor emit-fceiling emit-fsin emit-fcos emit-ftan emit-fasin emit-facos emit-fatan emit-fatan2 emit-logand emit-logior emit-logxor emit-logsub emit-string-set! emit-string->number emit-string->symbol emit-symbol->keyword emit-class-of emit-scm->f64 emit-scm->u64 emit-scm->u64/truncate emit-scm->s64 emit-u64->scm emit-s64->scm emit-wind emit-unwind emit-push-fluid emit-pop-fluid emit-fluid-ref emit-fluid-set! emit-push-dynamic-state emit-pop-dynamic-state emit-lsh emit-rsh emit-lsh/immediate emit-rsh/immediate emit-resolve-module emit-module-variable emit-lookup emit-lookup-bound emit-lookup-bound-public emit-lookup-bound-private emit-define! emit-current-module ;; Intrinsics for use by the baseline compiler. emit-$car emit-$cdr emit-$set-car! emit-$set-cdr! emit-$variable-ref emit-$variable-set! emit-$vector-length emit-$vector-ref emit-$vector-set! emit-$vector-ref/immediate emit-$vector-set!/immediate emit-$allocate-struct emit-$struct-vtable emit-$struct-ref emit-$struct-set! emit-$struct-ref/immediate emit-$struct-set!/immediate emit-cache-ref emit-cache-set! emit-call emit-call-label emit-tail-call emit-tail-call-label (emit-instrument-entry* . emit-instrument-entry) (emit-instrument-loop* . emit-instrument-loop) emit-receive-values emit-return-values emit-shuffle-down emit-call/cc emit-abort emit-builtin-ref emit-assert-nargs-ee emit-assert-nargs-ge emit-assert-nargs-le emit-reset-frame emit-assert-nargs-ee/locals emit-bind-kwargs emit-bind-rest emit-load-label emit-resolve emit-prompt emit-current-thread emit-fadd emit-fsub emit-fmul emit-fdiv emit-uadd emit-usub emit-umul emit-uadd/immediate emit-usub/immediate emit-umul/immediate emit-ulogand emit-ulogior emit-ulogxor emit-ulogsub emit-ursh emit-srsh emit-ulsh emit-ursh/immediate emit-srsh/immediate emit-ulsh/immediate emit-make-array emit-load-f64 emit-load-u64 emit-load-s64 emit-handle-interrupts emit-text link-assembly)) ;; Like define-inlinable, but only for first-order uses of the defined ;; routine. Should residualize less code. (eval-when (expand) (define-syntax define-inline (lambda (x) (syntax-case x () ((_ (name arg ...) body ...) (with-syntax (((temp ...) (generate-temporaries #'(arg ...)))) #`(eval-when (expand) (define-syntax-rule (name temp ...) (let ((arg temp) ...) body ...))))))))) ;;; Bytecode consists of 32-bit units, often subdivided in some way. ;;; These helpers create one 32-bit unit from multiple components. (define-inline (check-urange x mask) (unless (and (exact-integer? x) (= x (logand x mask))) (error "out of range" x)) x) (define-inline (check-srange x mask) (let ((x* (logand x mask))) (unless (if (negative? x) (= (+ x mask 1) x*) (= x x*)) (error "out of range" x)) x*)) (define-inline (pack-u8-u24 x y) (let ((x (check-urange x #xff)) (y (check-urange y #xffffff))) (logior x (ash y 8)))) (define-inline (pack-u8-s24 x y) (let ((x (check-urange x #xff)) (y (check-srange y #xffffff))) (logior x (ash y 8)))) (define-inline (pack-u16-u16 x y) (let ((x (check-urange x #xffff)) (y (check-urange y #xffff))) (logior x (ash y 16)))) (define-inline (pack-u1-u7-u24 x y z) (let ((x (check-urange x #x1)) (y (check-urange y #x7f)) (z (check-urange z #xffffff))) (logior x (ash y 1) (ash z 8)))) (define-inline (pack-u8-u12-u12 x y z) (let ((x (check-urange x #xff)) (y (check-urange y #xfff)) (z (check-urange z #xfff))) (logior x (ash y 8) (ash z 20)))) (define-inline (pack-u8-u12-s12 x y z) (let ((x (check-urange x #xff)) (y (check-urange y #xfff)) (z (check-srange z #xfff))) (logior x (ash y 8) (ash z 20)))) (define-inline (pack-u8-u8-u16 x y z) (let ((x (check-urange x #xff)) (y (check-urange y #xff)) (z (check-urange z #xffff))) (logior x (ash y 8) (ash z 16)))) (define-inline (pack-u8-u8-u8-u8 x y z w) (let ((x (check-urange x #xff)) (y (check-urange y #xff)) (z (check-urange z #xff)) (w (check-urange w #xff))) (logior x (ash y 8) (ash z 16) (ash w 24)))) (eval-when (expand) (define-syntax pack-flags (syntax-rules () ;; Add clauses as needed. ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0) (if f2 (ash 1 1) 0)))))) (define-syntax-rule (define-byte-order-swapper name size ref set) (define* (name buf #:optional (start 0) (end (bytevector-length buf))) "Patch up the text buffer @var{buf}, swapping the endianness of each N-byte unit." (unless (zero? (modulo (- end start) size)) (error "unexpected length")) (let lp ((pos start)) (when (< pos end) (set buf pos (ref buf pos (endianness big)) (endianness little)) (lp (+ pos size)))))) (define-byte-order-swapper byte-swap/2! 2 bytevector-u16-ref bytevector-u16-set!) (define-byte-order-swapper byte-swap/4! 4 bytevector-u32-ref bytevector-u32-set!) (define-byte-order-swapper byte-swap/8! 8 bytevector-u64-ref bytevector-u64-set!) ;;; A <meta> entry collects metadata for one procedure. Procedures are ;;; written as contiguous ranges of bytecode. ;;; (eval-when (expand) (define-syntax-rule (assert-match arg pattern kind) (let ((x arg)) (unless (match x (pattern #t) (_ #f)) (error (string-append "expected " kind) x))))) (define-record-type <jit-data> (make-jit-data low-pc high-pc) jit-data? (low-pc jit-data-low-pc) (high-pc jit-data-high-pc)) (define-record-type <meta> (%make-meta label properties low-pc high-pc arities jit-data-label) meta? (label meta-label) (properties meta-properties set-meta-properties!) (low-pc meta-low-pc) (high-pc meta-high-pc set-meta-high-pc!) (arities meta-arities set-meta-arities!) (jit-data-label meta-jit-data-label)) (define (make-meta label properties low-pc) (assert-match label (or (? exact-integer?) (? symbol?)) "symbol") (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys") (%make-meta label properties low-pc #f '() (gensym "jit-data"))) (define (meta-name meta) (assq-ref (meta-properties meta) 'name)) ;; Metadata for one <lambda-case>. (define-record-type <arity> (make-arity req opt rest kw-indices allow-other-keys? has-closure? low-pc high-pc definitions) arity? (req arity-req) (opt arity-opt) (rest arity-rest) (kw-indices arity-kw-indices) (allow-other-keys? arity-allow-other-keys?) (has-closure? arity-has-closure?) (low-pc arity-low-pc) (high-pc arity-high-pc set-arity-high-pc!) (definitions arity-definitions set-arity-definitions!)) ;;; An assembler collects all of the words emitted during assembly, and ;;; also maintains ancillary information such as the constant table, a ;;; relocation list, and so on. ;;; ;;; Bytecode consists of 32-bit units. We emit bytecode using native ;;; endianness. If we're targeting a foreign endianness, we byte-swap ;;; the bytevector as a whole instead of conditionalizing each access. ;;; (define-record-type <asm> (make-asm buf pos start labels relocs word-size endianness constants inits shstrtab next-section-number meta sources slot-maps) asm? ;; We write bytecode into a bytevector, growing the bytevector as ;; needed. asm-cur is that bytevector, and asm-pos is the byte offset ;; into the vector at which the next word should be written. ;; (buf asm-buf set-asm-buf!) (pos asm-pos set-asm-pos!) ;; asm-start is an absolute position, indicating the byte offset of ;; the beginning of an instruction. It is updated after writing all ;; the words for one primitive instruction. It models the position of ;; the instruction pointer during execution, given that the VM updates ;; the IP only at the end of executing the instruction, and is thus ;; useful for computing offsets between two points in a program. ;; (start asm-start set-asm-start!) ;; An alist of symbol -> position pairs, indicating the labels defined ;; in this compilation unit. ;; (labels asm-labels set-asm-labels!) ;; A list of relocations needed by the program text. We use an ;; internal representation for relocations, and handle textual ;; relative relocations in the assembler. Other kinds of relocations ;; are later reified as linker relocations and resolved by the linker. ;; (relocs asm-relocs set-asm-relocs!) ;; Target information. ;; (word-size asm-word-size) (endianness asm-endianness) ;; The constant table, as a vhash of object -> label. All constants ;; get de-duplicated and written into separate sections -- either the ;; .rodata section, for read-only data, or .data, for constants that ;; need initialization at load-time (like symbols). Constants can ;; depend on other constants (e.g. a symbol depending on a stringbuf), ;; so order in this table is important. ;; (constants asm-constants set-asm-constants!) ;; A vhash of label to init descriptors, where an init descriptor is ;; #(EMIT-INIT STATIC? PATCHES). EMIT-INIT, if present, is a ;; procedure taking the asm and the label as arguments. Unless the ;; object is statically allocatable, in which case it can be loaded ;; via make-non-immediate rather than static-ref, EMIT-INIT should ;; also initialize the corresponding cell for any later static-ref. ;; If STATIC? is true, the value can be loaded with ;; emit-make-non-immediate, otherwise it's emit-static-ref. A bit ;; confusing but that's how it is. PATCHES is a list of (DEST-LABEL ;; . FIELD) pairs, indicating locations to which to patch the value. ;; Like asm-constants, order is important. ;; (inits asm-inits set-asm-inits!) ;; The shstrtab, for section names. ;; (shstrtab asm-shstrtab set-asm-shstrtab!) ;; The section number for the next section to be written. ;; (next-section-number asm-next-section-number set-asm-next-section-number!) ;; A list of <meta>, corresponding to procedure metadata. ;; (meta asm-meta set-asm-meta!) ;; A list of (pos . source) pairs, indicating source information. POS ;; is relative to the beginning of the text section, and SOURCE is in ;; the same format that source-properties returns. ;; (sources asm-sources set-asm-sources!) ;; A list of (pos . slot-map) pairs, indicating slot maps. POS is ;; relative to the beginning of the text section. SLOT-MAP is a ;; bitfield describing the stack at call sites, as an integer. ;; (slot-maps asm-slot-maps set-asm-slot-maps!)) (define* (make-assembler #:key (word-size (target-word-size)) (endianness (target-endianness))) "Create an assembler for a given target @var{word-size} and @var{endianness}, falling back to appropriate values for the configured target." (make-asm (make-u32vector 1000) 0 0 (make-hash-table) '() word-size endianness vlist-null vlist-null (make-string-table) 1 '() '() '())) (define (intern-section-name! asm string) "Add a string to the section name table (shstrtab)." (string-table-intern! (asm-shstrtab asm) string)) (define (grow-buffer! asm) "Grow the code buffer of the asm." (let* ((buf (asm-buf asm)) (len (bytevector-length buf)) (new (make-u32vector (ash len -1) 0))) (bytevector-copy! buf 0 new 0 len) (set-asm-buf! asm new) #f)) (define-inline (emit asm u32) "Emit one 32-bit word into the instruction stream. Assumes that there is space for the word." (bytevector-u32-native-set! (asm-buf asm) (asm-pos asm) u32) (set-asm-pos! asm (+ (asm-pos asm) 4))) (define-inline (make-reloc type label base word) "Make an internal relocation of type @var{type} referencing symbol @var{label}, @var{word} words after position @var{start}. @var{type} may be x8-s24, indicating a 24-bit relative label reference that can be fixed up by the assembler, or s32, indicating a 32-bit relative reference that needs to be fixed up by the linker." (list type label base word)) (define-inline (reset-asm-start! asm) "Reset the asm-start after writing the words for one instruction." (set-asm-start! asm (asm-pos asm))) (define (record-label-reference asm label) "Record an x8-s24 local label reference. This value will get patched up later by the assembler." (let* ((start (asm-start asm)) (pos (asm-pos asm)) (reloc (make-reloc 'x8-s24 label start (- pos start)))) (set-asm-relocs! asm (cons reloc (asm-relocs asm))))) (define* (record-far-label-reference asm label #:optional (offset 0)) "Record an s32 far label reference. This value will get patched up later by the linker." (let* ((start (- (asm-start asm) offset)) (pos (asm-pos asm)) (reloc (make-reloc 's32 label start (- pos start)))) (set-asm-relocs! asm (cons reloc (asm-relocs asm))))) (define (immediate-bits asm x) (let ((bits (scm->immediate-bits x))) (and bits (truncate-bits bits (* 8 (asm-word-size asm)) #t)))) ;;; ;;; Primitive assemblers are defined by expanding `assembler' for each ;;; opcode in `(instruction-list)'. ;;; (eval-when (expand) (define (id-append ctx a b) (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) (define-syntax encoder (lambda (x) (define-syntax op-case (lambda (x) (syntax-case x () ((_ asm name ((type arg ...) code ...) clause ...) #`(if (eq? name 'type) (with-syntax (((arg ...) (generate-temporaries #'(arg ...)))) #'((arg ...) code ...)) (op-case asm name clause ...))) ((_ asm name) #'(error "unmatched name" name))))) (define (pack-first-word asm opcode type) (with-syntax ((opcode opcode)) (op-case asm type ((X32) (emit asm opcode)) ((X8_S24 arg) (emit asm (pack-u8-u24 opcode arg))) ((X8_F24 arg) (emit asm (pack-u8-u24 opcode arg))) ((X8_C24 arg) (emit asm (pack-u8-u24 opcode arg))) ((X8_L24 label) (record-label-reference asm label) (emit asm opcode)) ((X8_S8_I16 a imm) (let ((bits (truncate-bits (scm->immediate-bits imm) 16 #f))) (emit asm (pack-u8-u8-u16 opcode a bits)))) ((X8_S8_ZI16 a imm) (let ((bits (truncate-bits (scm->immediate-bits imm) 16 #t))) (emit asm (pack-u8-u8-u16 opcode a bits)))) ((X8_S12_S12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) ((X8_S12_C12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) ((X8_S12_Z12 a b) (emit asm (pack-u8-u12-s12 opcode a b))) ((X8_C12_C12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) ((X8_F12_F12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) ((X8_S8_S8_S8 a b c) (emit asm (pack-u8-u8-u8-u8 opcode a b c))) ((X8_S8_S8_C8 a b c) (emit asm (pack-u8-u8-u8-u8 opcode a b c))) ((X8_S8_C8_S8 a b c) (emit asm (pack-u8-u8-u8-u8 opcode a b c)))))) (define (pack-tail-word asm type) (op-case asm type ((C32 a) (emit asm a)) ((I32 imm) (let ((val (immediate-bits asm imm))) (emit asm val))) ((A32 imm) (unless (= (asm-word-size asm) 8) (error "make-long-immediate unavailable for this target")) (let ((bits (immediate-bits asm imm))) (emit asm (ash bits -32)) (emit asm (logand bits (1- (ash 1 32)))))) ((AF32 f64) (let ((u64 (u64vector-ref (f64vector f64) 0))) (emit asm (ash u64 -32)) (emit asm (logand u64 (1- (ash 1 32)))))) ((AU32 u64) (emit asm (ash u64 -32)) (emit asm (logand u64 (1- (ash 1 32))))) ((AS32 s64) (let ((u64 (u64vector-ref (s64vector s64) 0))) (emit asm (ash u64 -32)) (emit asm (logand u64 (1- (ash 1 32)))))) ((B32)) ((BU32)) ((BS32)) ((BF32)) ((N32 label) (record-far-label-reference asm label) (emit asm 0)) ((R32 label) (record-far-label-reference asm label) (emit asm 0)) ((L32 label) (record-far-label-reference asm label) (emit asm 0)) ((LO32 label offset) (record-far-label-reference asm label (* offset (asm-word-size asm))) (emit asm 0)) ((C8_C24 a b) (emit asm (pack-u8-u24 a b))) ((C8_S24 a b) (emit asm (pack-u8-u24 a b))) ((C16_C16 a b) (emit asm (pack-u16-u16 a b))) ((V32_X8_L24 labels) (let ((len (vector-length labels))) (emit asm len) (let lp () (unless (<= (+ (asm-pos asm) (* 4 len)) (bytevector-length (asm-buf asm))) (grow-buffer! asm) (lp))) (let lp ((n 0)) (when (< n len) (record-label-reference asm (vector-ref labels n)) (emit asm 0) (lp (1+ n)))))) ((B1_X7_L24 a label) (record-label-reference asm label) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) ((B1_C7_L24 a b label) (record-label-reference asm label) (emit asm (pack-u1-u7-u24 (if a 1 0) b 0))) ((B1_X31 a) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) ((B1_X7_S24 a b) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) ((B1_X7_F24 a b) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) ((B1_X7_C24 a b) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) ((X8_S24 a) (emit asm (pack-u8-u24 0 a))) ((X8_F24 a) (emit asm (pack-u8-u24 0 a))) ((X8_C24 a) (emit asm (pack-u8-u24 0 a))) ((X8_L24 label) (record-label-reference asm label) (emit asm 0)))) (syntax-case x () ((_ word0 word* ...) (with-syntax ((((formal0 ...) code0 ...) (pack-first-word #'asm #'opcode (syntax->datum #'word0))) ((((formal* ...) code* ...) ...) (map (lambda (word) (pack-tail-word #'asm word)) (syntax->datum #'(word* ...))))) ;; The opcode is the last argument, so that assemblers don't ;; have to shuffle their arguments before tail-calling an ;; encoder. #'(lambda (asm formal0 ... formal* ... ... opcode) (let lp () (let ((words (length '(word0 word* ...)))) (unless (<= (+ (asm-pos asm) (* 4 words)) (bytevector-length (asm-buf asm))) (grow-buffer! asm) (lp)))) code0 ... code* ... ... (reset-asm-start! asm))))))) (define (encoder-name operands) (let lp ((operands operands) (out #'encode)) (syntax-case operands () (() out) ((operand . operands) (lp #'operands (id-append #'operand (id-append out out #'-) #'operand)))))) (define-syntax define-encoder (lambda (x) (syntax-case x () ((_ operand ...) (with-syntax ((encode (encoder-name #'(operand ...)))) #'(define encode (encoder operand ...))))))) (define-syntax visit-instruction-kinds (lambda (x) (syntax-case x () ((visit-instruction-kinds macro arg ...) (with-syntax (((operands ...) (delete-duplicates (map (match-lambda ((name opcode kind . operands) (datum->syntax #'macro operands))) (instruction-list))))) #'(begin (macro arg ... . operands) ...))))))) (visit-instruction-kinds define-encoder) ;; In Guile's VM, locals are usually addressed via the stack pointer ;; (SP). There can be up to 2^24 slots for local variables in a ;; frame. Some instructions encode their operands using a restricted ;; subset of the full 24-bit local address space, in order to make the ;; bytecode more dense in the usual case that a function needs few ;; local slots. To allow these instructions to be used when there are ;; many local slots, we can temporarily push the values on the stack, ;; operate on them there, and then store back any result as we pop the ;; SP to its original position. ;; ;; We implement this shuffling via wrapper encoders that have the same ;; arity as the encoder they wrap, e.g. encode-X8_S12_S12/shuffle that ;; wraps encode-X8_S12_S12. We make the emit-cons public interface ;; use the shuffling encoder. That way we solve the problem fully and ;; in just one place. (define (encode-X8_S12_S12!/shuffle asm a b opcode) (cond ((< (logior a b) (ash 1 12)) (encode-X8_S12_S12 asm a b opcode)) (else (emit-push asm a) (emit-push asm (1+ b)) (encode-X8_S12_S12 asm 1 0 opcode) (emit-drop asm 2)))) (define (encode-X8_S12_S12<-/shuffle asm dst a opcode) (cond ((< (logior dst a) (ash 1 12)) (encode-X8_S12_S12 asm dst a opcode)) (else (emit-push asm a) (encode-X8_S12_S12 asm 0 0 opcode) (emit-pop asm dst)))) (define (encode-X8_S12_C12!/shuffle asm a const opcode) (cond ((< a (ash 1 12)) (encode-X8_S12_C12 asm a const opcode)) (else (emit-push asm a) (encode-X8_S12_C12 asm 0 const opcode) (emit-drop asm 1)))) (define (encode-X8_S12_C12<-/shuffle asm dst const opcode) (cond ((< dst (ash 1 12)) (encode-X8_S12_C12 asm dst const opcode)) (else ;; Push garbage value to make space for dst. (emit-push asm dst) (encode-X8_S12_C12 asm 0 const opcode) (emit-pop asm dst)))) (define (encode-X8_S12_Z12!/shuffle asm a const opcode) (cond ((< a (ash 1 12)) (encode-X8_S12_Z12 asm a const opcode)) (else (emit-push asm a) (encode-X8_S12_Z12 asm 0 const opcode) (emit-drop asm 1)))) (define (encode-X8_S8_I16<-/shuffle asm dst imm opcode) (cond ((< dst (ash 1 8)) (encode-X8_S8_I16 asm dst imm opcode)) (else ;; Push garbage value to make space for dst. (emit-push asm dst) (encode-X8_S8_I16 asm 0 imm opcode) (emit-pop asm dst)))) (define (encode-X8_S8_ZI16!/shuffle asm a imm opcode) (cond ((< a (ash 1 8)) (encode-X8_S8_ZI16 asm a imm opcode)) (else (emit-push asm a) (encode-X8_S8_ZI16 asm 0 imm opcode) (emit-drop asm 1)))) (define (encode-X8_S8_ZI16<-/shuffle asm dst imm opcode) (cond ((< dst (ash 1 8)) (encode-X8_S8_ZI16 asm dst imm opcode)) (else ;; Push garbage value to make space for dst. (emit-push asm dst) (encode-X8_S8_ZI16 asm 0 imm opcode) (emit-pop asm dst)))) (define (encode-X8_S8_S8_S8!/shuffle asm a b c opcode) (cond ((< (logior a b c) (ash 1 8)) (encode-X8_S8_S8_S8 asm a b c opcode)) (else (emit-push asm a) (emit-push asm (+ b 1)) (emit-push asm (+ c 2)) (encode-X8_S8_S8_S8 asm 2 1 0 opcode) (emit-drop asm 3)))) (define (encode-X8_S8_S8_S8<-/shuffle asm dst a b opcode) (cond ((< (logior dst a b) (ash 1 8)) (encode-X8_S8_S8_S8 asm dst a b opcode)) (else (emit-push asm a) (emit-push asm (1+ b)) (encode-X8_S8_S8_S8 asm 1 1 0 opcode) (emit-drop asm 1) (emit-pop asm dst)))) (define (encode-X8_S8_S8_C8<-/shuffle asm dst a const opcode) (cond ((< (logior dst a) (ash 1 8)) (encode-X8_S8_S8_C8 asm dst a const opcode)) (else (emit-push asm a) (encode-X8_S8_S8_C8 asm 0 0 const opcode) (emit-pop asm dst)))) (define (encode-X8_S8_C8_S8!/shuffle asm a const b opcode) (cond ((< (logior a b) (ash 1 8)) (encode-X8_S8_C8_S8 asm a const b opcode)) (else (emit-push asm a) (emit-push asm (1+ b)) (encode-X8_S8_C8_S8 asm 1 const 0 opcode) (emit-drop asm 2)))) (define (encode-X8_S8_C8_S8<-/shuffle asm dst const a opcode) (cond ((< (logior dst a) (ash 1 8)) (encode-X8_S8_C8_S8 asm dst const a opcode)) (else (emit-push asm a) (encode-X8_S8_C8_S8 asm 0 const 0 opcode) (emit-pop asm dst)))) (define (encode-X8_S8_S8_S8-C32!/shuffle asm a b c const opcode) (cond ((< (logior a b c) (ash 1 8)) (encode-X8_S8_S8_S8-C32 asm a b c const opcode)) (else (emit-push asm a) (emit-push asm (+ b 1)) (emit-push asm (+ c 2)) (encode-X8_S8_S8_S8-C32 asm 2 1 0 const opcode) (emit-drop asm 3)))) (define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode) (cond ((< (logior dst a b) (ash 1 8)) (encode-X8_S8_S8_S8-C32 asm dst a b c32 opcode)) (else (emit-push asm a) (emit-push asm (1+ b)) (encode-X8_S8_S8_S8-C32 asm 1 1 0 c32 opcode) (emit-drop asm 1) (emit-pop asm dst)))) (define (encode-X8_S8_S8_C8-C32<-/shuffle asm dst a const c32 opcode) (cond ((< (logior dst a) (ash 1 8)) (encode-X8_S8_S8_C8-C32 asm dst a const c32 opcode)) (else (emit-push asm a) (encode-X8_S8_S8_C8-C32 asm 0 0 const c32 opcode) (emit-pop asm dst)))) (define (encode-X8_S8_S8_S8-C32!/shuffle asm a b c c32 opcode) (cond ((< (logior a b c) (ash 1 8)) (encode-X8_S8_S8_S8-C32 asm a b c c32 opcode)) (else (emit-push asm a) (emit-push asm (+ b 1)) (emit-push asm (+ c 2)) (encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode) (emit-drop asm 3)))) (define (encode-X8_S8_C8_S8-C32!/shuffle asm a const b c32 opcode) (cond ((< (logior a b) (ash 1 8)) (encode-X8_S8_C8_S8-C32 asm a const b c32 opcode)) (else (emit-push asm a) (emit-push asm (+ b 1)) (encode-X8_S8_C8_S8-C32 asm 1 const 0 c32 opcode) (emit-drop asm 2)))) (define (encode-X8_S12_S12-C32<-/shuffle asm dst src c32 opcode) (cond ((< (logior dst src) (ash 1 12)) (encode-X8_S12_S12-C32 asm dst src c32 opcode)) (else (emit-push asm src) (encode-X8_S12_S12-C32 asm 0 0 c32 opcode) (emit-pop asm dst)))) (define (encode-X8_S12_S12-C32!/shuffle asm a b c32 opcode) (cond ((< (logior a b) (ash 1 12)) (encode-X8_S12_S12-C32 asm a b c32 opcode)) (else (emit-push asm a) (emit-push asm b) (encode-X8_S12_S12-C32 asm 1 0 c32 opcode) (emit-drop asm 2)))) (eval-when (expand) (define (id-append ctx a b) (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) (define (shuffling-encoder-name kind operands) (match (cons (syntax->datum kind) (syntax->datum operands)) (('! 'X8_S12_S12) #'encode-X8_S12_S12!/shuffle) (('<- 'X8_S12_S12) #'encode-X8_S12_S12<-/shuffle) (('! 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24!/shuffle) (('<- 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24<-/shuffle) (('! 'X8_S12_C12) #'encode-X8_S12_C12!/shuffle) (('<- 'X8_S12_C12) #'encode-X8_S12_C12<-/shuffle) (('! 'X8_S12_Z12) #'encode-X8_S12_Z12!/shuffle) (('<- 'X8_S8_I16) #'encode-X8_S8_I16<-/shuffle) (('! 'X8_S8_ZI16) #'encode-X8_S8_ZI16!/shuffle) (('<- 'X8_S8_ZI16) #'encode-X8_S8_ZI16<-/shuffle) (('! 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8!/shuffle) (('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle) (('<- 'X8_S8_S8_C8) #'encode-X8_S8_S8_C8<-/shuffle) (('! 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32!/shuffle) (('! 'X8_S8_C8_S8 'C32) #'encode-X8_S8_C8_S8-C32!/shuffle) (('<- 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32<-/shuffle) (('<- 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32<-/shuffle) (('<- 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32<-/shuffle) (('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle) (('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle) (('<- 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8<-/shuffle) (else (encoder-name operands)))) (define-syntax assembler (lambda (x) (define (word-args word) (match word ('C32 #'(a)) ('I32 #'(imm)) ('A32 #'(imm)) ('AF32 #'(f64)) ('AU32 #'(u64)) ('AS32 #'(s64)) ('B32 #'()) ('BU32 #'()) ('BS32 #'()) ('BF32 #'()) ('N32 #'(label)) ('R32 #'(label)) ('L32 #'(label)) ('LO32 #'(label offset)) ('C8_C24 #'(a b)) ('C8_S24 #'(a b)) ('C16_C16 #'(a b)) ('V32_X8_L24 #'(labels)) ('B1_X7_L24 #'(a label)) ('B1_C7_L24 #'(a b label)) ('B1_X31 #'(a)) ('B1_X7_S24 #'(a b)) ('B1_X7_F24 #'(a b)) ('B1_X7_C24 #'(a b)) ('X8_S24 #'(arg)) ('X8_F24 #'(arg)) ('X8_C24 #'(arg)) ('X8_L24 #'(label)) ('X8_S8_I16 #'(a imm)) ('X8_S8_ZI16 #'(a imm)) ('X8_S12_S12 #'(a b)) ('X8_S12_C12 #'(a b)) ('X8_S12_Z12 #'(a b)) ('X8_C12_C12 #'(a b)) ('X8_F12_F12 #'(a b)) ('X8_S8_S8_S8 #'(a b c)) ('X8_S8_S8_C8 #'(a b c)) ('X8_S8_C8_S8 #'(a b c)) ('X32 #'()))) (syntax-case x () ((_ name opcode kind word ...) (with-syntax (((formal ...) (generate-temporaries (append-map word-args (syntax->datum #'(word ...))))) (encode (shuffling-encoder-name #'kind #'(word ...)))) #'(lambda (asm formal ...) (encode asm formal ... opcode)))))))) (define assemblers (make-hash-table)) (eval-when (expand) (define-syntax define-assembler (lambda (x) (syntax-case x () ((_ name opcode kind arg ...) (with-syntax ((emit (id-append #'name #'emit- #'name))) #'(define emit (let ((emit (assembler name opcode kind arg ...))) (hashq-set! assemblers 'name emit) emit))))))) (define-syntax visit-opcodes (lambda (x) (syntax-case x () ((visit-opcodes macro arg ...) (with-syntax (((inst ...) (map (lambda (x) (datum->syntax #'macro x)) (instruction-list)))) #'(begin (macro arg ... . inst) ...))))))) (visit-opcodes define-assembler) ;; Shuffling is a general mechanism to get around address space ;; limitations for SP-relative variable references. FP-relative ;; variables need special support. Also, some instructions like `mov' ;; have multiple variations with different addressing limits. (define (emit-mov* asm dst src) (if (and (< dst (ash 1 12)) (< src (ash 1 12))) (emit-mov asm dst src) (emit-long-mov asm dst src))) (define (emit-fmov* asm dst src) (emit-long-fmov asm dst src)) (define (emit-receive* asm dst proc nlocals) (if (and (< dst (ash 1 12)) (< proc (ash 1 12))) (emit-receive asm dst proc nlocals) (begin (emit-receive-values asm proc #t 1) (emit-fmov* asm dst (1+ proc)) (emit-reset-frame asm nlocals)))) (define (emit-throw/value* asm val param) (emit-throw/value asm val (intern-non-immediate asm param))) (define (emit-throw/value+data* asm val param) (emit-throw/value+data asm val (intern-non-immediate asm param))) (define (emit-instrument-entry* asm) (let ((meta (car (asm-meta asm)))) (emit-instrument-entry asm (meta-jit-data-label meta)))) (define (emit-instrument-loop* asm) (let ((meta (car (asm-meta asm)))) (emit-instrument-loop asm (meta-jit-data-label meta)))) (define (emit-text asm instructions) "Assemble @var{instructions} using the assembler @var{asm}. @var{instructions} is a sequence of instructions, expressed as a list of lists. This procedure can be called many times before calling @code{link-assembly}." (for-each (lambda (inst) (apply (or (hashq-ref assemblers (car inst)) (error 'bad-instruction inst)) asm (cdr inst))) instructions)) ;;; ;;; The constant table records a topologically sorted set of literal ;;; constants used by a program. For example, a pair uses its car and ;;; cdr, a string uses its stringbuf, etc. ;;; ;;; Some things we want to add to the constant table are not actually ;;; Scheme objects: for example, stringbufs, cache cells for toplevel ;;; references, or cache cells for non-closure procedures. For these we ;;; define special record types and add instances of those record types ;;; to the table. ;;; (define-record-type <stringbuf> (make-stringbuf string) stringbuf? (string stringbuf-string)) (define-record-type <static-procedure> (make-static-procedure code) static-procedure? (code static-procedure-code)) (define-record-type <uniform-vector-backing-store> (make-uniform-vector-backing-store bytes element-size) uniform-vector-backing-store? (bytes uniform-vector-backing-store-bytes) (element-size uniform-vector-backing-store-element-size)) (define-record-type <cache-cell> (make-cache-cell key) cache-cell? (key cache-cell-key)) (define (simple-vector? obj) (and (vector? obj) (equal? (array-shape obj) (list (list 0 (1- (vector-length obj))))))) (define (simple-uniform-vector? obj) (and (array? obj) (symbol? (array-type obj)) (match (array-shape obj) (((0 n)) #t) (else #f)))) (define (statically-allocatable? x) "Return @code{#t} if a non-immediate constant can be allocated statically, and @code{#f} if it would need some kind of runtime allocation." (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) (array? x) (syntax? x))) (define (intern-constant asm obj) "Add an object to the constant table, and return a label that can be used to reference it. If the object is already present in the constant table, its existing label is used directly." (define (recur obj) (intern-constant asm obj)) (define (add-desc! label desc) (set-asm-inits! asm (vhash-consq label desc (asm-inits asm)))) (define (init-descriptor obj) (let ((label (recur obj))) (cond ((not label) #f) ((vhash-assq label (asm-inits asm)) => cdr) (else (let ((desc (vector #f #t '()))) (add-desc! label desc) desc))))) (define (add-patch! dst field obj) (match (init-descriptor obj) (#f #f) ((and desc #(emit-init emit-load patches)) (vector-set! desc 2 (acons dst field patches))))) (define (add-init! dst init) (add-desc! dst (vector init #f '()))) (define (intern! obj label) (define (patch! field obj) (add-patch! label field obj)) (define (init! emit-init) (add-init! label emit-init)) (cond ((pair? obj) (patch! 0 (car obj)) (patch! 1 (cdr obj))) ((simple-vector? obj) (let lp ((i 0)) (when (< i (vector-length obj)) (patch! (1+ i) (vector-ref obj i)) (lp (1+ i))))) ((syntax? obj) (patch! 1 (syntax-expression obj)) (patch! 2 (syntax-wrap obj)) (patch! 3 (syntax-module obj)) (patch! 4 (syntax-sourcev obj))) ((stringbuf? obj)) ((static-procedure? obj) ;; Special case, as we can't load the procedure's code using ;; make-non-immediate. (let* ((code (static-procedure-code obj)) (init (lambda (asm label) (emit-static-patch! asm label 1 code) #f))) (add-desc! label (vector init #t '())))) ((cache-cell? obj)) ((symbol? obj) (unless (symbol-interned? obj) (error "uninterned symbol cannot be saved to object file" obj)) (let ((str-label (recur (symbol->string obj)))) (init! (lambda (asm label) (emit-make-non-immediate asm 1 str-label) (emit-string->symbol asm 1 1) (emit-static-set! asm 1 label 0) 1)))) ((string? obj) (patch! 1 (make-stringbuf obj))) ((keyword? obj) (let ((sym-label (recur (keyword->symbol obj)))) (init! (lambda (asm label) (emit-static-ref asm 1 sym-label) (emit-symbol->keyword asm 1 1) (emit-static-set! asm 1 label 0) 1)))) ((number? obj) (let ((str-label (recur (number->string obj)))) (init! (lambda (asm label) (emit-make-non-immediate asm 1 str-label) (emit-string->number asm 1 1) (emit-static-set! asm 1 label 0) 1)))) ((uniform-vector-backing-store? obj)) ((simple-uniform-vector? obj) (let ((width (case (array-type obj) ((vu8 u8 s8) 1) ((u16 s16) 2) ;; Bitvectors are addressed in 32-bit units. ;; Although a complex number is 8 or 16 bytes wide, ;; it should be byteswapped in 4 or 8 byte units. ((u32 s32 f32 c32 b) 4) ((u64 s64 f64 c64) 8) (else (error "unhandled array type" obj))))) (patch! 2 (make-uniform-vector-backing-store (uniform-array->bytevector obj) width)))) ((array? obj) (patch! 1 (shared-array-root obj))) (else (error "don't know how to intern" obj)))) (cond ((immediate-bits asm obj) #f) ((vhash-assoc obj (asm-constants asm)) => cdr) (else (let ((label (gensym "constant"))) ;; Note that calling intern may mutate asm-constants and asm-inits. (intern! obj label) (set-asm-constants! asm (vhash-cons obj label (asm-constants asm))) label)))) (define (intern-non-immediate asm obj) "Intern a non-immediate into the constant table, and return its label." (when (immediate-bits asm obj) (error "expected a non-immediate" obj)) (intern-constant asm obj)) (define (intern-cache-cell asm key) "Intern a cache cell into the constant table, and return its label. If there is already a cache cell with the given scope and key, it is returned instead." (intern-constant asm (make-cache-cell key))) ;;; ;;; Macro assemblers bridge the gap between primitive instructions and ;;; some higher-level operations. ;;; (eval-when (expand) (define-syntax define-macro-assembler (lambda (x) (syntax-case x () ((_ (name arg ...) body body* ...) (with-syntax ((emit (id-append #'name #'emit- #'name))) #'(begin (define emit (let ((emit (lambda (arg ...) body body* ...))) (hashq-set! assemblers 'name emit) emit)) (export emit)))))))) (define-macro-assembler (load-constant asm dst obj) (cond ((scm->immediate-bits obj) => (lambda (bits) (cond ((and (< dst 256) (truncate-bits bits 16 #t)) (emit-make-immediate asm dst obj)) ((and (< dst 256) (truncate-bits bits 16 #f)) (emit-make-short-immediate asm dst obj)) ((truncate-bits bits 32 (eqv? (asm-word-size asm) 4)) (emit-make-long-immediate asm dst obj)) ((and (eqv? (asm-word-size asm) 8) (truncate-bits bits 64 #t)) (emit-make-long-long-immediate asm dst obj)) (else (emit-static-ref asm dst (intern-non-immediate asm obj)))))) ((statically-allocatable? obj) (emit-make-non-immediate asm dst (intern-non-immediate asm obj))) (else (emit-static-ref asm dst (intern-non-immediate asm obj))))) (define-macro-assembler (load-static-procedure asm dst label) (let ((loc (intern-constant asm (make-static-procedure label)))) (emit-make-non-immediate asm dst loc))) (define-syntax define-immediate-tag=?-macro-assembler (syntax-rules () ((_ name #f mask tag) #f) ((_ name pred mask tag) (define-macro-assembler (pred asm slot) (emit-immediate-tag=? asm slot mask tag))))) (visit-immediate-tags define-immediate-tag=?-macro-assembler) (define-syntax-rule (define-heap-tag=?-macro-assembler name pred mask tag) (define-macro-assembler (pred asm slot) (emit-heap-tag=? asm slot mask tag))) (visit-heap-tags define-heap-tag=?-macro-assembler) (define-syntax-rule (define-scm<-scm-scm-intrinsic name) (define-macro-assembler (name asm dst a b) (emit-call-scm<-scm-scm asm dst a b (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-scm-uimm-intrinsic name) (define-macro-assembler (name asm dst a b) (emit-call-scm<-scm-uimm asm dst a b (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm-sz-u32-intrinsic name) (define-macro-assembler (name asm a b c) (emit-call-scm-sz-u32 asm a b c (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-scm<-scm asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-f64<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-f64<-scm asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-f64<-f64-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-f64<-f64 asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-f64<-f64-f64-intrinsic name) (define-macro-assembler (name asm dst a b) (emit-call-f64<-f64-f64 asm dst a b (intrinsic-name->index 'name)))) (define-syntax-rule (define-u64<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-u64<-scm asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-s64<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-s64<-scm asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-u64-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-scm<-u64 asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-s64-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-scm<-s64 asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-thread-intrinsic name) (define-macro-assembler (name asm) (emit-call-thread asm (intrinsic-name->index 'name)))) (define-syntax-rule (define-thread-scm-intrinsic name) (define-macro-assembler (name asm a) (emit-call-thread-scm asm a (intrinsic-name->index 'name)))) (define-syntax-rule (define-thread-scm-scm-intrinsic name) (define-macro-assembler (name asm a b) (emit-call-thread-scm-scm asm a b (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-thread-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-scm<-thread-scm asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-scm-u64-intrinsic name) (define-macro-assembler (name asm dst a b) (emit-call-scm<-scm-u64 asm dst a b (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-scm-bool-intrinsic name) (define-macro-assembler (name asm dst a b) (emit-call-scm<-scm-uimm asm dst a (if b 1 0) (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-thread-intrinsic name) (define-macro-assembler (name asm dst) (emit-call-scm<-thread asm dst (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm-scm-intrinsic name) (define-macro-assembler (name asm a b) (emit-call-scm-scm asm a b (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm-uimm-scm-intrinsic name) (define-macro-assembler (name asm a b c) (emit-call-scm-uimm-scm asm a b c (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm-scm-scm-intrinsic name) (define-macro-assembler (name asm a b c) (emit-call-scm-scm-scm asm a b c (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-scmn-scmn-intrinsic name) (define-macro-assembler (name asm dst a b) (unless (statically-allocatable? a) (error "not statically allocatable" a)) (unless (statically-allocatable? b) (error "not statically allocatable" b)) (let ((a (intern-constant asm a)) (b (intern-constant asm b))) (emit-call-scm<-scmn-scmn asm dst a b (intrinsic-name->index 'name))))) (define-scm<-scm-scm-intrinsic add) (define-scm<-scm-uimm-intrinsic add/immediate) (define-scm<-scm-scm-intrinsic sub) (define-scm<-scm-uimm-intrinsic sub/immediate) (define-scm<-scm-scm-intrinsic mul) (define-scm<-scm-scm-intrinsic div) (define-scm<-scm-scm-intrinsic quo) (define-scm<-scm-scm-intrinsic rem) (define-scm<-scm-scm-intrinsic mod) (define-scm<-scm-intrinsic inexact) (define-scm<-scm-intrinsic abs) (define-scm<-scm-intrinsic sqrt) (define-scm<-scm-intrinsic floor) (define-scm<-scm-intrinsic ceiling) (define-scm<-scm-intrinsic sin) (define-scm<-scm-intrinsic cos) (define-scm<-scm-intrinsic tan) (define-scm<-scm-intrinsic asin) (define-scm<-scm-intrinsic acos) (define-scm<-scm-intrinsic atan) (define-scm<-scm-scm-intrinsic atan2) (define-f64<-f64-intrinsic fabs) (define-f64<-f64-intrinsic fsqrt) (define-f64<-f64-intrinsic ffloor) (define-f64<-f64-intrinsic fceiling) (define-f64<-f64-intrinsic fsin) (define-f64<-f64-intrinsic fcos) (define-f64<-f64-intrinsic ftan) (define-f64<-f64-intrinsic fasin) (define-f64<-f64-intrinsic facos) (define-f64<-f64-intrinsic fatan) (define-f64<-f64-f64-intrinsic fatan2) (define-scm<-scm-scm-intrinsic logand) (define-scm<-scm-scm-intrinsic logior) (define-scm<-scm-scm-intrinsic logxor) (define-scm<-scm-scm-intrinsic logsub) (define-scm-sz-u32-intrinsic string-set!) (define-scm<-scm-intrinsic string->number) (define-scm<-scm-intrinsic string->symbol) (define-scm<-scm-intrinsic symbol->keyword) (define-scm<-scm-intrinsic class-of) (define-f64<-scm-intrinsic scm->f64) (define-u64<-scm-intrinsic scm->u64) (define-u64<-scm-intrinsic scm->u64/truncate) (define-s64<-scm-intrinsic scm->s64) (define-scm<-u64-intrinsic u64->scm) (define-scm<-s64-intrinsic s64->scm) (define-thread-scm-scm-intrinsic wind) (define-thread-intrinsic unwind) (define-thread-scm-scm-intrinsic push-fluid) (define-thread-intrinsic pop-fluid) (define-scm<-thread-scm-intrinsic fluid-ref) (define-thread-scm-scm-intrinsic fluid-set!) (define-thread-scm-intrinsic push-dynamic-state) (define-thread-intrinsic pop-dynamic-state) (define-scm<-scm-u64-intrinsic lsh) (define-scm<-scm-u64-intrinsic rsh) (define-scm<-scm-uimm-intrinsic lsh/immediate) (define-scm<-scm-uimm-intrinsic rsh/immediate) (define-scm<-scm-bool-intrinsic resolve-module) (define-scm<-scm-scm-intrinsic module-variable) (define-scm<-scm-scm-intrinsic lookup) (define-scm<-scm-scm-intrinsic lookup-bound) (define-scm<-scmn-scmn-intrinsic lookup-bound-public) (define-scm<-scmn-scmn-intrinsic lookup-bound-private) (define-scm<-scm-scm-intrinsic define!) (define-scm<-thread-intrinsic current-module) (define-scm<-scm-intrinsic $car) (define-scm<-scm-intrinsic $cdr) (define-scm-scm-intrinsic $set-car!) (define-scm-scm-intrinsic $set-cdr!) (define-scm<-scm-intrinsic $variable-ref) (define-scm-scm-intrinsic $variable-set!) (define-scm<-scm-intrinsic $vector-length) (define-scm<-scm-scm-intrinsic $vector-ref) (define-scm-scm-scm-intrinsic $vector-set!) (define-scm<-scm-uimm-intrinsic $vector-ref/immediate) (define-scm-uimm-scm-intrinsic $vector-set!/immediate) (define-scm<-scm-scm-intrinsic $allocate-struct) (define-scm<-scm-intrinsic $struct-vtable) (define-scm<-scm-scm-intrinsic $struct-ref) (define-scm-scm-scm-intrinsic $struct-set!) (define-scm<-scm-uimm-intrinsic $struct-ref/immediate) (define-scm-uimm-scm-intrinsic $struct-set!/immediate) (define-macro-assembler (begin-program asm label properties) (emit-label asm label) (let ((meta (make-meta label properties (asm-start asm)))) (set-asm-meta! asm (cons meta (asm-meta asm)))) (emit-instrument-entry* asm)) (define-macro-assembler (end-program asm) (let ((meta (car (asm-meta asm)))) (set-meta-high-pc! meta (asm-start asm)) (set-meta-arities! meta (reverse (meta-arities meta))) (set-asm-constants! asm (vhash-cons (make-jit-data (meta-low-pc meta) (meta-high-pc meta)) (meta-jit-data-label meta) (asm-constants asm))))) (define-macro-assembler (begin-standard-arity asm has-closure? req nlocals alternate) (emit-begin-opt-arity asm has-closure? req '() #f nlocals alternate)) (define-macro-assembler (begin-opt-arity asm has-closure? req opt rest nlocals alternate) (emit-begin-kw-arity asm has-closure? req opt rest '() #f nlocals alternate)) (define-macro-assembler (begin-kw-arity asm has-closure? req opt rest kw-indices allow-other-keys? nlocals alternate) (assert-match req ((? symbol?) ...) "list of symbols") (assert-match opt ((? symbol?) ...) "list of symbols") (assert-match rest (or #f (? symbol?)) "#f or symbol") (assert-match kw-indices (((? keyword?) . (? integer?)) ...) "alist of keyword -> integer") (assert-match allow-other-keys? (? boolean?) "boolean") (assert-match nlocals (? integer?) "integer") (assert-match alternate (or #f (? exact-integer?) (? symbol?)) "#f or symbol") (let* ((meta (car (asm-meta asm))) (arity (make-arity req opt rest kw-indices allow-other-keys? has-closure? ;; Include the initial instrument-entry in ;; the first arity. (if (null? (meta-arities meta)) (meta-low-pc meta) (asm-start asm)) #f '())) ;; The procedure itself is in slot 0, in the standard calling ;; convention. For procedure prologues, nreq includes the ;; procedure, so here we add 1. (nclosure (if has-closure? 1 0)) (nreq (+ nclosure (length req))) (nopt (length opt)) (rest? (->bool rest))) (set-meta-arities! meta (cons arity (meta-arities meta))) (cond ((or allow-other-keys? (pair? kw-indices)) (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? nlocals alternate)) ((or rest? (pair? opt)) (emit-opt-prelude asm nreq nopt rest? nlocals alternate)) (else (emit-standard-prelude asm nreq nlocals alternate))))) (define-macro-assembler (begin-unchecked-arity asm has-closure? req nlocals) (assert-match req ((? symbol?) ...) "list of symbols") (assert-match nlocals (? integer?) "integer") (let* ((meta (car (asm-meta asm))) (arity (make-arity req '() #f '() #f has-closure? (meta-low-pc meta) #f '())) (nclosure (if has-closure? 1 0)) (nreq (+ nclosure (length req)))) (set-meta-arities! meta (cons arity (meta-arities meta))) (emit-unchecked-prelude asm nreq nlocals))) (define-macro-assembler (end-arity asm) (let ((arity (car (meta-arities (car (asm-meta asm)))))) (set-arity-definitions! arity (reverse (arity-definitions arity))) (set-arity-high-pc! arity (asm-start asm)))) (define-macro-assembler (unchecked-prelude asm nreq nlocals) (unless (= nlocals nreq) (emit-alloc-frame asm nlocals))) (define-macro-assembler (standard-prelude asm nreq nlocals alternate) (cond (alternate (emit-arguments<=? asm nreq) (emit-jne asm alternate) (emit-alloc-frame asm nlocals)) ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12))) (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq))) (else (emit-assert-nargs-ee asm nreq) (emit-alloc-frame asm nlocals)))) (define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate) (if alternate (begin (emit-arguments<=? asm nreq) (emit-jl asm alternate)) (emit-assert-nargs-ge asm nreq)) (cond (rest? (unless (zero? nopt) (emit-bind-optionals asm (+ nreq nopt))) (emit-bind-rest asm (+ nreq nopt))) (alternate (emit-arguments<=? asm (+ nreq nopt)) ;; The arguments<=? instruction sets NONE to indicate greater-than, ;; whereas for <, NONE usually indicates greater-than-or-equal, ;; hence the name jge. Perhaps we just need to rename jge to ;; br-if-none. (emit-jge asm alternate) (unless (zero? nopt) (emit-bind-optionals asm (+ nreq nopt)))) (else (emit-assert-nargs-le asm (+ nreq nopt)) (unless (zero? nopt) (emit-bind-optionals asm (+ nreq nopt))))) (emit-alloc-frame asm nlocals)) (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? nlocals alternate) (if alternate (begin (emit-arguments<=? asm nreq) (emit-jl asm alternate) (unless rest? (emit-positional-arguments<=? asm nreq (+ nreq nopt)) (emit-jge asm alternate))) (emit-assert-nargs-ge asm nreq)) (let ((ntotal (fold (lambda (kw ntotal) (match kw (((? keyword?) . idx) (max (1+ idx) ntotal)))) (+ nreq nopt) kw-indices))) ;; FIXME: port 581f410f (emit-bind-kwargs asm nreq (pack-flags allow-other-keys? rest?) (+ nreq nopt) ntotal (intern-constant asm kw-indices)) (emit-alloc-frame asm nlocals))) (define-macro-assembler (label asm sym) (hashq-set! (asm-labels asm) sym (asm-start asm))) (define-macro-assembler (source asm source) (set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm)))) (define-macro-assembler (definition asm name slot representation) (let* ((arity (car (meta-arities (car (asm-meta asm))))) (def (vector name slot representation (- (asm-start asm) (arity-low-pc arity))))) (set-arity-definitions! arity (cons def (arity-definitions arity))))) (define-macro-assembler (cache-ref asm dst key) (emit-static-ref asm dst (intern-cache-cell asm key))) (define-macro-assembler (cache-set! asm key val) (emit-static-set! asm val (intern-cache-cell asm key) 0)) (define-macro-assembler (slot-map asm proc-slot slot-map) (unless (zero? slot-map) (set-asm-slot-maps! asm (cons (cons* (asm-start asm) proc-slot slot-map) (asm-slot-maps asm))))) ;;; ;;; Helper for linking objects. ;;; (define (make-object asm name bv relocs labels . kwargs) "Make a linker object. This helper handles interning the name in the shstrtab, assigning the size, allocating a fresh index, and defining a corresponding linker symbol for the start of the section." (let ((name-idx (intern-section-name! asm (symbol->string name))) (index (asm-next-section-number asm))) (set-asm-next-section-number! asm (1+ index)) (make-linker-object (symbol->string name) (apply make-elf-section #:index index #:name name-idx #:size (bytevector-length bv) kwargs) bv relocs (cons (make-linker-symbol name 0) labels)))) ;;; ;;; Linking the constant table. This code is somewhat intertwingled ;;; with the intern-constant code above, as that procedure also ;;; residualizes instructions to initialize constants at load time. ;;; (define (write-immediate asm buf pos bits) (let ((endianness (asm-endianness asm))) (case (asm-word-size asm) ((4) (bytevector-u32-set! buf pos bits endianness)) ((8) (bytevector-u64-set! buf pos bits endianness)) (else (error "bad word size" asm))))) (define (write-placeholder asm buf pos) (write-immediate asm buf pos (immediate-bits asm #f))) (define (emit-init-constants asm) "If there is writable data that needs initialization at runtime, emit a procedure to do that and return its label. Otherwise return @code{#f}." (let* ((inits (asm-inits asm))) (and (not (vlist-null? inits)) (let ((label (gensym "init-constants"))) (emit-begin-program asm label '()) (emit-assert-nargs-ee/locals asm 1 1) (let lp ((n (1- (vlist-length inits)))) (match (vlist-ref inits n) ((label . #(#f #t ((dst . field)))) ;; Special case in which emit-static-patch is actually ;; an optimization. (emit-static-patch! asm dst field label)) ((label . #(emit-init static? patches)) (let ((slot-from-init (and emit-init (emit-init asm label)))) (unless (null? patches) (let ((slot (or slot-from-init (begin (if static? (emit-make-non-immediate asm 1 label) (emit-static-ref asm 1 label)) 1)))) (for-each (match-lambda ((dst . offset) (emit-static-set! asm slot dst offset))) patches)))))) (unless (zero? n) (lp (1- n)))) (emit-reset-frame asm 1) (emit-load-constant asm 0 *unspecified*) (emit-return-values asm) (emit-end-program asm) label)))) (define (link-data asm data name) "Link the static data for a program into the @var{name} section (which should be .data or .rodata), and return the resulting linker object. @var{data} should be a vhash mapping objects to labels." (define (align address alignment) (+ address (modulo (- alignment (modulo address alignment)) alignment))) (define tc7-vector #x0d) (define vector-immutable-flag #x80) (define tc7-string #x15) (define string-read-only-flag #x200) (define tc7-stringbuf #x27) (define stringbuf-wide-flag #x400) (define tc7-syntax #x3d) (define syntax-has-source-flag #x100) (define tc7-program #x45) (define tc7-bytevector #x4d) ;; This flag is intended to be left-shifted by 7 bits. (define bytevector-immutable-flag #x200) (define tc7-array #x5d) (define tc7-bitvector #x5f) (define bitvector-immutable-flag #x80) (let ((word-size (asm-word-size asm)) (endianness (asm-endianness asm))) (define (byte-length x) (cond ((stringbuf? x) (let ((x (stringbuf-string x))) (+ (* 2 word-size) (case (string-bytes-per-char x) ((1) (1+ (string-length x))) ((4) (* (1+ (string-length x)) 4)) (else (error "bad string bytes per char" x)))))) ((static-procedure? x) (* 2 word-size)) ((string? x) (* 4 word-size)) ((pair? x) (* 2 word-size)) ((simple-vector? x) (* (1+ (vector-length x)) word-size)) ((syntax? x) (* 5 word-size)) ((jit-data? x) (case word-size ((4) (+ word-size (* 4 3))) ((8) (+ word-size (* 4 4))) ;; One additional uint32_t for padding. (else (error word-size)))) ((simple-uniform-vector? x) (* 4 word-size)) ((uniform-vector-backing-store? x) (bytevector-length (uniform-vector-backing-store-bytes x))) ((array? x) (* word-size (+ 3 (* 3 (array-rank x))))) (else word-size))) (define (write-constant-reference buf pos x) (let ((bits (immediate-bits asm x))) (if bits (write-immediate asm buf pos bits) ;; The asm-inits will fix up any reference to a ;; non-immediate. (write-placeholder asm buf pos)))) (define (write buf pos obj) (cond ((stringbuf? obj) (let* ((x (stringbuf-string obj)) (len (string-length x)) (tag (logior tc7-stringbuf (if (= (string-bytes-per-char x) 1) 0 stringbuf-wide-flag)))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness) (bytevector-u32-set! buf (+ pos 4) len endianness)) ((8) (bytevector-u64-set! buf pos tag endianness) (bytevector-u64-set! buf (+ pos 8) len endianness)) (else (error "bad word size" asm))) (let ((pos (+ pos (* word-size 2)))) (case (string-bytes-per-char x) ((1) (let lp ((i 0)) (if (< i len) (let ((u8 (char->integer (string-ref x i)))) (bytevector-u8-set! buf (+ pos i) u8) (lp (1+ i))) (bytevector-u8-set! buf (+ pos i) 0)))) ((4) (let lp ((i 0)) (if (< i len) (let ((u32 (char->integer (string-ref x i)))) (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness) (lp (1+ i))) (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness)))) (else (error "bad string bytes per char" x)))))) ((static-procedure? obj) (case word-size ((4) (bytevector-u32-set! buf pos tc7-program endianness) (bytevector-u32-set! buf (+ pos 4) 0 endianness)) ((8) (bytevector-u64-set! buf pos tc7-program endianness) (bytevector-u64-set! buf (+ pos 8) 0 endianness)) (else (error "bad word size")))) ((cache-cell? obj) (write-placeholder asm buf pos)) ((jit-data? obj) ;; Default initialization of 0. (values)) ((string? obj) (let ((tag (logior tc7-string string-read-only-flag))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness) (write-placeholder asm buf (+ pos 4)) ; stringbuf (bytevector-u32-set! buf (+ pos 8) 0 endianness) (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness)) ((8) (bytevector-u64-set! buf pos tag endianness) (write-placeholder asm buf (+ pos 8)) ; stringbuf (bytevector-u64-set! buf (+ pos 16) 0 endianness) (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness)) (else (error "bad word size"))))) ((pair? obj) (write-constant-reference buf pos (car obj)) (write-constant-reference buf (+ pos word-size) (cdr obj))) ((simple-vector? obj) (let* ((len (vector-length obj)) (tag (logior tc7-vector vector-immutable-flag (ash len 8)))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness)) ((8) (bytevector-u64-set! buf pos tag endianness)) (else (error "bad word size"))) (let lp ((i 0)) (when (< i (vector-length obj)) (let ((pos (+ pos word-size (* i word-size))) (elt (vector-ref obj i))) (write-constant-reference buf pos elt) (lp (1+ i))))))) ((symbol? obj) (write-placeholder asm buf pos)) ((keyword? obj) (write-placeholder asm buf pos)) ((syntax? obj) (let ((tag (logior tc7-syntax syntax-has-source-flag))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness)) ((8) (bytevector-u64-set! buf pos tag endianness)) (else (error "bad word size")))) (write-constant-reference buf (+ pos (* 1 word-size)) (syntax-expression obj)) (write-constant-reference buf (+ pos (* 2 word-size)) (syntax-wrap obj)) (write-constant-reference buf (+ pos (* 3 word-size)) (syntax-module obj)) (write-constant-reference buf (+ pos (* 4 word-size)) (syntax-sourcev obj))) ((number? obj) (write-placeholder asm buf pos)) ((simple-uniform-vector? obj) (let ((tag (if (bitvector? obj) (logior tc7-bitvector bitvector-immutable-flag) (logior tc7-bytevector ;; Bytevector immutable flag also shifted ;; left. (ash (logior bytevector-immutable-flag (array-type-code obj)) 7))))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness) (bytevector-u32-set! buf (+ pos 4) (if (bitvector? obj) (bitvector-length obj) (bytevector-length obj)) endianness) ; length (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer (write-placeholder asm buf (+ pos 12))) ; owner ((8) (bytevector-u64-set! buf pos tag endianness) (bytevector-u64-set! buf (+ pos 8) (if (bitvector? obj) (bitvector-length obj) (bytevector-length obj)) endianness) ; length (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer (write-placeholder asm buf (+ pos 24))) ; owner (else (error "bad word size"))))) ((uniform-vector-backing-store? obj) (let ((bv (uniform-vector-backing-store-bytes obj))) (bytevector-copy! bv 0 buf pos (bytevector-length bv)) (unless (eq? endianness (native-endianness)) (case (uniform-vector-backing-store-element-size obj) ((1) #f) ;; Nothing to do. ((2) (byte-swap/2! buf pos (+ pos (bytevector-length bv)))) ((4) (byte-swap/4! buf pos (+ pos (bytevector-length bv)))) ((8) (byte-swap/8! buf pos (+ pos (bytevector-length bv)))) (else (error "FIXME: Implement byte order swap")))))) ((array? obj) (let-values ;; array tag + rank + contp flag: see libguile/arrays.h . (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16))) ((bv-set! bvs-set!) (case word-size ((4) (values bytevector-u32-set! bytevector-s32-set!)) ((8) (values bytevector-u64-set! bytevector-s64-set!)) (else (error "bad word size"))))) (bv-set! buf pos tag endianness) (write-placeholder asm buf (+ pos word-size)) ; root vector (fixed later) (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base (let lp ((pos (+ pos (* word-size 3))) (bounds (array-shape obj)) (incs (shared-array-increments obj))) (when (pair? bounds) (bvs-set! buf pos (first (first bounds)) endianness) (bvs-set! buf (+ pos word-size) (second (first bounds)) endianness) (bvs-set! buf (+ pos (* word-size 2)) (first incs) endianness) (lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs)))))) (else (error "unrecognized object" obj)))) (define (add-relocs obj pos relocs) (match obj (($ <jit-data> low-pc high-pc) ;; Patch "start" and "end" fields of "struct jit_data". (cons* (make-linker-reloc 'rel32/1 (+ pos word-size 4) (+ low-pc word-size 4) '.rtl-text) (make-linker-reloc 'rel32/1 (+ pos word-size 8) (+ high-pc word-size 8) '.rtl-text) relocs)) (_ relocs))) (cond ((vlist-null? data) #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))) (let lp ((i 0) (pos 0) (relocs '()) (symbols '())) (if (< i (vlist-length data)) (match (vlist-ref data i) ((obj . obj-label) (write buf pos obj) (lp (1+ i) (align (+ (byte-length obj) pos) 8) (add-relocs obj pos relocs) (cons (make-linker-symbol obj-label pos) symbols)))) (make-object asm name buf relocs symbols #:flags (match name ('.data (logior SHF_ALLOC SHF_WRITE)) ('.rodata SHF_ALLOC)))))))))) (define (link-constants asm) "Link sections to hold constants needed by the program text emitted using @var{asm}. Returns three values: an object for the .rodata section, an object for the .data section, and a label for an initialization procedure. Any of these may be @code{#f}." (define (shareable? x) (cond ((stringbuf? x) #t) ((pair? x) (and (immediate-bits asm (car x)) (immediate-bits asm (cdr x)))) ((simple-vector? x) (let lp ((i 0)) (or (= i (vector-length x)) (and (immediate-bits asm (vector-ref x i)) (lp (1+ i)))))) ((uniform-vector-backing-store? x) #t) (else #f))) (let* ((init-constants (emit-init-constants asm)) (constants (asm-constants asm)) (len (vlist-length constants))) (let lp ((i 0) (ro vlist-null) (rw vlist-null)) (if (= i len) (values (link-data asm ro '.rodata) (link-data asm rw '.data) init-constants) (match (vlist-ref constants i) ((obj . label) (if (shareable? obj) (lp (1+ i) (vhash-consq obj label ro) rw) (lp (1+ i) ro (vhash-consq obj label rw))))))))) ;;; ;;; Linking program text. ;;; (define (process-relocs buf relocs labels) "Patch up internal x8-s24 relocations, and any s32 relocations that reference symbols in the text section. Return a list of linker relocations for references to symbols defined outside the text section." (fold (lambda (reloc tail) (match reloc ((type label base offset) (let ((abs (hashq-ref labels label)) (dst (+ base offset))) (case type ((s32) (if abs (let ((rel (- abs base))) (unless (zero? (logand rel #x3)) (error "reloc not in 32-bit units!")) (bytevector-s32-native-set! buf dst (ash rel -2)) tail) (cons (make-linker-reloc 'rel32/4 dst offset label) tail))) ((x8-s24) (unless abs (error "unbound near relocation" reloc)) (let ((rel (- abs base)) (u32 (bytevector-u32-native-ref buf dst))) (unless (zero? (logand rel #x3)) (error "reloc not in 32-bit units!")) (bytevector-u32-native-set! buf dst (pack-u8-s24 (logand u32 #xff) (ash rel -2))) tail)) (else (error "bad relocation kind" reloc))))))) '() relocs)) (define (process-labels labels) "Define linker symbols for the label-offset map in @var{labels}. The offsets are expected to be expressed in words." (hash-map->list (lambda (label loc) (make-linker-symbol label loc)) labels)) (define (link-text-object asm) "Link the .rtl-text section, swapping the endianness of the bytes if needed." (let ((buf (make-bytevector (asm-pos asm)))) (bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf)) (unless (eq? (asm-endianness asm) (native-endianness)) (byte-swap/4! buf)) (make-object asm '.rtl-text buf (process-relocs buf (asm-relocs asm) (asm-labels asm)) (process-labels (asm-labels asm))))) ;;; ;;; Create the frame maps. These maps are used by GC to identify dead ;;; slots in pending call frames, to avoid marking them. We only do ;;; this when frame makes a non-tail call, as that is the common case. ;;; Only the topmost frame will see a GC at any other point, but we mark ;;; top frames conservatively as serializing live slot maps at every ;;; instruction would take up too much space in the object file. ;;; ;; The .guile.frame-maps section starts with two packed u32 values: one ;; indicating the offset of the first byte of the .rtl-text section, and ;; another indicating the relative offset in bytes of the slots data. (define frame-maps-prefix-len 8) ;; Each header is 8 bytes: 4 for the offset from .rtl_text, and 4 for ;; the offset of the slot map from the beginning of the ;; .guile.frame-maps section. The length of a frame map depends on the ;; frame size at the call site, and is not encoded into this section as ;; it is available at run-time. (define frame-map-header-len 8) (define (link-frame-maps asm) (define (map-byte-length proc-slot) (ceiling-quotient (* 2 (- proc-slot 2)) 8)) (define (make-frame-maps maps count map-len) (let* ((endianness (asm-endianness asm)) (header-pos frame-maps-prefix-len) (map-pos (+ header-pos (* count frame-map-header-len))) (bv (make-bytevector (+ map-pos map-len) 0))) (bytevector-u32-set! bv 4 map-pos endianness) (let lp ((maps maps) (header-pos header-pos) (map-pos map-pos)) (match maps (() (make-object asm '.guile.frame-maps bv (list (make-linker-reloc 'abs32/1 0 0 '.rtl-text)) '() #:type SHT_PROGBITS #:flags SHF_ALLOC)) (((pos proc-slot . map) . maps) (bytevector-u32-set! bv header-pos pos endianness) (bytevector-u32-set! bv (+ header-pos 4) map-pos endianness) (let write-bytes ((map-pos map-pos) (map map) (byte-length (map-byte-length proc-slot))) (if (zero? byte-length) (lp maps (+ header-pos frame-map-header-len) map-pos) (begin (bytevector-u8-set! bv map-pos (logand map #xff)) (write-bytes (1+ map-pos) (ash map -8) (1- byte-length)))))))))) (match (asm-slot-maps asm) (() #f) (in (let lp ((in in) (out '()) (count 0) (map-len 0)) (match in (() (make-frame-maps out count map-len)) (((and head (pos proc-slot . map)) . in) (lp in (cons head out) (1+ count) (+ (map-byte-length proc-slot) map-len)))))))) ;;; ;;; Linking other sections of the ELF file, like the dynamic segment, ;;; the symbol table, etc. ;;; ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0300) (define *bytecode-minor-version* 5) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, given the writable data section @var{rw} needing fixup from the procedure with label @var{rw-init}. @var{rw-init} may be false. If @var{rw} is true, it will be added to the GC roots at runtime." (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type) (let* ((endianness (asm-endianness asm)) (words 6) (words (if rw (+ words 4) words)) (words (if rw-init (+ words 2) words)) (words (if frame-maps (+ words 2) words)) (bv (make-bytevector (* word-size words) 0)) (set-uword! (lambda (i uword) (%set-uword! bv (* i word-size) uword endianness))) (relocs '()) (set-label! (lambda (i label) (set! relocs (cons (make-linker-reloc 'reloc-type (* i word-size) 0 label) relocs)) (%set-uword! bv (* i word-size) 0 endianness)))) (set-uword! 0 DT_GUILE_VM_VERSION) (set-uword! 1 (logior (ash *bytecode-major-version* 16) *bytecode-minor-version*)) (set-uword! 2 DT_GUILE_ENTRY) (set-label! 3 '.rtl-text) (when 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 (linker-object-bv rw))) (when rw-init (set-uword! 8 DT_INIT) ; constants (set-label! 9 rw-init))) (when frame-maps (set-uword! (- words 4) DT_GUILE_FRAME_MAPS) (set-label! (- words 3) '.guile.frame-maps)) (set-uword! (- words 2) DT_NULL) (set-uword! (- words 1) 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-shstrtab asm) "Link the string table for the section headers." (intern-section-name! asm ".shstrtab") (make-object asm '.shstrtab (link-string-table! (asm-shstrtab asm)) '() '() #:type SHT_STRTAB #:flags 0)) (define (link-symtab text-section asm) (let* ((endianness (asm-endianness asm)) (word-size (asm-word-size asm)) (size (elf-symbol-len word-size)) (meta (reverse (asm-meta asm))) (n (length meta)) (strtab (make-string-table)) (bv (make-bytevector (* n size) 0))) (define (intern-string! name) (string-table-intern! strtab (if name (symbol->string name) ""))) (for-each (lambda (meta n) (let ((name (intern-string! (meta-name meta)))) (write-elf-symbol bv (* n size) endianness word-size (make-elf-symbol #:name name ;; Symbol value and size are measured in ;; bytes, not u32s. #:value (meta-low-pc meta) #:size (- (meta-high-pc meta) (meta-low-pc meta)) #:type STT_FUNC #:visibility STV_HIDDEN #:shndx (elf-section-index text-section))))) meta (iota n)) (let ((strtab (make-object asm '.strtab (link-string-table! strtab) '() '() #:type SHT_STRTAB #:flags 0))) (values (make-object asm '.symtab bv '() '() #:type SHT_SYMTAB #:flags 0 #:entsize size #:link (elf-section-index (linker-object-section strtab))) strtab)))) ;;; The .guile.arities section describes the arities that a function can ;;; have. It is in two parts: a sorted array of headers describing ;;; basic arities, and an array of links out to a string table (and in ;;; the case of keyword arguments, to the data section) for argument ;;; names. The whole thing is prefixed by a uint32 indicating the ;;; offset of the end of the headers array. ;;; ;;; The arity headers array is a packed array of structures of the form: ;;; ;;; struct arity_header { ;;; uint32_t low_pc; ;;; uint32_t high_pc; ;;; uint32_t offset; ;;; uint32_t flags; ;;; uint32_t nreq; ;;; uint32_t nopt; ;;; uint32_t nlocals; ;;; } ;;; ;;; All of the offsets and addresses are 32 bits. We can expand in the ;;; future to use 64-bit offsets if appropriate, but there are other ;;; aspects of bytecode that constrain us to a total image that fits in ;;; 32 bits, so for the moment we'll simplify the problem space. ;;; ;;; The following flags values are defined: ;;; ;;; #x1: has-rest? ;;; #x2: allow-other-keys? ;;; #x4: has-keyword-args? ;;; #x8: is-case-lambda? ;;; #x10: is-in-case-lambda? ;;; #x20: elided-closure? ;;; ;;; Functions with a single arity specify their number of required and ;;; optional arguments in nreq and nopt, and do not have the ;;; is-case-lambda? flag set. Their "offset" member links to an array ;;; of pointers into the associated .guile.arities.strtab string table, ;;; identifying the argument names. This offset is relative to the ;;; start of the .guile.arities section. ;;; ;;; If the arity has keyword arguments -- if has-keyword-args? is set in ;;; the flags -- the first uint32 pointed to by offset encodes a link to ;;; the "keyword indices" literal, in the data section. Then follow the ;;; names for all locals, in order, as uleb128 values. The required ;;; arguments will be the first locals, followed by the optionals, ;;; followed by the rest argument if if has-rest? is set. The names ;;; point into the associated string table section. ;;; ;;; Functions with no arities have no arities information present in the ;;; .guile.arities section. ;;; ;;; Functions with multiple arities are preceded by a header with ;;; is-case-lambda? set. All other fields are 0, except low-pc and ;;; high-pc which should be the bounds of the whole function. Headers ;;; for the individual arities follow, with the is-in-case-lambda? flag ;;; set. In this way the whole headers array is sorted in increasing ;;; low-pc order, and case-lambda clauses are contained within the ;;; [low-pc, high-pc] of the case-lambda header. ;;; ;;; Normally the 0th argument is the closure for the function being ;;; called. However if the function is "well-known" -- all of its call ;;; sites are visible -- then the compiler may elide the closure, and ;;; the 0th argument is the first user-visible argument. ;; Length of the prefix to the arities section, in bytes. (define arities-prefix-len 4) ;; Length of an arity header, in bytes. (define arity-header-len (* 7 4)) ;; Some helpers. (define (put-uleb128 port val) (let lp ((val val)) (let ((next (ash val -7))) (if (zero? next) (put-u8 port val) (begin (put-u8 port (logior #x80 (logand val #x7f))) (lp next)))))) (define (put-sleb128 port val) (let lp ((val val)) (if (<= 0 (+ val 64) 127) (put-u8 port (logand val #x7f)) (begin (put-u8 port (logior #x80 (logand val #x7f))) (lp (ash val -7)))))) (define (port-position port) (seek port 0 SEEK_CUR)) (define-inline (pack-arity-flags has-rest? allow-other-keys? has-keyword-args? is-case-lambda? is-in-case-lambda? elided-closure?) (logior (if has-rest? (ash 1 0) 0) (if allow-other-keys? (ash 1 1) 0) (if has-keyword-args? (ash 1 2) 0) (if is-case-lambda? (ash 1 3) 0) (if is-in-case-lambda? (ash 1 4) 0) (if elided-closure? (ash 1 5) 0))) (define (write-arities asm metas headers names-port strtab) (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals) (unless (<= (+ nreq nopt) nlocals) (error "forgot to emit definition instructions?")) (bytevector-u32-set! headers pos low-pc (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 4) high-pc (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm))) (define (write-kw-indices kw-indices relocs) ;; FIXME: Assert that kw-indices is already interned. (if (pair? kw-indices) (let ((pos (+ (bytevector-length headers) (port-position names-port))) (label (intern-constant asm kw-indices))) (put-bytevector names-port #vu8(0 0 0 0)) (cons (make-linker-reloc 'abs32/1 pos 0 label) relocs)) relocs)) (define (write-arity pos arity in-case-lambda? relocs) (write-header pos (arity-low-pc arity) (arity-high-pc arity) ;; FIXME: Seems silly to add on bytevector-length of ;; headers, given the arities-prefix. (+ (bytevector-length headers) (port-position names-port)) (pack-arity-flags (arity-rest arity) (arity-allow-other-keys? arity) (pair? (arity-kw-indices arity)) #f in-case-lambda? (not (arity-has-closure? arity))) (length (arity-req arity)) (length (arity-opt arity)) (length (arity-definitions arity))) (let ((relocs (write-kw-indices (arity-kw-indices arity) relocs))) ;; Write local names. (let lp ((definitions (arity-definitions arity))) (match definitions (() relocs) ((#(name slot representation def) . definitions) (let ((sym (if (symbol? name) (string-table-intern! strtab (symbol->string name)) 0))) (put-uleb128 names-port sym) (lp definitions))))) ;; Now write their definitions. (let lp ((definitions (arity-definitions arity))) (match definitions (() relocs) ((#(name slot representation def) . definitions) (put-uleb128 names-port def) (let ((tag (case representation ((scm) 0) ((f64) 1) ((u64) 2) ((s64) 3) ((ptr) 4) (else (error "what!" representation))))) (put-uleb128 names-port (logior (ash slot 3) tag))) (lp definitions)))))) (let lp ((metas metas) (pos arities-prefix-len) (relocs '())) (match metas (() (unless (= pos (bytevector-length headers)) (error "expected to fully fill the bytevector" pos (bytevector-length headers))) relocs) ((meta . metas) (match (meta-arities meta) (() (lp metas pos relocs)) ((arity) (lp metas (+ pos arity-header-len) (write-arity pos arity #f relocs))) (arities ;; Write a case-lambda header, then individual arities. ;; The case-lambda header's offset link is 0. (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0 (pack-arity-flags #f #f #f #t #f #f) 0 0 0) (let lp* ((arities arities) (pos (+ pos arity-header-len)) (relocs relocs)) (match arities (() (lp metas pos relocs)) ((arity . arities) (lp* arities (+ pos arity-header-len) (write-arity pos arity #t relocs))))))))))) (define (link-arities asm) (define (meta-arities-header-size meta) (define (lambda-size arity) arity-header-len) (define (case-lambda-size arities) (fold + arity-header-len ;; case-lambda header (map lambda-size arities))) ;; the cases (match (meta-arities meta) (() 0) ((arity) (lambda-size arity)) (arities (case-lambda-size arities)))) (define (bytevector-append a b) (let ((out (make-bytevector (+ (bytevector-length a) (bytevector-length b))))) (bytevector-copy! a 0 out 0 (bytevector-length a)) (bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b)) out)) (let* ((endianness (asm-endianness asm)) (metas (reverse (asm-meta asm))) (header-size (fold (lambda (meta size) (+ size (meta-arities-header-size meta))) arities-prefix-len metas)) (strtab (make-string-table)) (headers (make-bytevector header-size 0))) (bytevector-u32-set! headers 0 (bytevector-length headers) endianness) (let-values (((names-port get-name-bv) (open-bytevector-output-port))) (let* ((relocs (write-arities asm metas headers names-port strtab)) (strtab (make-object asm '.guile.arities.strtab (link-string-table! strtab) '() '() #:type SHT_STRTAB #:flags 0))) (values (make-object asm '.guile.arities (bytevector-append headers (get-name-bv)) relocs '() #:type SHT_PROGBITS #:flags 0 #:link (elf-section-index (linker-object-section strtab))) strtab))))) ;;; ;;; The .guile.docstrs section is a packed, sorted array of (pc, str) ;;; values. Pc and str are both 32 bits wide. (Either could change to ;;; 64 bits if appropriate in the future.) Pc is the address of the ;;; entry to a program, relative to the start of the text section, in ;;; bytes, and str is an index into the associated .guile.docstrs.strtab ;;; string table section. ;;; ;; The size of a docstrs entry, in bytes. (define docstr-size 8) (define (link-docstrs asm) (define (find-docstrings) (filter-map (lambda (meta) (define (is-documentation? pair) (eq? (car pair) 'documentation)) (let* ((props (meta-properties meta)) (tail (find-tail is-documentation? props))) (and tail (not (find-tail is-documentation? (cdr tail))) (string? (cdar tail)) (cons (meta-low-pc meta) (cdar tail))))) (reverse (asm-meta asm)))) (let* ((endianness (asm-endianness asm)) (docstrings (find-docstrings)) (strtab (make-string-table)) (bv (make-bytevector (* (length docstrings) docstr-size) 0))) (fold (lambda (pair pos) (match pair ((pc . string) (bytevector-u32-set! bv pos pc endianness) (bytevector-u32-set! bv (+ pos 4) (string-table-intern! strtab string) endianness) (+ pos docstr-size)))) 0 docstrings) (let ((strtab (make-object asm '.guile.docstrs.strtab (link-string-table! strtab) '() '() #:type SHT_STRTAB #:flags 0))) (values (make-object asm '.guile.docstrs bv '() '() #:type SHT_PROGBITS #:flags 0 #:link (elf-section-index (linker-object-section strtab))) strtab)))) ;;; ;;; The .guile.procprops section is a packed, sorted array of (pc, addr) ;;; values. Pc and addr are both 32 bits wide. (Either could change to ;;; 64 bits if appropriate in the future.) Pc is the address of the ;;; entry to a program, relative to the start of the text section, and ;;; addr is the address of the associated properties alist, relative to ;;; the start of the ELF image. ;;; ;;; Since procedure properties are stored in the data sections, we need ;;; to link the procedures property section first. (Note that this ;;; constraint does not apply to the arities section, which may ;;; reference the data sections via the kw-indices literal, because ;;; assembling the text section already makes sure that the kw-indices ;;; are interned.) ;;; ;; The size of a procprops entry, in bytes. (define procprops-size 8) (define (link-procprops asm) (define (assoc-remove-one alist key value-pred) (match alist (() '()) ((((? (lambda (x) (eq? x key))) . value) . alist) (if (value-pred value) alist (acons key value alist))) (((k . v) . alist) (acons k v (assoc-remove-one alist key value-pred))))) (define (props-without-name-or-docstring meta) (assoc-remove-one (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t)) 'documentation string?)) (define (find-procprops) (filter-map (lambda (meta) (let ((props (props-without-name-or-docstring meta))) (and (pair? props) (cons (meta-low-pc meta) props)))) (reverse (asm-meta asm)))) (let* ((endianness (asm-endianness asm)) (procprops (find-procprops)) (bv (make-bytevector (* (length procprops) procprops-size) 0))) (let lp ((procprops procprops) (pos 0) (relocs '())) (match procprops (() (make-object asm '.guile.procprops bv relocs '() #:type SHT_PROGBITS #:flags 0)) (((pc . props) . procprops) (bytevector-u32-set! bv pos pc endianness) (lp procprops (+ pos procprops-size) (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0 (intern-constant asm props)) relocs))))))) ;;; ;;; The DWARF .debug_info, .debug_abbrev, .debug_str, and .debug_loc ;;; sections provide line number and local variable liveness ;;; information. Their format is defined by the DWARF ;;; specifications. ;;; (define (asm-language asm) ;; FIXME: Plumb language through to the assembler. 'scheme) ;; -> 5 values: .debug_info, .debug_abbrev, .debug_str, .debug_loc, .debug_lines (define (link-debug asm) (define (put-s8 port val) (let ((bv (make-bytevector 1))) (bytevector-s8-set! bv 0 val) (put-bytevector port bv))) (define (put-u16 port val) (let ((bv (make-bytevector 2))) (bytevector-u16-set! bv 0 val (asm-endianness asm)) (put-bytevector port bv))) (define (put-u32 port val) (let ((bv (make-bytevector 4))) (bytevector-u32-set! bv 0 val (asm-endianness asm)) (put-bytevector port bv))) (define (put-u64 port val) (let ((bv (make-bytevector 8))) (bytevector-u64-set! bv 0 val (asm-endianness asm)) (put-bytevector port bv))) (define (meta->subprogram-die meta) `(subprogram (@ ,@(cond ((meta-name meta) => (lambda (name) `((name ,(symbol->string name))))) (else '())) (low-pc ,(meta-label meta)) (high-pc ,(- (meta-high-pc meta) (meta-low-pc meta)))))) (define (make-compile-unit-die asm) `(compile-unit (@ (producer ,(string-append "Guile " (version))) (language ,(asm-language asm)) (low-pc .rtl-text) (high-pc ,(asm-pos asm)) (stmt-list 0)) ,@(map meta->subprogram-die (reverse (asm-meta asm))))) (let-values (((die-port get-die-bv) (open-bytevector-output-port)) ((die-relocs) '()) ((abbrev-port get-abbrev-bv) (open-bytevector-output-port)) ;; (tag has-kids? attrs forms) -> code ((abbrevs) vlist-null) ((strtab) (make-string-table)) ((line-port get-line-bv) (open-bytevector-output-port)) ((line-relocs) '()) ;; file -> code ((files) vlist-null)) (define (write-abbrev code tag has-children? attrs forms) (put-uleb128 abbrev-port code) (put-uleb128 abbrev-port (tag-name->code tag)) (put-u8 abbrev-port (children-name->code (if has-children? 'yes 'no))) (for-each (lambda (attr form) (put-uleb128 abbrev-port (attribute-name->code attr)) (put-uleb128 abbrev-port (form-name->code form))) attrs forms) (put-uleb128 abbrev-port 0) (put-uleb128 abbrev-port 0)) (define (intern-abbrev tag has-children? attrs forms) (let ((key (list tag has-children? attrs forms))) (match (vhash-assoc key abbrevs) ((_ . code) code) (#f (let ((code (1+ (vlist-length abbrevs)))) (set! abbrevs (vhash-cons key code abbrevs)) (write-abbrev code tag has-children? attrs forms) code))))) (define (intern-file file) (match (vhash-assoc file files) ((_ . code) code) (#f (let ((code (1+ (vlist-length files)))) (set! files (vhash-cons file code files)) code)))) (define (write-sources) ;; Choose line base and line range values that will allow for an ;; address advance range of 16 words. The special opcode range is ;; from 10 to 255, so 246 values. (define base -4) (define range 15) (define min-inc 4) ; Minimum PC increment. (let lp ((sources (asm-sources asm)) (out '())) (match sources (((pc . s) . sources) (let ((file (assq-ref s 'filename)) (line (assq-ref s 'line)) (col (assq-ref s 'column))) (lp sources ;; Guile line and column numbers are 0-indexed, but ;; they are 1-indexed for DWARF. (if (and line col) (cons (list pc (if (string? file) (intern-file file) 0) (1+ line) (1+ col)) out) out)))) (() ;; Compilation unit header for .debug_line. We write in ;; DWARF 2 format because more tools understand it than DWARF ;; 4, which incompatibly adds another field to this header. (put-u32 line-port 0) ; Length; will patch later. (put-u16 line-port 2) ; DWARF 2 format. (put-u32 line-port 0) ; Prologue length; will patch later. (put-u8 line-port min-inc) ; Minimum instruction length: 4 bytes. (put-u8 line-port 1) ; Default is-stmt: true. (put-s8 line-port base) ; Line base. See the DWARF standard. (put-u8 line-port range) ; Line range. See the DWARF standard. (put-u8 line-port 10) ; Opcode base: the first "special" opcode. ;; A table of the number of uleb128 arguments taken by each ;; of the standard opcodes. (put-u8 line-port 0) ; 1: copy (put-u8 line-port 1) ; 2: advance-pc (put-u8 line-port 1) ; 3: advance-line (put-u8 line-port 1) ; 4: set-file (put-u8 line-port 1) ; 5: set-column (put-u8 line-port 0) ; 6: negate-stmt (put-u8 line-port 0) ; 7: set-basic-block (put-u8 line-port 0) ; 8: const-add-pc (put-u8 line-port 1) ; 9: fixed-advance-pc ;; Include directories, as a zero-terminated sequence of ;; nul-terminated strings. Nothing, for the moment. (put-u8 line-port 0) ;; File table. For each file that contributes to this ;; compilation unit, a nul-terminated file name string, and a ;; uleb128 for each of directory the file was found in, the ;; modification time, and the file's size in bytes. We pass ;; zero for the latter three fields. (vlist-fold-right (lambda (pair seed) (match pair ((file . code) (put-bytevector line-port (string->utf8 file)) (put-u8 line-port 0) (put-uleb128 line-port 0) ; directory (put-uleb128 line-port 0) ; mtime (put-uleb128 line-port 0))) ; size seed) #f files) (put-u8 line-port 0) ; 0 byte terminating file list. ;; Patch prologue length. (let ((offset (port-position line-port))) (seek line-port 6 SEEK_SET) (put-u32 line-port (- offset 10)) (seek line-port offset SEEK_SET)) ;; Now write the statement program. (let () (define (extended-op opcode payload-len) (put-u8 line-port 0) ; extended op (put-uleb128 line-port (1+ payload-len)) ; payload-len + opcode (put-uleb128 line-port opcode)) (define (set-address sym) (define (add-reloc! kind) (set! line-relocs (cons (make-linker-reloc kind (port-position line-port) 0 sym) line-relocs))) (match (asm-word-size asm) (4 (extended-op 2 4) (add-reloc! 'abs32/1) (put-u32 line-port 0)) (8 (extended-op 2 8) (add-reloc! 'abs64/1) (put-u64 line-port 0)))) (define (end-sequence pc) (let ((pc-inc (/ (- (asm-pos asm) pc) min-inc))) (put-u8 line-port 2) ; advance-pc (put-uleb128 line-port pc-inc)) (extended-op 1 0)) (define (advance-pc pc-inc line-inc) (let ((spec (+ (- line-inc base) (* (/ pc-inc min-inc) range) 10))) (cond ((or (< line-inc base) (>= line-inc (+ base range))) (advance-line line-inc) (advance-pc pc-inc 0)) ((<= spec 255) (put-u8 line-port spec)) ((< spec 500) (put-u8 line-port 8) ; const-advance-pc (advance-pc (- pc-inc (* (floor/ (- 255 10) range) min-inc)) line-inc)) (else (put-u8 line-port 2) ; advance-pc (put-uleb128 line-port (/ pc-inc min-inc)) (advance-pc 0 line-inc))))) (define (advance-line inc) (put-u8 line-port 3) (put-sleb128 line-port inc)) (define (set-file file) (put-u8 line-port 4) (put-uleb128 line-port file)) (define (set-column col) (put-u8 line-port 5) (put-uleb128 line-port col)) (set-address '.rtl-text) (let lp ((in out) (pc 0) (file 1) (line 1) (col 0)) (match in (() (when (null? out) ;; There was no source info in the first place. Set ;; file register to 0 before adding final row. (set-file 0)) (end-sequence pc)) (((pc* file* line* col*) . in*) (cond ((and (eqv? file file*) (eqv? line line*) (eqv? col col*)) (lp in* pc file line col)) (else (unless (eqv? col col*) (set-column col*)) (unless (eqv? file file*) (set-file file*)) (advance-pc (- pc* pc) (- line* line)) (lp in* pc* file* line* col*))))))))))) (define (compute-code attr val) (match attr ('name (string-table-intern! strtab val)) ('low-pc val) ('high-pc val) ('producer (string-table-intern! strtab val)) ('language (language-name->code val)) ('stmt-list val))) (define (choose-form attr val code) (cond ((string? val) 'strp) ((eq? attr 'stmt-list) 'sec-offset) ((eq? attr 'low-pc) 'addr) ((exact-integer? code) (cond ((< code 0) 'sleb128) ((<= code #xff) 'data1) ((<= code #xffff) 'data2) ((<= code #xffffffff) 'data4) ((<= code #xffffffffffffffff) 'data8) (else 'uleb128))) (else (error "unhandled case" attr val code)))) (define (add-die-relocation! kind sym) (set! die-relocs (cons (make-linker-reloc kind (port-position die-port) 0 sym) die-relocs))) (define (write-value code form) (match form ('data1 (put-u8 die-port code)) ('data2 (put-u16 die-port code)) ('data4 (put-u32 die-port code)) ('data8 (put-u64 die-port code)) ('uleb128 (put-uleb128 die-port code)) ('sleb128 (put-sleb128 die-port code)) ('addr (match (asm-word-size asm) (4 (add-die-relocation! 'abs32/1 code) (put-u32 die-port 0)) (8 (add-die-relocation! 'abs64/1 code) (put-u64 die-port 0)))) ('sec-offset (put-u32 die-port code)) ('strp (put-u32 die-port code)))) (define (write-die die) (match die ((tag ('@ (attrs vals) ...) children ...) (let* ((codes (map compute-code attrs vals)) (forms (map choose-form attrs vals codes)) (has-children? (not (null? children))) (abbrev-code (intern-abbrev tag has-children? attrs forms))) (put-uleb128 die-port abbrev-code) (for-each write-value codes forms) (when has-children? (for-each write-die children) (put-uleb128 die-port 0)))))) ;; Compilation unit header. (put-u32 die-port 0) ; Length; will patch later. (put-u16 die-port 4) ; DWARF 4. (put-u32 die-port 0) ; Abbrevs offset. (put-u8 die-port (asm-word-size asm)) ; Address size. (write-die (make-compile-unit-die asm)) ;; Terminate the abbrevs list. (put-uleb128 abbrev-port 0) (write-sources) (values (let ((bv (get-die-bv))) ;; Patch DWARF32 length. (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4) (asm-endianness asm)) (make-object asm '.debug_info bv die-relocs '() #:type SHT_PROGBITS #:flags 0)) (make-object asm '.debug_abbrev (get-abbrev-bv) '() '() #:type SHT_PROGBITS #:flags 0) (make-object asm '.debug_str (link-string-table! strtab) '() '() #:type SHT_PROGBITS #:flags 0) (make-object asm '.debug_loc #vu8() '() '() #:type SHT_PROGBITS #:flags 0) (let ((bv (get-line-bv))) ;; Patch DWARF32 length. (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4) (asm-endianness asm)) (make-object asm '.debug_line bv line-relocs '() #:type SHT_PROGBITS #:flags 0))))) (define (link-objects asm) (let*-values (;; Link procprops before constants, because it probably ;; interns more constants. ((procprops) (link-procprops asm)) ((ro rw rw-init) (link-constants asm)) ;; Link text object after constants, so that the ;; constants initializer gets included. ((text) (link-text-object asm)) ((frame-maps) (link-frame-maps asm)) ((dt) (link-dynamic-section asm text rw rw-init frame-maps)) ((symtab strtab) (link-symtab (linker-object-section text) asm)) ((arities arities-strtab) (link-arities asm)) ((docstrs docstrs-strtab) (link-docstrs asm)) ((dinfo dabbrev dstrtab dloc dline) (link-debug asm)) ;; This needs to be linked last, because linking other ;; sections adds entries to the string table. ((shstrtab) (link-shstrtab asm))) (filter identity (list text ro frame-maps rw dt symtab strtab arities arities-strtab docstrs docstrs-strtab procprops dinfo dabbrev dstrtab dloc dline shstrtab)))) ;;; ;;; High-level public interfaces. ;;; (define* (link-assembly asm #:key (page-aligned? #t)) "Produce an ELF image from the code and data emitted into @var{asm}. The result is a bytevector, by default linked so that read-only and writable data are on separate pages. Pass @code{#:page-aligned? #f} to disable this behavior." (link-elf (link-objects asm) #:page-aligned? page-aligned?))
Close
