(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))
(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))))))
(else
(error "don't know how to intern" obj))))
(cond
"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))))
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(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)))
((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)
;; FIXME: Define these somewhere central, shared with C.
(define *bytecode-major-version* #x0202)
-(define *bytecode-minor-version* 4)
+(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},
;;; 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
;;; 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))
+(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))))))
-;; The offset of "offset" within arity header, in bytes.
-(define arity-header-offset-offset (* 2 4))
+(define (port-position port)
+ (seek port 0 SEEK_CUR))
(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys?
has-keyword-args? is-case-lambda?
(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
('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)
HCoop / bpt / guile.git / blobdiff