mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

More expansion-time-only definitions in assembler.scm

Browse source 
* module/system/vm/assembler.scm (define-inline): Change so that the
  defined macro is only defined at expansion-time.
  (u32-ref, u32-set!, s32-ref, s32-set!, pack-arity-flags): Use
  define-inline.
  (pack-flags, assert-match, *block-size*, id-append, assembler)
  (define-assembler, visit-opcodes, define-macro-assembler): Wrap in
  eval-when expand.
This commit is contained in:
Andy Wingo 2014-04-21 12:13:54 +02:00
parent dece041203
commit 28e12ea0c4
1 changed files with 159 additions and 152 deletions
Download patch file Download diff file Expand all files Collapse all files

311
module/system/vm/assembler.scm
View file

@ -65,14 +65,16 @@
;; Like define-inlinable, but only for first-order uses of the defined ;; Like define-inlinable, but only for first-order uses of the defined
;; routine. Should residualize less code. ;; routine. Should residualize less code.
(define-syntax define-inline (eval-when (expand)
(lambda (x) (define-syntax define-inline
(syntax-case x () (lambda (x)
((_ (name arg ...) body ...) (syntax-case x ()
(with-syntax (((temp ...) (generate-temporaries #'(arg ...)))) ((_ (name arg ...) body ...)
#`(define-syntax-rule (name temp ...) (with-syntax (((temp ...) (generate-temporaries #'(arg ...))))
(let ((arg temp) ...) #`(eval-when (expand)
body ...))))))) (define-syntax-rule (name temp ...)
(let ((arg temp) ...)
body ...)))))))))
;;; Bytecode consists of 32-bit units, often subdivided in some way. ;;; Bytecode consists of 32-bit units, often subdivided in some way.
;;; These helpers create one 32-bit unit from multiple components. ;;; These helpers create one 32-bit unit from multiple components.
@ -123,24 +125,25 @@
(error "out of range" z)) (error "out of range" z))
(logior x (ash y 8) (ash z 16) (ash w 24))) (logior x (ash y 8) (ash z 16) (ash w 24)))
(define-syntax pack-flags (eval-when (expand)
(syntax-rules () (define-syntax pack-flags
;; Add clauses as needed. (syntax-rules ()
((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0) ;; Add clauses as needed.
(if f2 (ash 2 0) 0))))) ((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. ;;; 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))) (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)) (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))) (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)) (bytevector-s32-native-set! buf (* n 4) val))
@ -149,10 +152,11 @@
;;; A <meta> entry collects metadata for one procedure. Procedures are ;;; A <meta> entry collects metadata for one procedure. Procedures are
;;; written as contiguous ranges of bytecode. ;;; written as contiguous ranges of bytecode.
;;; ;;;
(define-syntax-rule (assert-match arg pattern kind) (eval-when (expand)
(let ((x arg)) (define-syntax-rule (assert-match arg pattern kind)
(unless (match x (pattern #t) (_ #f)) (let ((x arg))
(error (string-append "expected " kind) x)))) (unless (match x (pattern #t) (_ #f))
(error (string-append "expected " kind) x)))))
(define-record-type <meta> (define-record-type <meta>
(%make-meta label properties low-pc high-pc arities) (%make-meta label properties low-pc high-pc arities)
@ -185,7 +189,8 @@
(high-pc arity-high-pc set-arity-high-pc!) (high-pc arity-high-pc set-arity-high-pc!)
(definitions arity-definitions set-arity-definitions!)) (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 ;;; An assembler collects all of the words emitted during assembly, and
;;; also maintains ancillary information such as the constant table, a ;;; also maintains ancillary information such as the constant table, a
@ -365,133 +370,134 @@ later by the linker."
;;; opcode in `(instruction-list)'. ;;; opcode in `(instruction-list)'.
;;; ;;;
(eval-when (expand compile load eval) (eval-when (expand)
(define (id-append ctx a b) (define (id-append ctx a b)
(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))) (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
(define-syntax assembler (define-syntax assembler
(lambda (x) (lambda (x)
(define-syntax op-case (define-syntax op-case
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ asm name ((type arg ...) code ...) clause ...) ((_ asm name ((type arg ...) code ...) clause ...)
#`(if (eq? name 'type) #`(if (eq? name 'type)
(with-syntax (((arg ...) (generate-temporaries #'(arg ...)))) (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
#'((arg ...) #'((arg ...)
code ...)) code ...))
(op-case asm name clause ...))) (op-case asm name clause ...)))
((_ asm name) ((_ asm name)
#'(error "unmatched name" name))))) #'(error "unmatched name" name)))))
(define (pack-first-word asm opcode type) (define (pack-first-word asm opcode type)
(with-syntax ((opcode opcode)) (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 (op-case
asm type asm type
((U8_X24) ((U8_U24 a b)
(emit asm opcode)) (emit asm (pack-u8-u24 a b)))
((U8_U24 arg) ((U8_L24 a label)
(emit asm (pack-u8-u24 opcode arg)))
((U8_L24 label)
(record-label-reference asm label) (record-label-reference asm label)
(emit asm opcode)) (emit asm a))
((U8_U8_I16 a imm) ((U32 a)
(emit asm (pack-u8-u8-u16 opcode a (object-address imm)))) (emit asm a))
((U8_U12_U12 a b) ((I32 imm)
(emit asm (pack-u8-u12-u12 opcode a b))) (let ((val (object-address imm)))
((U8_U8_U8_U8 a b c) (unless (zero? (ash val -32))
(emit asm (pack-u8-u8-u8-u8 opcode a b c)))))) (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)))))
(define (pack-tail-word asm type) (syntax-case x ()
(op-case ((_ name opcode word0 word* ...)
asm type (with-syntax ((((formal0 ...)
((U8_U24 a b) code0 ...)
(emit asm (pack-u8-u24 a b))) (pack-first-word #'asm
((U8_L24 a label) (syntax->datum #'opcode)
(record-label-reference asm label) (syntax->datum #'word0)))
(emit asm a)) ((((formal* ...)
((U32 a) code* ...) ...)
(emit asm a)) (map (lambda (word) (pack-tail-word #'asm word))
((I32 imm) (syntax->datum #'(word* ...)))))
(let ((val (object-address imm))) #'(lambda (asm formal0 ... formal* ... ...)
(unless (zero? (ash val -32)) (unless (asm? asm) (error "not an asm"))
(error "FIXME: enable truncation of negative fixnums when cross-compiling")) code0 ...
(emit asm val))) code* ... ...
((A32 imm) (reset-asm-start! asm))))))))
(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 assemblers (make-hash-table))
(define-syntax define-assembler (eval-when (expand)
(lambda (x) (define-syntax define-assembler
(syntax-case x () (lambda (x)
((_ name opcode kind arg ...) (syntax-case x ()
(with-syntax ((emit (id-append #'name #'emit- #'name))) ((_ name opcode kind arg ...)
#'(begin (with-syntax ((emit (id-append #'name #'emit- #'name)))
(define emit #'(begin
(let ((emit (assembler name opcode arg ...))) (define emit
(hashq-set! assemblers 'name emit) (let ((emit (assembler name opcode arg ...)))
emit)) (hashq-set! assemblers 'name emit)
(export emit))))))) emit))
(export emit)))))))
(define-syntax visit-opcodes (define-syntax visit-opcodes
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((visit-opcodes macro arg ...) ((visit-opcodes macro arg ...)
(with-syntax (((inst ...) (with-syntax (((inst ...)
(map (lambda (x) (datum->syntax #'macro x)) (map (lambda (x) (datum->syntax #'macro x))
(instruction-list)))) (instruction-list))))
#'(begin #'(begin
(macro arg ... . inst) (macro arg ... . inst)
...)))))) ...)))))))
(visit-opcodes define-assembler) (visit-opcodes define-assembler)
@ -662,17 +668,18 @@ returned instead."
;;; some higher-level operations. ;;; some higher-level operations.
;;; ;;;
(define-syntax define-macro-assembler (eval-when (expand)
(lambda (x) (define-syntax define-macro-assembler
(syntax-case x () (lambda (x)
((_ (name arg ...) body body* ...) (syntax-case x ()
(with-syntax ((emit (id-append #'name #'emit- #'name))) ((_ (name arg ...) body body* ...)
#'(begin (with-syntax ((emit (id-append #'name #'emit- #'name)))
(define emit #'(begin
(let ((emit (lambda (arg ...) body body* ...))) (define emit
(hashq-set! assemblers 'name emit) (let ((emit (lambda (arg ...) body body* ...)))
emit)) (hashq-set! assemblers 'name emit)
(export emit))))))) emit))
(export emit))))))))
(define-macro-assembler (load-constant asm dst obj) (define-macro-assembler (load-constant asm dst obj)
(cond (cond
@ -1473,9 +1480,9 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
(define (port-position port) (define (port-position port)
(seek port 0 SEEK_CUR)) (seek port 0 SEEK_CUR))
(define-syntax-rule (pack-arity-flags has-rest? allow-other-keys? (define-inline (pack-arity-flags has-rest? allow-other-keys?
has-keyword-args? is-case-lambda? has-keyword-args? is-case-lambda?
is-in-case-lambda?) is-in-case-lambda?)
(logior (if has-rest? (ash 1 0) 0) (logior (if has-rest? (ash 1 0) 0)
(if allow-other-keys? (ash 1 1) 0) (if allow-other-keys? (ash 1 1) 0)
(if has-keyword-args? (ash 1 2) 0) (if has-keyword-args? (ash 1 2) 0)