-;;; Guile RTL assembler
+;;; Guile bytecode assembler
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 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
;;; Commentary:
;;;
;;; This module implements an assembler that creates an ELF image from
-;;; RTL assembly and macro-assembly. The input can be given in
+;;; 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 RTL VM operations.
-;;; Assemblers for primitive instructions are generated programmatically
-;;; from (rtl-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.
+;;; "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
(define-module (system vm assembler)
#:use-module (system base target)
- #:use-module (system vm instruction)
#:use-module (system vm dwarf)
#:use-module (system vm elf)
#:use-module (system vm linker)
+ #:use-module (language bytecode)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:export (make-assembler
+
+ emit-call
+ emit-call-label
+ emit-tail-call
+ emit-tail-call-label
+ (emit-receive* . emit-receive)
+ emit-receive-values
+ emit-return
+ emit-return-values
+ emit-call/cc
+ emit-abort
+ (emit-builtin-ref* . emit-builtin-ref)
+ emit-br-if-nargs-ne
+ emit-br-if-nargs-lt
+ emit-br-if-nargs-gt
+ emit-assert-nargs-ee
+ emit-assert-nargs-ge
+ emit-assert-nargs-le
+ emit-alloc-frame
+ emit-reset-frame
+ emit-assert-nargs-ee/locals
+ emit-br-if-npos-gt
+ emit-bind-kwargs
+ emit-bind-rest
+ emit-br
+ emit-br-if-true
+ emit-br-if-null
+ emit-br-if-nil
+ emit-br-if-pair
+ emit-br-if-struct
+ emit-br-if-char
+ emit-br-if-tc7
+ (emit-br-if-eq* . emit-br-if-eq)
+ (emit-br-if-eqv* . emit-br-if-eqv)
+ (emit-br-if-equal* . emit-br-if-equal)
+ (emit-br-if-=* . emit-br-if-=)
+ (emit-br-if-<* . emit-br-if-<)
+ (emit-br-if-<=* . emit-br-if-<=)
+ (emit-br-if-logtest* . emit-br-if-logtest)
+ (emit-mov* . emit-mov)
+ (emit-box* . emit-box)
+ (emit-box-ref* . emit-box-ref)
+ (emit-box-set!* . emit-box-set!)
+ emit-make-closure
+ (emit-free-ref* . emit-free-ref)
+ (emit-free-set!* . emit-free-set!)
+ emit-current-module
+ emit-resolve
+ (emit-define!* . emit-define!)
+ emit-toplevel-box
+ emit-module-box
+ emit-prompt
+ (emit-wind* . emit-wind)
+ emit-unwind
+ (emit-push-fluid* . emit-push-fluid)
+ emit-pop-fluid
+ (emit-fluid-ref* . emit-fluid-ref)
+ (emit-fluid-set* . emit-fluid-set)
+ (emit-string-length* . emit-string-length)
+ (emit-string-ref* . emit-string-ref)
+ (emit-string->number* . emit-string->number)
+ (emit-string->symbol* . emit-string->symbol)
+ (emit-symbol->keyword* . emit-symbol->keyword)
+ (emit-cons* . emit-cons)
+ (emit-car* . emit-car)
+ (emit-cdr* . emit-cdr)
+ (emit-set-car!* . emit-set-car!)
+ (emit-set-cdr!* . emit-set-cdr!)
+ (emit-add* . emit-add)
+ (emit-add1* . emit-add1)
+ (emit-sub* . emit-sub)
+ (emit-sub1* . emit-sub1)
+ (emit-mul* . emit-mul)
+ (emit-div* . emit-div)
+ (emit-quo* . emit-quo)
+ (emit-rem* . emit-rem)
+ (emit-mod* . emit-mod)
+ (emit-ash* . emit-ash)
+ (emit-logand* . emit-logand)
+ (emit-logior* . emit-logior)
+ (emit-logxor* . emit-logxor)
+ (emit-make-vector* . emit-make-vector)
+ (emit-make-vector/immediate* . emit-make-vector/immediate)
+ (emit-vector-length* . emit-vector-length)
+ (emit-vector-ref* . emit-vector-ref)
+ (emit-vector-ref/immediate* . emit-vector-ref/immediate)
+ (emit-vector-set!* . emit-vector-set!)
+ (emit-vector-set!/immediate* . emit-vector-set!/immediate)
+ (emit-struct-vtable* . emit-struct-vtable)
+ (emit-allocate-struct/immediate* . emit-allocate-struct/immediate)
+ (emit-struct-ref/immediate* . emit-struct-ref/immediate)
+ (emit-struct-set!/immediate* . emit-struct-set!/immediate)
+ (emit-allocate-struct* . emit-allocate-struct)
+ (emit-struct-ref* . emit-struct-ref)
+ (emit-struct-set!* . emit-struct-set!)
+ (emit-class-of* . emit-class-of)
+ (emit-make-array* . emit-make-array)
+ (emit-bv-u8-ref* . emit-bv-u8-ref)
+ (emit-bv-s8-ref* . emit-bv-s8-ref)
+ (emit-bv-u16-ref* . emit-bv-u16-ref)
+ (emit-bv-s16-ref* . emit-bv-s16-ref)
+ (emit-bv-u32-ref* . emit-bv-u32-ref)
+ (emit-bv-s32-ref* . emit-bv-s32-ref)
+ (emit-bv-u64-ref* . emit-bv-u64-ref)
+ (emit-bv-s64-ref* . emit-bv-s64-ref)
+ (emit-bv-f32-ref* . emit-bv-f32-ref)
+ (emit-bv-f64-ref* . emit-bv-f64-ref)
+ (emit-bv-u8-set!* . emit-bv-u8-set!)
+ (emit-bv-s8-set!* . emit-bv-s8-set!)
+ (emit-bv-u16-set!* . emit-bv-u16-set!)
+ (emit-bv-s16-set!* . emit-bv-s16-set!)
+ (emit-bv-u32-set!* . emit-bv-u32-set!)
+ (emit-bv-s32-set!* . emit-bv-s32-set!)
+ (emit-bv-u64-set!* . emit-bv-u64-set!)
+ (emit-bv-s64-set!* . emit-bv-s64-set!)
+ (emit-bv-f32-set!* . emit-bv-f32-set!)
+ (emit-bv-f64-set!* . emit-bv-f64-set!)
+
emit-text
link-assembly))
\f
-;;; RTL code consists of 32-bit units, often subdivided in some way.
+;; 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-inlinable (pack-u8-u24 x y)
+(define-inline (pack-u8-u24 x y)
(unless (<= 0 x 255)
(error "out of range" x))
(logior x (ash y 8)))
-(define-inlinable (pack-u8-s24 x y)
+(define-inline (pack-u8-s24 x y)
(unless (<= 0 x 255)
(error "out of range" x))
(logior x (ash (cond
(else (error "out of range" y)))
8)))
-(define-inlinable (pack-u1-u7-u24 x y z)
+(define-inline (pack-u1-u7-u24 x y z)
(unless (<= 0 x 1)
(error "out of range" x))
(unless (<= 0 y 127)
(error "out of range" y))
(logior x (ash y 1) (ash z 8)))
-(define-inlinable (pack-u8-u12-u12 x y z)
+(define-inline (pack-u8-u12-u12 x y z)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 4095)
(error "out of range" y))
(logior x (ash y 8) (ash z 20)))
-(define-inlinable (pack-u8-u8-u16 x y z)
+(define-inline (pack-u8-u8-u16 x y z)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 255)
(error "out of range" y))
(logior x (ash y 8) (ash z 16)))
-(define-inlinable (pack-u8-u8-u8-u8 x y z w)
+(define-inline (pack-u8-u8-u8-u8 x y z w)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 255)
(error "out of range" z))
(logior x (ash y 8) (ash z 16) (ash w 24)))
-(define-syntax pack-flags
- (syntax-rules ()
- ;; Add clauses as needed.
- ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
- (if f2 (ash 2 0) 0)))))
+(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 2 0) 0))))))
;;; Helpers to read and write 32-bit units in a buffer.
-(define-syntax-rule (u32-ref buf n)
+(define-inline (u32-ref buf n)
(bytevector-u32-native-ref buf (* n 4)))
-(define-syntax-rule (u32-set! buf n val)
+(define-inline (u32-set! buf n val)
(bytevector-u32-native-set! buf (* n 4) val))
-(define-syntax-rule (s32-ref buf n)
+(define-inline (s32-ref buf n)
(bytevector-s32-native-ref buf (* n 4)))
-(define-syntax-rule (s32-set! buf n val)
+(define-inline (s32-set! buf n val)
(bytevector-s32-native-set! buf (* n 4) val))
\f
;;; A <meta> entry collects metadata for one procedure. Procedures are
-;;; written as contiguous ranges of RTL code.
+;;; written as contiguous ranges of bytecode.
;;;
-(define-syntax-rule (assert-match arg pattern kind)
- (let ((x arg))
- (unless (match x (pattern #t) (_ #f))
- (error (string-append "expected " kind) x))))
+(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 <meta>
(%make-meta label properties low-pc high-pc arities)
(arities meta-arities set-meta-arities!))
(define (make-meta label properties low-pc)
- (assert-match label (? symbol?) "symbol")
+ (assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
(assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
(%make-meta label properties low-pc #f '()))
;; Metadata for one <lambda-case>.
(define-record-type <arity>
(make-arity req opt rest kw-indices allow-other-keys?
- low-pc high-pc)
+ low-pc high-pc definitions)
arity?
(req arity-req)
(opt arity-opt)
(kw-indices arity-kw-indices)
(allow-other-keys? arity-allow-other-keys?)
(low-pc arity-low-pc)
- (high-pc arity-high-pc set-arity-high-pc!))
+ (high-pc arity-high-pc set-arity-high-pc!)
+ (definitions arity-definitions set-arity-definitions!))
-(define-syntax *block-size* (identifier-syntax 32))
+(eval-when (expand)
+ (define-syntax *block-size* (identifier-syntax 32)))
;;; 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.
;;;
-;;; RTL code consists of 32-bit units. We emit RTL code using native
+;;; 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.
;;;
word-size endianness
constants inits
shstrtab next-section-number
- meta sources)
+ meta sources
+ dead-slot-maps
+ to-file?)
asm?
- ;; We write RTL code into what is logically a growable vector,
+ ;; We write bytecode into what is logically a growable vector,
;; implemented as a list of blocks. asm-cur is the current block, and
;; asm-idx is the current index into that block, in 32-bit units.
;;
;; beginning of an instruction (in u32 units). 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 RTL 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.
+ ;; 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!)
;;
(constants asm-constants set-asm-constants!)
- ;; A list of RTL instructions needed to initialize the constants.
- ;; Will run in a thunk with 2 local variables.
+ ;; A list of instructions needed to initialize the constants. Will
+ ;; run in a thunk with 2 local variables.
;;
(inits asm-inits set-asm-inits!)
;; 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!))
+ (sources asm-sources set-asm-sources!)
+
+ ;; A list of (pos . dead-slot-map) pairs, indicating dead slot maps.
+ ;; POS is relative to the beginning of the text section.
+ ;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites,
+ ;; as an integer.
+ ;;
+ (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!)
+ (to-file? asm-to-file?))
-(define-inlinable (fresh-block)
+(define-inline (fresh-block)
(make-u32vector *block-size*))
(define* (make-assembler #:key (word-size (target-word-size))
- (endianness (target-endianness)))
+ (endianness (target-endianness))
+ (to-file? #t))
"Create an assembler for a given target @var{word-size} and
@var{endianness}, falling back to appropriate values for the configured
target."
word-size endianness
vlist-null '()
(make-string-table) 1
- '() '()))
+ '() '() '() to-file?))
(define (intern-section-name! asm string)
"Add a string to the section name table (shstrtab)."
(string-table-intern! (asm-shstrtab asm) string))
-(define-inlinable (asm-pos asm)
+(define-inline (asm-pos asm)
"The offset of the next word to be written into the code buffer, in
32-bit units."
(+ (asm-idx asm) (asm-written asm)))
(set-asm-cur! asm new)
(set-asm-idx! asm 0)))
-(define-inlinable (emit asm u32)
+(define-inline (emit asm u32)
"Emit one 32-bit word into the instruction stream. Assumes that there
is space for the word, and ensures that there is space for the next
word."
(if (= (asm-idx asm) *block-size*)
(allocate-new-block asm)))
-(define-inlinable (make-reloc type label base word)
+(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
reference that needs to be fixed up by the linker."
(list type label base word))
-(define-inlinable (reset-asm-start! asm)
+(define-inline (reset-asm-start! asm)
"Reset the asm-start after writing the words for one instruction."
(set-asm-start! asm (asm-pos asm)))
;;;
;;; Primitive assemblers are defined by expanding `assembler' for each
-;;; opcode in `(rtl-instruction-list)'.
+;;; opcode in `(instruction-list)'.
;;;
-(eval-when (expand compile load eval)
+(eval-when (expand)
(define (id-append ctx a b)
- (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
-
-(define-syntax assembler
- (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))
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+
+ (define-syntax assembler
+ (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
+ ((U8_X24)
+ (emit asm opcode))
+ ((U8_U24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((U8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((U8_U8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((U8_U8_U8_U8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
(op-case
asm type
- ((U8_X24)
- (emit asm opcode))
- ((U8_U24 arg)
- (emit asm (pack-u8-u24 opcode arg)))
- ((U8_L24 label)
+ ((U8_U24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((U8_L24 a label)
(record-label-reference asm label)
- (emit asm opcode))
- ((U8_U8_I16 a imm)
- (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
- ((U8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 opcode a b)))
- ((U8_U8_U8_U8 a b c)
- (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
-
- (define (pack-tail-word asm type)
- (op-case
- asm type
- ((U8_U24 a b)
- (emit asm (pack-u8-u24 a b)))
- ((U8_L24 a label)
- (record-label-reference asm label)
- (emit asm a))
- ((U8_U8_I16 a b imm)
- (emit asm (pack-u8-u8-u16 a b (object-address imm))))
- ((U8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 a b c)))
- ((U8_U8_U8_U8 a b c d)
- (emit asm (pack-u8-u8-u8-u8 a b c d)))
- ((U32 a)
- (emit asm a))
- ((I32 imm)
- (let ((val (object-address imm)))
- (unless (zero? (ash val -32))
- (error "FIXME: enable truncation of negative fixnums when cross-compiling"))
- (emit asm val)))
- ((A32 imm)
- (unless (= (asm-word-size asm) 8)
- (error "make-long-immediate unavailable for this target"))
- (emit asm (ash (object-address imm) -32))
- (emit asm (logand (object-address imm) (1- (ash 1 32)))))
- ((B32))
- ((N32 label)
- (record-far-label-reference asm label)
- (emit asm 0))
- ((S32 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) 4)))
- (emit asm 0))
- ((X8_U24 a)
- (emit asm (pack-u8-u24 0 a)))
- ((X8_U12_U12 a b)
- (emit asm (pack-u8-u12-u12 0 a b)))
- ((X8_L24 label)
- (record-label-reference asm label)
- (emit asm 0))
- ((B1_X7_L24 a label)
- (record-label-reference asm label)
- (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
- ((B1_U7_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_U24 a b)
- (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
-
- (syntax-case x ()
- ((_ name opcode word0 word* ...)
- (with-syntax ((((formal0 ...)
- code0 ...)
- (pack-first-word #'asm
- (syntax->datum #'opcode)
- (syntax->datum #'word0)))
- ((((formal* ...)
- code* ...) ...)
- (map (lambda (word) (pack-tail-word #'asm word))
- (syntax->datum #'(word* ...)))))
- #'(lambda (asm formal0 ... formal* ... ...)
- (unless (asm? asm) (error "not an asm"))
- code0 ...
- code* ... ...
- (reset-asm-start! asm)))))))
+ (emit asm a))
+ ((U32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (object-address imm)))
+ (unless (zero? (ash val -32))
+ (error "FIXME: enable truncation of negative fixnums when cross-compiling"))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (emit asm (ash (object-address imm) -32))
+ (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+ ((B32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((S32 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) 4)))
+ (emit asm 0))
+ ((X8_U24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_U7_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_U24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm
+ (syntax->datum #'opcode)
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (unless (asm? asm) (error "not an asm"))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm))))))))
(define assemblers (make-hash-table))
-(define-syntax define-assembler
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode kind arg ...)
- (with-syntax ((emit (id-append #'name #'emit- #'name)))
- #'(begin
- (define emit
+(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 arg ...)))
(hashq-set! assemblers 'name emit)
- emit))
- (export emit)))))))
-
-(define-syntax visit-opcodes
- (lambda (x)
- (syntax-case x ()
- ((visit-opcodes macro arg ...)
- (with-syntax (((inst ...)
- (map (lambda (x) (datum->syntax #'macro x))
- (rtl-instruction-list))))
- #'(begin
- (macro arg ... . inst)
- ...))))))
+ 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)
+(eval-when (expand)
+
+ ;; Some operands are encoded 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 there are few live locals. Here we
+ ;; define wrapper emitters that shuffle out-of-range operands into and
+ ;; out of the reserved range of locals [233,255]. This range is
+ ;; sufficient because these restricted operands are only present in
+ ;; the first word of an instruction. Since 8 bits is the smallest
+ ;; slot-addressing operand size, that means we can fit 3 operands in
+ ;; the 24 bits of payload of the first word (the lower 8 bits being
+ ;; taken by the opcode).
+ ;;
+ ;; The result are wrapper emitters with the same arity,
+ ;; e.g. emit-cons* that wraps emit-cons. We expose these wrappers as
+ ;; the public interface for emitting `cons' instructions. That way we
+ ;; solve the problem fully and in just one place. The only manual
+ ;; care that need be taken is in the exports list at the top of the
+ ;; file -- to be sure that we export the wrapper and not the wrapped
+ ;; emitter.
+
+ (define (shuffling-assembler name kind word0 word*)
+ (define (analyze-first-word)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type %kind arg ...) values) clause ...)
+ (if (and (eq? type '%type) (eq? kind '%kind))
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...) values))
+ (op-case type clause ...)))
+ ((_ type)
+ #f)))
+ (op-case
+ word0
+ ((U8_U8_I16 ! a imm)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ imm))
+ ((U8_U8_I16 <- a imm)
+ (values (if (< a (ash 1 8)) a 253)
+ imm))
+ ((U8_U12_U12 ! a b)
+ (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U12_U12 <- a b)
+ (values (if (< a (ash 1 12)) a 253)
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U8_U8_U8 ! a b c)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))
+ ((U8_U8_U8_U8 <- a b c)
+ (values (if (< a (ash 1 8)) a 253)
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))))
+
+ (define (tail-formals type)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((op-case type (%type arg ...) clause ...)
+ (if (eq? type '%type)
+ (generate-temporaries #'(arg ...))
+ (op-case type clause ...)))
+ ((op-case type)
+ (error "unmatched type" type))))
+ (op-case type
+ (U8_U24 a b)
+ (U8_L24 a label)
+ (U32 a)
+ (I32 imm)
+ (A32 imm)
+ (B32)
+ (N32 label)
+ (S32 label)
+ (L32 label)
+ (LO32 label offset)
+ (X8_U24 a)
+ (X8_L24 label)
+ (B1_X7_L24 a label)
+ (B1_U7_L24 a b label)
+ (B1_X31 a)
+ (B1_X7_U24 a b)))
+
+ (define (shuffle-up dst)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type ...) exp) clause ...)
+ (if (memq type '(%type ...))
+ #'exp
+ (op-case type clause ...)))
+ ((_ type)
+ (error "unexpected type" type))))
+ (with-syntax ((dst dst))
+ (op-case
+ word0
+ ((U8_U8_I16 U8_U8_U8_U8)
+ (unless (< dst (ash 1 8))
+ (emit-mov* asm dst 253)))
+ ((U8_U12_U12)
+ (unless (< dst (ash 1 12))
+ (emit-mov* asm dst 253))))))
+
+ (and=>
+ (analyze-first-word)
+ (lambda (formals+shuffle)
+ (with-syntax ((emit-name (id-append name #'emit- name))
+ (((formal0 ...) shuffle) formals+shuffle)
+ (((formal* ...) ...) (map tail-formals word*)))
+ (with-syntax (((shuffle-up-dst ...)
+ (if (eq? kind '<-)
+ (syntax-case #'(formal0 ...) ()
+ ((dst . _)
+ (list (shuffle-up #'dst))))
+ '())))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (call-with-values (lambda () shuffle)
+ (lambda (formal0 ...)
+ (emit-name asm formal0 ... formal* ... ...)))
+ shuffle-up-dst ...))))))
+
+ (define-syntax define-shuffling-assembler
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ #:except (except ...) name opcode kind word0 word* ...)
+ (cond
+ ((or-map (lambda (op) (eq? (syntax->datum #'name) op))
+ (map syntax->datum #'(except ...)))
+ #'(begin))
+ ((shuffling-assembler #'name (syntax->datum #'kind)
+ (syntax->datum #'word0)
+ (map syntax->datum #'(word* ...)))
+ => (lambda (proc)
+ (with-syntax ((emit (id-append #'name
+ (id-append #'name #'emit- #'name)
+ #'*))
+ (proc proc))
+ #'(define emit
+ (let ((emit proc))
+ (hashq-set! assemblers 'name emit)
+ emit)))))
+ (else #'(begin))))))))
+
+(visit-opcodes define-shuffling-assembler #:except (receive mov))
+
+;; Mov and receive are two special cases that can work without wrappers.
+;; Indeed it is important that they do so.
+
+(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-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-mov* asm dst (1+ proc))
+ (emit-reset-frame asm nlocals))))
+
(define (emit-text asm instructions)
"Assemble @var{instructions} using the assembler @var{asm}.
-@var{instructions} is a sequence of RTL instructions, expressed as a
-list of lists. This procedure can be called many times before calling
+@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))
;;; to the table.
;;;
-(define-inlinable (immediate? x)
+(define-inline (immediate? x)
"Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise."
(not (zero? (logand (object-address x) 6))))
((static-procedure? obj)
`((static-patch! ,label 1 ,(static-procedure-code obj))))
((cache-cell? obj) '())
- ((symbol? obj)
+ ((and (symbol? obj) (symbol-interned? obj))
`((make-non-immediate 1 ,(recur (symbol->string obj)))
(string->symbol 1 1)
(static-set! 1 ,label 0)))
(static-set! 1 ,label 0)))
((uniform-vector-backing-store? obj) '())
((simple-uniform-vector? obj)
- `((static-patch! ,label 2
- ,(recur (make-uniform-vector-backing-store
- (uniform-array->bytevector obj)
- (if (bitvector? obj)
- ;; Bitvectors are addressed in
- ;; 32-bit units.
- 4
- (uniform-vector-element-size 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)))))
+ `((static-patch! ,label 2
+ ,(recur (make-uniform-vector-backing-store
+ (uniform-array->bytevector obj)
+ width))))))
+ ((array? obj)
+ `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
(else
- (error "don't know how to intern" obj))))
+ (if (asm-to-file? asm)
+ (error "don't know how to intern" obj)
+ `((make-short-immediate 1 ,(vlist-length (asm-constants asm)))
+ (vector-ref 1 0 1)
+ (static-set! 1 ,label 0))))))
(cond
((immediate? obj) #f)
((vhash-assoc obj (asm-constants asm)) => cdr)
(else
- ;; Note that calling intern may mutate asm-constants and
- ;; asm-constant-inits.
+ ;; Note that calling intern may mutate asm-constants and asm-inits.
(let* ((label (gensym "constant"))
(inits (intern obj label)))
(set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
;;; some higher-level operations.
;;;
-(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)))))))
+(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
;(define-tc7-macro-assembler br-if-fluid 37)
;(define-tc7-macro-assembler br-if-dynamic-state 45)
;(define-tc7-macro-assembler br-if-frame 47)
+(define-tc7-macro-assembler br-if-keyword 53)
;(define-tc7-macro-assembler br-if-vm 55)
;(define-tc7-macro-assembler br-if-vm-cont 71)
;(define-tc7-macro-assembler br-if-rtl-program 69)
"alist of keyword -> integer")
(assert-match allow-other-keys? (? boolean?) "boolean")
(assert-match nlocals (? integer?) "integer")
- (assert-match alternate (or #f (? symbol?)) "#f or symbol")
+ (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?
- (asm-start asm) #f))
+ (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.
(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))))
+;; As noted above, we reserve locals 253 through 255 for shuffling large
+;; operands. However the calling convention has all arguments passed in
+;; a contiguous block. This helper, called after the clause has been
+;; chosen and the keyword/optional/rest arguments have been processed,
+;; shuffles up arguments from slot 253 and higher into their final
+;; allocations.
+;;
+(define (shuffle-up-args asm nargs)
+ (when (> nargs 253)
+ (let ((slot (1- nargs)))
+ (emit-mov asm (+ slot 3) slot)
+ (shuffle-up-args asm (1- nargs)))))
+
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond
(alternate
(emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
(else
(emit-assert-nargs-ee asm nreq)
- (emit-alloc-frame asm nlocals))))
+ (emit-alloc-frame asm nlocals)))
+ (shuffle-up-args asm nreq))
(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
(if alternate
(emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
(else
(emit-assert-nargs-le asm (+ nreq nopt))))
- (emit-alloc-frame asm nlocals))
+ (emit-alloc-frame asm nlocals)
+ (shuffle-up-args asm (+ nreq nopt (if rest? 1 0))))
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate)
(+ nreq nopt)
ntotal
(intern-constant asm kw-indices))
- (emit-alloc-frame asm nlocals)))
+ (emit-alloc-frame asm nlocals)
+ (shuffle-up-args asm ntotal)))
(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)
+ (let* ((arity (car (meta-arities (car (asm-meta asm)))))
+ (def (vector name
+ slot
+ (* (- (asm-start asm) (arity-low-pc arity)) 4))))
+ (set-arity-definitions! arity (cons def (arity-definitions arity)))))
+
(define-macro-assembler (cache-current-module! asm module scope)
(let ((mod-label (intern-module-cache-cell asm scope)))
(emit-static-set! asm module mod-label 0)))
(cell-label (intern-cache-cell asm key sym)))
(emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
+(define-macro-assembler (dead-slot-map asm proc-slot dead-slot-map)
+ (unless (zero? dead-slot-map)
+ (set-asm-dead-slot-maps! asm
+ (cons
+ (cons* (asm-start asm) proc-slot dead-slot-map)
+ (asm-dead-slot-maps asm)))))
\f
(let ((label (gensym "init-constants")))
(emit-text asm
`((begin-program ,label ())
- (assert-nargs-ee/locals 1 1)
+ ,@(if (asm-to-file? asm)
+ '((assert-nargs-ee/locals 1 1))
+ '((assert-nargs-ee/locals 2 0)
+ (mov 0 1)))
,@(reverse inits)
(load-constant 1 ,*unspecified*)
(return 1)
(define tc7-wide-stringbuf
(+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag))
(define tc7-ro-string (+ 21 #x200))
- (define tc7-rtl-program 69)
+ (define tc7-program 69)
(define tc7-bytevector 77)
(define tc7-bitvector 95)
+ (define tc7-array 93)
(let ((word-size (asm-word-size asm))
(endianness (asm-endianness asm)))
(* 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)))
((static-procedure? obj)
(case word-size
((4)
- (bytevector-u32-set! buf pos tc7-rtl-program endianness)
+ (bytevector-u32-set! buf pos tc7-program endianness)
(bytevector-u32-set! buf (+ pos 4) 0 endianness))
((8)
- (bytevector-u64-set! buf pos tc7-rtl-program endianness)
+ (bytevector-u64-set! buf pos tc7-program endianness)
(bytevector-u64-set! buf (+ pos 8) 0 endianness))
(else (error "bad word size"))))
(write-immediate asm buf pos #f))
((string? obj)
- (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
+ (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
(case word-size
((4)
(bytevector-u32-set! buf pos tc7-ro-string endianness)
(write-constant-reference buf pos elt)
(lp (1+ i)))))))
- ((symbol? obj)
+ ((and (symbol? obj) (symbol-interned? obj))
(write-immediate asm buf pos #f))
((keyword? obj)
((simple-uniform-vector? obj)
(let ((tag (if (bitvector? obj)
tc7-bitvector
- (let ((type-code (uniform-vector-element-type-code obj)))
+ (let ((type-code (array-type-code obj)))
(logior tc7-bytevector (ash type-code 7))))))
(case word-size
((4)
;; Need to swap units of element-size bytes
(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-immediate asm buf (+ pos word-size) #f) ; 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))))
+ (if (asm-to-file? asm)
+ (error "unrecognized object" obj)
+ (write-constant-reference buf pos obj)))))
(cond
((vlist-null? data) #f)
\f
+;;;
+;;; 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 (- 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 4) 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-dead-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))))))))
+
+\f
+
;;;
;;; 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* #x0202)
-(define *bytecode-minor-version* 3)
+(define *bytecode-minor-version* 6)
-(define (link-dynamic-section asm text rw rw-init)
- "Link the dynamic section for an ELF image with RTL 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 (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))
- (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
+ (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)))
(* i word-size) 0 label)
relocs))
(%set-uword! bv (* i word-size) 0 endianness))))
- (set-uword! 0 DT_GUILE_RTL_VERSION)
+ (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)
- (cond
- (rw
+ (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)))
- (cond
- (rw-init
+ (when rw-init
(set-uword! 8 DT_INIT) ; constants
- (set-label! 9 rw-init)
- (set-uword! 10 DT_NULL)
- (set-uword! 11 0))
- (else
- (set-uword! 8 DT_NULL)
- (set-uword! 9 0))))
- (else
- (set-uword! 4 DT_NULL)
- (set-uword! 5 0)))
+ (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)
;;; 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 RTL that constrain us to a total image that fits in 32
-;;; bits, so for the moment we'll simplify the problem space.
+;;; 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:
;;;
;;; 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. Links for required arguments
-;;; are first, in order, as uint32 values. Next follow the optionals,
-;;; then the rest link if has-rest? is set, then a link to the "keyword
-;;; indices" literal if has-keyword-args? is set. Unlike the other
-;;; links, the kw-indices link points into the data section, and is
-;;; relative to the ELF image as a whole.
+;;; 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.
(define arities-prefix-len 4)
;; Length of an arity header, in bytes.
-(define arity-header-len (* 6 4))
-
-;; The offset of "offset" within arity header, in bytes.
-(define arity-header-offset-offset (* 2 4))
-
-(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
- has-keyword-args? is-case-lambda?
- is-in-case-lambda?)
+(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?)
(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)))
-(define (meta-arities-size meta)
- (define (lambda-size arity)
- (+ arity-header-len
- (* 4 ;; name pointers
- (+ (length (arity-req arity))
- (length (arity-opt arity))
- (if (arity-rest arity) 1 0)
- (if (pair? (arity-kw-indices arity)) 1 0)))))
- (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 (write-arity-headers metas bv endianness)
- (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
- (bytevector-u32-set! bv pos (* low-pc 4) endianness)
- (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
- (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
- (bytevector-u32-set! bv (+ pos 12) flags endianness)
- (bytevector-u32-set! bv (+ pos 16) nreq endianness)
- (bytevector-u32-set! bv (+ pos 20) nopt endianness))
- (define (write-arity-header pos arity in-case-lambda?)
- (write-arity-header* pos (arity-low-pc arity)
- (arity-high-pc arity)
- (pack-arity-flags (arity-rest arity)
- (arity-allow-other-keys? arity)
- (pair? (arity-kw-indices arity))
- #f
- in-case-lambda?)
- (length (arity-req arity))
- (length (arity-opt arity))))
- (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+(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 4) (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (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?)
+ (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 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 def) . definitions)
+ (put-uleb128 names-port def)
+ (put-uleb128 names-port slot)
+ (lp definitions))))))
+ (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
(match metas
(()
- ;; Fill in the prefix.
- (bytevector-u32-set! bv 0 pos endianness)
- (values pos (reverse offsets)))
+ (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 offsets))
+ (() (lp metas pos relocs))
((arity)
- (write-arity-header pos arity #f)
(lp metas
(+ pos arity-header-len)
- (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (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-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
- (pack-arity-flags #f #f #f #t #f) 0 0)
+ (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
+ (pack-arity-flags #f #f #f #t #f) 0 0 0)
(let lp* ((arities arities) (pos (+ pos arity-header-len))
- (offsets offsets))
+ (relocs relocs))
(match arities
- (() (lp metas pos offsets))
+ (() (lp metas pos relocs))
((arity . arities)
- (write-arity-header pos arity #t)
(lp* arities
(+ pos arity-header-len)
- (acons arity
- (+ pos arity-header-offset-offset)
- offsets)))))))))))
-
-(define (write-arity-links asm bv pos arity-offset-pairs strtab)
- (define (write-symbol sym pos)
- (bytevector-u32-set! bv pos
- (string-table-intern! strtab (symbol->string sym))
- (asm-endianness asm))
- (+ pos 4))
- (define (write-kw-indices pos kw-indices)
- ;; FIXME: Assert that kw-indices is already interned.
- (make-linker-reloc 'abs32/1 pos 0
- (intern-constant asm kw-indices)))
- (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
- (match pairs
- (()
- (unless (= pos (bytevector-length bv))
- (error "expected to fully fill the bytevector"
- pos (bytevector-length bv)))
- relocs)
- (((arity . offset) . pairs)
- (bytevector-u32-set! bv offset pos (asm-endianness asm))
- (let ((pos (fold write-symbol
- pos
- (append (arity-req arity)
- (arity-opt arity)
- (cond
- ((arity-rest arity) => list)
- (else '()))))))
- (match (arity-kw-indices arity)
- (() (lp pos pairs relocs))
- (kw-indices
- (lp (+ pos 4)
- pairs
- (cons (write-kw-indices pos kw-indices) relocs)))))))))
+ (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)))
- (size (fold (lambda (meta size)
- (+ size (meta-arities-size meta)))
- arities-prefix-len
- metas))
+ (header-size (fold (lambda (meta size)
+ (+ size (meta-arities-header-size meta)))
+ arities-prefix-len
+ metas))
(strtab (make-string-table))
- (bv (make-bytevector size 0)))
- (let ((kw-indices-relocs
- (call-with-values
- (lambda ()
- (write-arity-headers metas bv endianness))
- (lambda (pos arity-offset-pairs)
- (write-arity-links asm bv pos arity-offset-pairs strtab)))))
- (let ((strtab (make-object asm '.guile.arities.strtab
- (link-string-table! strtab)
- '() '()
- #:type SHT_STRTAB #:flags 0)))
+ (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
- bv
- kw-indices-relocs '()
+ (bytevector-append headers (get-name-bv))
+ relocs '()
#:type SHT_PROGBITS #:flags 0
#:link (elf-section-index
(linker-object-section strtab)))
(bytevector-u64-set! bv 0 val (asm-endianness asm))
(put-bytevector port bv)))
- (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 (meta->subprogram-die meta)
`(subprogram
(@ ,@(cond
(lp sources
;; Guile line and column numbers are 0-indexed, but
;; they are 1-indexed for DWARF.
- (cons (list pc
- (if file (intern-file file) 0)
- (if line (1+ line))
- (if col (1+ col)))
- out))))
+ (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
('language (language-name->code val))
('stmt-list val)))
- (define (exact-integer? val)
- (and (number? val) (integer? val) (exact? 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 #xffffffff) 'data4)
((<= code #xffffffffffffffff) 'data8)
(else 'uleb128)))
- ((symbol? val) 'addr)
(else (error "unhandled case" attr val code))))
(define (add-die-relocation! kind sym)
;; Link text object after constants, so that the
;; constants initializer gets included.
((text) (link-text-object asm))
- ((dt) (link-dynamic-section asm text rw rw-init))
+ ((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))
;; sections adds entries to the string table.
((shstrtab) (link-shstrtab asm)))
(filter identity
- (list text ro rw dt symtab strtab arities arities-strtab
+ (list text ro frame-maps rw dt symtab strtab
+ arities arities-strtab
docstrs docstrs-strtab procprops
dinfo dabbrev dstrtab dloc dline
shstrtab))))
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?))
+ (define (asm-constant-vector asm)
+ (list->vector (reverse (map car (vlist->list (asm-constants asm))))))
+ (let ((bv (link-elf (link-objects asm) #:page-aligned? page-aligned?)))
+ (cons bv (if (asm-to-file? asm) #f (asm-constant-vector asm)))))
HCoop / bpt / guile.git / blobdiff