|#
-;;;; Assembler Machine Dependencies. Intel 386 version
+;;;; Assembler Machine Dependencies. AMD x86-64 version
(declare (usual-integrations))
\f
(define-integrable maximum-padding-length
;; Instructions can be any number of bytes long.
- ;; Thus the maximum padding is 3 bytes.
- 24)
+ ;; Thus the maximum padding is 7 bytes.
+ 56)
(define-integrable padding-string
;; Pad with HLT instructions
|#
-;;;; Intel i386 Specific Coercions
+;;;; AMD x86-64 Specific Coercions
(declare (usual-integrations))
\f
(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+(define coerce-64-bit-unsigned (make-coercion 'UNSIGNED 64))
(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
-(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
\ No newline at end of file
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
+(define coerce-64-bit-signed (make-coercion 'SIGNED 64))
\ No newline at end of file
|#
-;;; i386 Instruction Set Macros. Early version
+;;; AMD x86-64 Instruction Set Macros. Early version
;;; NOPs for now.
(declare (usual-integrations))
(if (syntax-match? '(IDENTIFIER DATUM * DATUM) (cdr form))
`(DEFINE-INSTRUCTION ,(cadr form)
(()
- (BYTE (8 ,(close-syntax (caddr form) environment)))
+ (BITS (8 ,(close-syntax (caddr form) environment)))
,@(map (lambda (extra)
- `(BYTE (8 ,(close-syntax extra environment))))
+ `(BITS (8 ,(close-syntax extra environment))))
(cdddr form))))
(ill-formed-syntax form)))))
,(compile-database (cdr form) environment
(lambda (pattern actions)
(let ((keyword (car pattern))
- (categories (car actions))
- (mode (cadr actions))
- (register (caddr actions))
- (tail (cdddr actions)))
+ (categories (list-ref actions 0))
+ (rex-prefix (list-ref actions 1))
+ (mode (list-ref actions 2))
+ (register (list-ref actions 3))
+ (tail (list-tail actions 4)))
`(,(close-syntax 'MAKE-EFFECTIVE-ADDRESS environment)
',keyword
',categories
+ ',rex-prefix
,(integer-syntaxer mode environment 'UNSIGNED 2)
,(integer-syntaxer register environment 'UNSIGNED 3)
,(if (null? tail)
- `()
+ `(,(close-syntax 'QUOTE environment) ())
(process-fields tail #f environment))))))))))
-;; This one is necessary to distinguish between r/mW mW, etc.
+;; This one is necessary to distinguish between r/m-ea, m-ea, etc.
(define-syntax define-ea-transformer
(sc-macro-transformer
`(MATCH-RESULT)))))
(ill-formed-syntax form)))))
\f
-;; *** We can't really handle switching these right now. ***
-
-(define-integrable *ADDRESS-SIZE* 32)
-(define-integrable *OPERAND-SIZE* 32)
-
(define (parse-instruction opcode tail early? environment)
(process-fields (cons opcode tail) early? environment))
(expand-variable-width (car fields) early? environment)
(call-with-values (lambda () (expand-fields fields early? environment))
(lambda (code size)
- (if (not (zero? (remainder size 8)))
- (error "Bad syllable size:" size))
+ size ;ignore
code))))
(define (expand-variable-width field early? environment)
(cadr binding)
environment
(map (lambda (clause)
- (call-with-values
- (lambda () (expand-fields (cdr clause) early? environment))
- (lambda (code size)
- (if (not (zero? (remainder size 8)))
- (error "Bad clause size:" size))
- `(,code ,size ,@(car clause)))))
+ (receive (code size)
+ (expand-fields (cdr clause) early? environment)
+ (if (not (zero? (remainder size 8)))
+ (error "Bad clause size:" size))
+ `(,code ,size ,@(car clause))))
clauses)))))
\f
(define (expand-fields fields early? environment)
(if (pair? fields)
- (call-with-values
- (lambda () (expand-fields (cdr fields) early? environment))
- (lambda (tail tail-size)
- (case (caar fields)
- ;; For opcodes and fixed fields of the instruction
- ((BYTE)
- ;; (BYTE (8 #xff))
- ;; (BYTE (16 (+ foo #x23) SIGNED))
- (call-with-values
- (lambda ()
- (collect-byte (cdar fields) tail environment))
- (lambda (code size)
- (values code (+ size tail-size)))))
- ((ModR/M)
- ;; (ModR/M 2 source) = /2 r/m(source)
- ;; (ModR/M r target) = /r r/m(target)
- (if early?
- (error "No early support for ModR/M -- Fix i386/insmac.scm"))
- (let ((field (car fields)))
- (let ((digit-or-reg (cadr field))
- (r/m (caddr field)))
- (values `(,(close-syntax 'CONS-SYNTAX environment)
- (,(close-syntax 'EA/REGISTER environment) ,r/m)
- (,(close-syntax 'CONS-SYNTAX environment)
- ,(integer-syntaxer digit-or-reg environment
- 'UNSIGNED 3)
- (,(close-syntax 'CONS-SYNTAX environment)
- (,(close-syntax 'EA/MODE environment) ,r/m)
- (,(close-syntax 'APPEND-SYNTAX! environment)
- (,(close-syntax 'EA/EXTRA environment) ,r/m)
- ,tail))))
- (+ 8 tail-size)))))
- ;; For immediate operands whose size depends on the operand
- ;; size for the instruction (halfword vs. longword)
- ((IMMEDIATE)
- (values
- (let ((field (car fields)))
- (let ((value (cadr field))
- (mode (if (pair? (cddr field)) (caddr field) 'OPERAND))
- (domain
- (if (and (pair? (cddr field)) (pair? (cdddr field)))
- (cadddr field)
- 'SIGNED)))
- `(,(close-syntax 'CONS-SYNTAX environment)
- ,(integer-syntaxer
- value
- environment
- domain
- (case mode
- ((OPERAND) *operand-size*)
- ((ADDRESS) *address-size*)
- (else (error "Unknown IMMEDIATE mode:" mode))))
- ,tail)))
- tail-size))
- (else
- (error "Unknown field kind:" (caar fields))))))
- (values `'() 0)))
-
-(define (collect-byte components tail environment)
+ (receive (tail tail-size) (expand-fields (cdr fields) early? environment)
+ (case (caar fields)
+ ;; For opcodes and fixed fields of the instruction
+ ((BITS)
+ ;; (BITS (8 #xff))
+ ;; (BITS (16 (+ foo #x23) SIGNED))
+ (receive (code size) (collect-bits (cdar fields) tail environment)
+ (values code (+ size tail-size))))
+ ((PREFIX)
+ ;; (PREFIX (OPERAND size) (REGISTER [reg]) (EA ea))
+ (if early?
+ (error "No early support for PREFIX -- Fix x86-64/insmac.scm"))
+ (values (collect-prefix (cdar fields) tail environment) -1))
+ ((ModR/M)
+ ;; (ModR/M 2 source) = /2 r/m(source)
+ ;; (ModR/M r target) = /r r/m(target)
+ (if early?
+ (error "No early support for ModR/M -- Fix x86-64/insmac.scm"))
+ (values (collect-ModR/M (cdar fields) tail environment) -1))
+ (else
+ (error "Unknown field kind:" (caar fields)))))
+ (values `(,(close-syntax 'QUOTE environment) ()) 0)))
+
+(define (collect-bits components tail environment)
(let loop ((components components))
(if (pair? components)
- (call-with-values (lambda () (loop (cdr components)))
- (lambda (byte-tail byte-size)
- (let ((size (caar components))
- (expression (cadar components))
- (type (if (pair? (cddar components))
- (caddar components)
- 'UNSIGNED)))
- (values `(,(close-syntax 'CONS-SYNTAX environment)
- ,(integer-syntaxer expression environment type size)
- ,byte-tail)
- (+ size byte-size)))))
- (values tail 0))))
\ No newline at end of file
+ (receive (bits-tail bits-size) (loop (cdr components))
+ (let ((size (caar components))
+ (expression (cadar components))
+ (type (if (pair? (cddar components))
+ (caddar components)
+ 'UNSIGNED)))
+ (values `(,(close-syntax 'CONS-SYNTAX environment)
+ ,(integer-syntaxer expression environment type size)
+ ,bits-tail)
+ (+ size bits-size))))
+ (values tail 0))))
+
+(define (collect-prefix options tail environment)
+ (let loop ((options options) (operand #f) (register #f) (r/m #f))
+ (if (pair? options)
+ (case (caar options)
+ ((OPERAND) (loop (cdr options) (cadar options) register r/m))
+ ((OPCODE-REGISTER)
+ (loop (cdr options)
+ operand
+ (or (not (pair? (cdar options))) (cadar options))
+ r/m))
+ ((ModR/M)
+ ;; (ModR/M <r/m>), for fixed digits
+ ;; (ModR/M <reg> <r/m>), for registers
+ (if (pair? (cddar options))
+ (loop (cdr options) operand (cadar options) (caddar options))
+ (loop (cdr options) operand #f (cadar options))))
+ (else (error "Bad instruction prefix option:" (car options))))
+ (let ((cons-prefix (close-syntax 'CONS-PREFIX environment)))
+ `(,cons-prefix ,operand ,register ,r/m ,tail)))))
+
+(define (collect-ModR/M field tail environment)
+ (let ((digit-or-reg (car field))
+ (ea (cadr field)))
+ `(,(close-syntax 'CONS-ModR/M environment)
+ ,(integer-syntaxer
+ (if (integer? digit-or-reg)
+ (fix:and digit-or-reg 7)
+ `(,(close-syntax 'FIX:AND environment) ,digit-or-reg 7))
+ environment
+ 'UNSIGNED
+ 3)
+ ,ea
+ ,tail)))
\ No newline at end of file
;;;; Addressing modes
;; r/m part of ModR/M byte and SIB byte.
-;; These are valid only for 32-bit addressing.
+;; These are valid only for 64-bit addressing.
(define-ea-database
+
+;;;; Register
+
+ ((R (? r extended-reg))
+ (REGISTER)
+ #x41 #b11 r)
+
((R (? r))
(REGISTER)
- #b11 r)
+ 0 #b11 r)
+
+;;;; Register-indirect
+
+ ((@R (? r extended-indirect-reg))
+ (MEMORY)
+ #x41 #b00 r)
((@R (? r indirect-reg))
(MEMORY)
- #b00 r)
+ 0 #b00 r)
- ((@R 5) ; EBP
+ ;; Mode of 0 with R/M of 4 means that what follows is a SIB format,
+ ;; and R/M of 5 means that what follows is a PC-relative immediate
+ ;; offset (in 64-bit mode), so we must have special cases for rsp,
+ ;; rbp, r12, and r13.
+
+ ;; SIB format, with no scale.
+ ((@R 4) ; rsp
(MEMORY)
- #b01 5
- (BYTE (8 0)))
+ 0 #b00 4
+ (BITS (3 4)
+ (3 4)
+ (2 0)))
- ((@R 4) ; ESP
+ ;; rbp plus offset, with zero offset.
+ ((@R 5) ; rbp
(MEMORY)
- #b00 4
- (BYTE (3 4)
+ 0 #b01 5
+ (BITS (8 0)))
+
+ ;; SIB format, with no scale.
+ ((@R 12)
+ (MEMORY)
+ #x41 #b00 4
+ (BITS (3 4)
(3 4)
(2 0)))
+ ;; r13 plus offset, with zero offset.
+ ((@R 13)
+ (MEMORY)
+ #x41 #b01 5
+ (BITS (8 0)))
+\f
+;;;; Register-indirect with 8-bit Offset
+
+ ;; Mode of #b01 with R/M of 13 means SIB plus offset, so we must
+ ;; have special cases for rsp and r12.
+
+ ((@RO B (? r extended-index-reg) (? offset))
+ (MEMORY)
+ #x41 #b01 r
+ (BITS (8 offset SIGNED)))
+
((@RO B (? r index-reg) (? offset))
(MEMORY)
- #b01 r
- (BYTE (8 offset SIGNED)))
+ 0 #b01 r
+ (BITS (8 offset SIGNED)))
+
+ ((@RO UB (? r extended-index-reg) (? offset))
+ (MEMORY)
+ #x41 #b01 r
+ (BITS (8 offset UNSIGNED)))
((@RO UB (? r index-reg) (? offset))
(MEMORY)
- #b01 r
- (BYTE (8 offset UNSIGNED)))
+ 0 #b01 r
+ (BITS (8 offset UNSIGNED)))
- ((@RO B 4 (? offset))
+ ((@RO B 4 (? offset)) ; rsp
(MEMORY)
- #b01 4
- (BYTE (3 4)
+ 0 #b01 4
+ (BITS (3 4)
+ (3 4)
+ (2 0)
+ (8 offset SIGNED)))
+
+ ((@RO B 12 (? offset))
+ (MEMORY)
+ #x41 #b01 4
+ (BITS (3 4)
(3 4)
(2 0)
(8 offset SIGNED)))
((@RO UB 4 (? offset))
(MEMORY)
- #b01 4
- (BYTE (3 4)
+ 0 #b01 4
+ (BITS (3 4)
(3 4)
(2 0)
(8 offset UNSIGNED)))
- ((@RO W (? r index-reg) (? offset))
+ ((@RO UB 12 (? offset))
(MEMORY)
- #b10 r
- (IMMEDIATE offset ADDRESS SIGNED))
+ #x41 #b01 4
+ (BITS (3 4)
+ (3 4)
+ (2 0)
+ (8 offset UNSIGNED)))
+\f
+;;;; Register-indirect with 32-bit Offset
- ((@RO UW (? r index-reg) (? offset))
+ ((@RO L (? r extended-index-reg) (? offset signed-long))
(MEMORY)
- #b10 r
- (IMMEDIATE offset ADDRESS UNSIGNED))
-\f
- ((@RO W 4 (? offset)) ; ESP
+ #x41 #b10 r
+ (BITS (32 offset SIGNED)))
+
+ ((@RO L (? r index-reg) (? offset signed-long))
+ (MEMORY)
+ 0 #b10 r
+ (BITS (32 offset SIGNED)))
+
+ ((@RO L 4 (? offset signed-long)) ; rsp
+ (MEMORY)
+ 0 #b10 #b100
+ (BITS (3 4)
+ (3 4)
+ (2 0)
+ (32 offset SIGNED)))
+
+ ((@RO L 12 (? offset signed-long))
+ (MEMORY)
+ #x41 #b10 #b100
+ (BITS (3 4)
+ (3 4)
+ (2 0)
+ (32 offset SIGNED)))
+
+ ((@RO UL (? r extended-index-reg) (? offset unsigned-long))
+ (MEMORY)
+ #x41 #b10 r
+ (BITS (32 offset UNSIGNED)))
+
+ ((@RO UL (? r index-reg) (? offset unsigned-long))
(MEMORY)
- #b10 #b100
- (BYTE (3 4)
+ 0 #b10 r
+ (BITS (32 offset UNSIGNED)))
+
+ ((@RO UL 4 (? offset unsigned-long)) ; rsp
+ (MEMORY)
+ 0 #b10 #b100
+ (BITS (3 4)
(3 4)
- (2 0))
- (IMMEDIATE offset ADDRESS SIGNED))
+ (2 0)
+ (32 offset UNSIGNED)))
- ((@RO UW 4 (? offset)) ; ESP
+ ((@RO UL 12 (? offset unsigned-long))
(MEMORY)
- #b10 #b100
- (BYTE (3 4)
+ #x41 #b10 #b100
+ (BITS (3 4)
(3 4)
- (2 0))
- (IMMEDIATE offset ADDRESS UNSIGNED))
+ (2 0)
+ (32 offset UNSIGNED)))
+\f
+;;;; Register-indirect Indexed
+
+ ((@RI (? b extended-base-reg) (? i extended-index-reg) (? s index-scale))
+ (MEMORY)
+ #x43 #b00 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)))
+
+ ((@RI (? b extended-base-reg) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #x41 #b00 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)))
+
+ ((@RI (? b base-reg) (? i extended-index-reg) (? s index-scale))
+ (MEMORY)
+ #x42 #b00 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)))
((@RI (? b base-reg) (? i index-reg) (? s index-scale))
(MEMORY)
- #b00 #b100
- (BYTE (3 b)
+ 0 #b00 #b100
+ (BITS (3 b)
(3 i)
(2 s)))
- ((@RI 5 (? i index-reg) (? s index-scale)) ; EBP
+ ((@RI 5 (? i extended-index-reg) (? s index-scale)) ; rbp
+ (MEMORY)
+ #x42 #b01 #b100
+ (BITS (3 5)
+ (3 i)
+ (2 s)
+ (8 0)))
+
+ ((@RI 5 (? i index-reg) (? s index-scale)) ; rbp
(MEMORY)
- #b01 #b100
- (BYTE (3 5)
+ 0 #b01 #b100
+ (BITS (3 5)
(3 i)
(2 s)
(8 0)))
- ((@ROI B (? b) (? offset) (? i index-reg) (? s index-scale))
+ ((@RI 13 (? i extended-index-reg) (? s index-scale))
+ (MEMORY)
+ #x43 #b01 #b100
+ (BITS (3 5)
+ (3 i)
+ (2 s)
+ (8 0)))
+
+ ((@RI 13 (? i index-reg) (? s index-scale))
+ (MEMORY)
+ #x41 #b01 #b100
+ (BITS (3 5)
+ (3 i)
+ (2 s)
+ (8 0)))
+\f
+;;;; Register-indirect with Offset, Indexed
+
+ ((@ROI B (? b extended-reg) (? offset signed-byte) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x43 #b01 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (8 offset SIGNED)))
+
+ ((@ROI B (? b extended-reg) (? offset signed-byte) (? i index-reg)
+ (? s index-scale))
(MEMORY)
- #b01 #b100
- (BYTE (3 b)
+ #x41 #b01 #b100
+ (BITS (3 b)
(3 i)
(2 s)
(8 offset SIGNED)))
- ((@ROI UB (? b) (? offset) (? i index-reg) (? s index-scale))
+ ((@ROI B (? b) (? offset signed-byte) (? i extended-index-reg)
+ (? s index-scale))
(MEMORY)
- #b01 #b100
- (BYTE (3 b)
+ #x42 #b01 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (8 offset SIGNED)))
+
+ ((@ROI B (? b) (? offset signed-byte) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ 0 #b01 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (8 offset SIGNED)))
+
+ ((@ROI UB (? b extended-reg) (? offset unsigned-byte)
+ (? i extended-index-reg) (? s index-scale))
+ (MEMORY)
+ #x43 #b01 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (8 offset UNSIGNED)))
+
+ ((@ROI UB (? b extended-reg) (? offset unsigned-byte) (? i index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x41 #b01 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (8 offset UNSIGNED)))
+
+ ((@ROI UB (? b) (? offset unsigned-byte) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x42 #b01 #b100
+ (BITS (3 b)
(3 i)
(2 s)
(8 offset UNSIGNED)))
- ((@ROI W (? b) (? offset) (? i index-reg) (? s index-scale))
+ ((@ROI UB (? b) (? offset unsigned-byte) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ 0 #b01 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (8 offset UNSIGNED)))
+\f
+ ((@ROI W (? b extended-reg) (? offset signed-word) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x43 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset SIGNED)))
+
+ ((@ROI W (? b extended-reg) (? offset signed-word) (? i index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x41 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset SIGNED)))
+
+ ((@ROI W (? b) (? offset signed-word) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x42 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset SIGNED)))
+
+ ((@ROI W (? b) (? offset signed-word) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ 0 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset SIGNED)))
+
+ ((@ROI UW (? b extended-reg) (? offset unsigned-word)
+ (? i extended-index-reg) (? s index-scale))
+ (MEMORY)
+ #x43 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset UNSIGNED)))
+
+ ((@ROI UW (? b extended-reg) (? offset unsigned-word) (? i index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x41 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset UNSIGNED)))
+
+ ((@ROI UW (? b) (? offset unsigned-word) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x42 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset UNSIGNED)))
+
+ ((@ROI UW (? b) (? offset unsigned-word) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ 0 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (16 offset UNSIGNED)))
+\f
+ ((@ROI L (? b extended-reg) (? offset signed-long) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x43 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (32 offset SIGNED)))
+
+ ((@ROI L (? b extended-reg) (? offset signed-long) (? i index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x41 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (32 offset SIGNED)))
+
+ ((@ROI L (? b) (? offset signed-long) (? i extended-index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x42 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (32 offset SIGNED)))
+
+ ((@ROI L (? b) (? offset signed-long) (? i index-reg) (? s index-scale))
+ (MEMORY)
+ 0 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (32 offset SIGNED)))
+
+ ((@ROI UL (? b extended-reg) (? offset unsigned-long)
+ (? i extended-index-reg) (? s index-scale))
+ (MEMORY)
+ #x43 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (32 offset UNSIGNED)))
+
+ ((@ROI UL (? b extended-reg) (? offset unsigned-long) (? i index-reg)
+ (? s index-scale))
+ (MEMORY)
+ #x41 #b10 #b100
+ (BITS (3 b)
+ (3 i)
+ (2 s)
+ (32 offset UNSIGNED)))
+
+ ((@ROI UL (? b) (? offset unsigned-long) (? i extended-index-reg)
+ (? s index-scale))
(MEMORY)
- #b10 #b100
- (BYTE (3 b)
+ #x42 #b10 #b100
+ (BITS (3 b)
(3 i)
- (2 s))
- (IMMEDIATE offset ADDRESS SIGNED))
+ (2 s)
+ (32 offset UNSIGNED)))
- ((@ROI UW (? b) (? offset) (? i index-reg) (? s index-scale))
+ ((@ROI UL (? b) (? offset unsigned-long) (? i index-reg) (? s index-scale))
(MEMORY)
- #b10 #b100
- (BYTE (3 b)
+ 0 #b10 #b100
+ (BITS (3 b)
(3 i)
- (2 s))
- (IMMEDIATE offset ADDRESS UNSIGNED))
+ (2 s)
+ (32 offset UNSIGNED)))
- ((@ (? value))
+ ((@PCR (? label))
(MEMORY)
- #b00 #b101
- (IMMEDIATE value ADDRESS)))
+ 0 #b00 #b101
+ (BITS (32 `(- ,label (+ *PC* 4)) SIGNED)))
+
+ ((@PCO (? offset))
+ (MEMORY)
+ 0 #b00 #b101
+ (BITS (32 offset SIGNED))))
\f
-(define-ea-transformer r/mW)
-(define-ea-transformer mW MEMORY)
-(define-ea-transformer r/mB)
-(define-ea-transformer mB MEMORY)
+(define-ea-transformer r/m-ea)
+(define-ea-transformer m-ea MEMORY)
(define-structure (effective-address
(conc-name ea/)
(constructor make-effective-address))
- (keyword false read-only true)
- (categories false read-only true)
- (mode false read-only true)
- (register false read-only true)
- (extra '() read-only true))
+ (keyword #f read-only #t)
+ (categories #f read-only #t)
+ (rex-prefix #f read-only #t)
+ (mode #f read-only #t)
+ (register #f read-only #t)
+ (extra '() read-only #t))
+
+(define (cons-prefix operand-size register r/m tail)
+ (let ((tail
+ (if (eq? operand-size 'W)
+ (cons-syntax (syntax-evaluation #x66 coerce-8-bit-unsigned)
+ tail)
+ tail)))
+ ((lambda (rex-prefix)
+ (if (zero? rex-prefix)
+ tail
+ (cons-syntax (syntax-evaluation rex-prefix coerce-8-bit-unsigned)
+ tail)))
+ (fix:or
+ (case operand-size
+ ;; B must be handled separately; there is no prefix for it.
+ ;; W is handled with a #x66 prefix.
+ ;; L is the default.
+ ((#F W L) 0)
+ ((Q) #x48)
+ (else (error "Invalid operand size:" operand-size)))
+ (let ((extended-register?
+ (or (eqv? register #t)
+ (and register (>= register r8)))))
+ (if r/m
+ (fix:or (if extended-register? #x44 0) (ea/rex-prefix r/m))
+ (if extended-register? #x41 0)))))))
+
+(define (cons-modr/m digit ea tail)
+ (cons-syntax (ea/register ea)
+ (cons-syntax digit
+ (cons-syntax (ea/mode ea)
+ (append-syntax! (ea/extra ea) tail)))))
+
+(declare (integrate-operator opcode-register))
+(define (opcode-register opcode register)
+ (declare (integrate opcode))
+ (+ opcode (if (>= register r8) (- register r8) register)))
+\f
+(define (operand-size s)
+ ;; B must be handled separately in general.
+ (case s
+ ((W L Q) s)
+ (else #f)))
+
+(define (extended-reg r)
+ (and (>= r r8)
+ (- r r8)))
+
+(define (indirect-reg r)
+ (and (< r r8)
+ (not (= r rsp))
+ (not (= r rbp))
+ r))
-(define (sign-extended-byte value)
- (and (fits-in-signed-byte? value)
- value))
+(define (extended-indirect-reg r)
+ (and (not (= r r12))
+ (not (= r r13))
+ (extended-reg r)))
-(define (zero-extended-byte value)
- (and (fits-in-unsigned-byte? value)
- value))
-
-(define-integrable (indirect-reg r)
- (and (not (= r esp))
- (not (= r ebp))
+(define (base-reg r)
+ (and (< r r8)
+ (not (= r rbp))
r))
-(define-integrable (base-reg r)
- (and (not (= r ebp))
- r))
+(define (extended-base-reg r)
+ (and (not (= r r13))
+ (extended-reg r)))
-(define-integrable (index-reg r)
- (and (not (= r esp))
+(define (index-reg r)
+ (and (< r r8)
+ (not (= r rsp))
r))
+(define (extended-index-reg r)
+ (and (not (= r r12))
+ (extended-reg r)))
+
(define (index-scale scale-value)
(case scale-value
((1) #b00)
((2) #b01)
((4) #b10)
((8) #b11)
- (else false)))
\ No newline at end of file
+ (else false)))
+\f
+(define (signed-byte value)
+ (and (fits-in-signed-byte? value)
+ value))
+
+(define (unsigned-byte value)
+ (and (fits-in-unsigned-byte? value)
+ value))
+
+(define (signed-word value)
+ (and (fits-in-signed-word? value)
+ value))
+
+(define (unsigned-word value)
+ (and (fits-in-unsigned-word? value)
+ value))
+
+(define (signed-long value)
+ (and (fits-in-signed-long? value)
+ value))
+
+(define (unsigned-long value)
+ (and (fits-in-unsigned-long? value)
+ value))
+
+(define (signed-quad value)
+ (and (fits-in-signed-quad? value)
+ value))
+
+(define (unsigned-quad value)
+ (and (fits-in-unsigned-quad? value)
+ value))
+
+(define (sign-extended-byte value)
+ (and (fits-in-signed-byte? value)
+ value))
+
+(define (zero-extended-byte value)
+ (and (not (negative? value))
+ (fits-in-signed-byte? value)
+ value))
+
+(define (sign-extended-word value)
+ (and (fits-in-signed-word? value)
+ value))
+
+(define (zero-extended-word value)
+ (and (not (negative? value))
+ (fits-in-signed-word? value)
+ value))
+
+(define (sign-extended-long value)
+ (and (fits-in-signed-long? value)
+ value))
+
+(define (zero-extended-long value)
+ (and (not (negative? value))
+ (fits-in-signed-long? value)
+ value))
+
+(define (sign-extended-quad value)
+ (and (fits-in-signed-quad? value)
+ value))
+
+(define (zero-extended-quad value)
+ (and (not (negative? value))
+ (fits-in-signed-quad? value)
+ value))
\ No newline at end of file
|#
-;;;; Machine Model for the Intel 386, i486, and successors
+;;;; Machine Model for the AMD x86-64
;;; package: (compiler)
(declare (usual-integrations))
(define use-pre/post-increment? false)
(define-integrable endianness 'LITTLE)
(define-integrable addressing-granularity 8)
-(define-integrable scheme-object-width 32)
+(define-integrable scheme-object-width 64)
(define-integrable scheme-type-width 6) ;or 8
;; NOTE: expt is not being constant-folded now.
(- scheme-object-width scheme-type-width))
(define-integrable float-width 64)
-(define-integrable float-alignment 32)
+(define-integrable float-alignment 64)
(define-integrable address-units-per-float
(quotient float-width addressing-granularity))
(define-integrable signed-fixnum/upper-limit
;; (expt 2 (-1+ scheme-datum-width)) ***
- 33554432)
+ #x0200000000000000)
(define-integrable signed-fixnum/lower-limit
(- signed-fixnum/upper-limit))
\f
;;;; Closure format
-;; See microcode/cmpint-i386.h for a description of the layout.
-;; This must return a word based offset.
-;; On the i386, to save space, entries can be at 2 mod 4 addresses,
-;; which makes it impossible if the closure object used for
-;; referencing points to arbitrary entries. Instead, all closure
-;; entry points bump to the canonical entry point, which is always
-;; longword aligned.
+;;; See microcode/cmpintmd/x86-64.h for a description of the layout.
+
+(define-integrable closure-entry-size 2)
+
+(define-integrable address-units-per-closure-manifest address-units-per-object)
+(define-integrable address-units-per-entry-format-code 4)
+(define-integrable address-units-per-closure-entry-count 4)
+(define-integrable address-units-per-closure-padding 4)
+
+;;; (MOV Q (R ,rax) (&U <entry>)) 48 B8 <eight-byte immediate>
+;;; (CALL (R ,rax)) FF D0
+(define-integrable address-units-per-closure-entry-instructions 12)
+
+(define-integrable address-units-per-closure-entry
+ (+ address-units-per-entry-format-code
+ address-units-per-closure-entry-instructions))
+
+;;; Note:
+;;;
+;;; (= address-units-per-closure-entry #| 16 |#
+;;; (* closure-entry-size #| 2 |# address-units-per-object #| 8 |#))
+
+;;; Given the number of entries in a closure, and the index of an
+;;; entry, return the number of words from that entry's closure
+;;; pointer to the location of the storage for the closure's first
+;;; free variable. In this case, the closure pointer is the same as
+;;; the compiled entry pointer into the entry instructions. This is
+;;; different from the i386, where the entry instructions are not all
+;;; object-aligned, and thus the closure pointer is adjusted to point
+;;; to the first entry in the closure block, which is always aligned.
+;;;
+;;; When there are zero entries, the `closure' is just a vector, and
+;;; represented by a tagged pointer to a manifest, following which are
+;;; the free variables. In this case, the first offset is one object
+;;; past the manifest's address.
(define (closure-first-offset nentries entry)
- entry ; ignored
(if (zero? nentries)
1
- (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2)))
+ (* (- nentries entry) closure-entry-size)))
-;; This is from the start of the complete closure object,
-;; viewed as a vector, and including the header word.
+;;; Given the number of entry points in a closure, return the distance
+;;; in objects from the address of the manifest closure to the address
+;;; of the first free variable.
(define (closure-object-first-offset nentries)
- (case nentries
- ((0) 1)
- ((1) 4)
- (else
- (quotient (+ 5 (* 5 nentries)) 2))))
+ (if (zero? nentries)
+ 1 ;One vector manifest.
+ ;; One object for the closure manifest, and one object for the
+ ;; leading entry count and the trailing padding.
+ (+ 2 (* nentries closure-entry-size))))
-;; Bump from one entry point to another.
+;;; Given the number of entries in a closure, and the indices of two
+;;; entries, return the number of bytes separating the two entries.
(define (closure-entry-distance nentries entry entry*)
- nentries ; ignored
- (* 10 (- entry* entry)))
+ nentries ;ignore
+ (* (- entry* entry) address-units-per-closure-entry))
-;; Bump to the canonical entry point.
+;;; Given the number of entries in a closure, and the index of an
+;;; entry, return the number of bytes to add to a possibly misaligned
+;;; closure pointer to obtain a `canonical' entry point, which is
+;;; aligned on an object boundary. Since all closure entry points are
+;;; aligned thus on this machine, we need adjust nothing.
(define (closure-environment-adjustment nentries entry)
- (declare (integrate-operator closure-entry-distance))
- (closure-entry-distance nentries entry 0))
+ nentries entry ;ignore
+ 0)
\f
;;;; Machine registers
-(define eax 0) ; acumulator
-(define ecx 1) ; counter register
-(define edx 2) ; multiplication high-half target
-(define ebx 3) ; distinguished useful register
-(define esp 4) ; stack pointer
-(define ebp 5) ; frame pointer
-(define esi 6) ; string source pointer
-(define edi 7) ; string destination pointer
-
-;; Virtual floating point registers:
-;; Floating point stack locations, allocated as if registers.
-;; One left free to allow room to push and operate.
-
-(define fr0 8)
-(define fr1 9)
-(define fr2 10)
-(define fr3 11)
-(define fr4 12)
-(define fr5 13)
-(define fr6 14)
-(define fr7 15)
-
+(define rax 0) ; accumulator
+(define rcx 1) ; counter register
+(define rdx 2) ; multiplication high-half target
+(define rbx 3) ; distinguished useful register
+(define rsp 4) ; stack pointer
+(define rbp 5) ; frame pointer
+(define rsi 6) ; string source pointer
+(define rdi 7) ; string destination pointer
+
+;;; More general-purpose registers.
+
+(define r8 8)
+(define r9 9)
+(define r10 10)
+(define r11 11)
+(define r12 12)
+(define r13 13)
+(define r14 14)
+(define r15 15)
+
+;;; x87 floating-point stack locations, allocated as if registers.
+
+(define fr0 16)
+(define fr1 17)
+(define fr2 18)
+(define fr3 19)
+(define fr4 20)
+(define fr5 21)
+(define fr6 22)
+(define fr7 23)
+
+;;; 64-bit media registers (deprecated).
+
+(define mmx0 24)
+(define mmx1 25)
+(define mmx2 26)
+(define mmx3 27)
+(define mmx4 28)
+(define mmx5 29)
+(define mmx6 30)
+(define mmx7 31)
+
+;;; 128-bit media registers.
+
+(define xmm0 32)
+(define xmm1 33)
+(define xmm2 34)
+(define xmm3 35)
+(define xmm4 36)
+(define xmm5 37)
+(define xmm6 38)
+(define xmm7 39)
+(define xmm8 40)
+(define xmm9 41)
+(define xmm10 42)
+(define xmm11 43)
+(define xmm12 44)
+(define xmm13 45)
+(define xmm14 46)
+(define xmm15 47)
+\f
(define number-of-machine-registers 16)
(define number-of-temporary-registers 256)
-(define-integrable regnum:stack-pointer esp)
-(define-integrable regnum:datum-mask ebp)
-(define-integrable regnum:regs-pointer esi)
-(define-integrable regnum:free-pointer edi)
+(define-integrable regnum:stack-pointer rsp)
+(define-integrable regnum:datum-mask rbp)
+(define-integrable regnum:regs-pointer rsi)
+(define-integrable regnum:free-pointer rdi)
(define-integrable (machine-register-known-value register)
register ; ignored
false)
(define (machine-register-value-class register)
- (cond ((<= eax register ebx)
+ (cond ((<= rax register rbx)
value-class=object)
((= register regnum:datum-mask)
value-class=immediate)
(= register regnum:free-pointer)
(= register regnum:regs-pointer))
value-class=address)
+ ((<= r8 register r15)
+ value-class=object)
((<= fr0 register fr7)
value-class=float)
+ ((<= mmx0 register mmx7)
+ (error "MMX media registers not allocated:" register))
+ ((<= xmm0 register xmm15)
+ (error "XMM media registers not allocated:" register))
(else
- (error "illegal machine register" register))))
+ (error "Invalid machine register:" register))))
(define-integrable register-block/memtop-offset 0)
(define-integrable register-block/int-mask-offset 1)
(define-integrable register-block/stack-guard-offset 11)
(define-integrable (fits-in-signed-byte? value)
- (and (>= value -128) (< value 128)))
+ (<= #x-80 value #x7f))
(define-integrable (fits-in-unsigned-byte? value)
- (and (>= value 0) (< value 128)))
+ (<= 0 value #xff))
+
+(define-integrable (fits-in-signed-word? value)
+ (<= #x-8000 value #x7fff))
+
+(define-integrable (fits-in-unsigned-word? value)
+ (<= 0 value #xffff))
+
+(define-integrable (fits-in-signed-long? value)
+ (<= #x-80000000 value #x7fffffff))
+
+(define-integrable (fits-in-unsigned-long? value)
+ (<= 0 value #xffffffff))
+
+(define-integrable (fits-in-signed-quad? value)
+ (<= #x-8000000000000000 value #x7fffffffffffffff))
+
+(define-integrable (fits-in-unsigned-quad? value)
+ (<= 0 value #xffffffffffffffff))
\f
;;;; RTL Generator Interface
(define (interpreter-register:access)
- (rtl:make-machine-register eax))
+ (rtl:make-machine-register rax))
(define (interpreter-register:cache-reference)
- (rtl:make-machine-register eax))
+ (rtl:make-machine-register rax))
(define (interpreter-register:cache-unassigned?)
- (rtl:make-machine-register eax))
+ (rtl:make-machine-register rax))
(define (interpreter-register:lookup)
- (rtl:make-machine-register eax))
+ (rtl:make-machine-register rax))
(define (interpreter-register:unassigned?)
- (rtl:make-machine-register eax))
+ (rtl:make-machine-register rax))
(define (interpreter-register:unbound?)
- (rtl:make-machine-register eax))
+ (rtl:make-machine-register rax))
(define-integrable (interpreter-block-register offset-value)
(rtl:make-offset (interpreter-regs-pointer)
(rtl:cons-pointer-datum expression)))))
(else
false))))
+\f
+;;; Disable all open-coding for now.
(define compiler:open-code-floating-point-arithmetic?
- true)
+ false)
(define compiler:primitives-with-no-open-coding
- '(DIVIDE-FIXNUM GCD-FIXNUM &/
- ;; Disabled: trig instructions are limited to an
- ;; input range of 0 <= |X| <= pi*2^62, and yield
- ;; inaccurate answers for an input range of 0 <= |X|
- ;; <= pi/4. Correct argument reduction requires a
- ;; better approximation of pi than the i387 has.
- FLONUM-SIN FLONUM-COS FLONUM-TAN
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
\ No newline at end of file
+ '(%RECORD %RECORD-LENGTH %RECORD-REF %RECORD-SET! %RECORD? &* &+ &-
+ &/ &< &= &> -1+ 1+ BIT-STRING-LENGTH BIT-STRING? CAR CDR
+ CHAR->INTEGER CHAR? CONS DIVIDE-FIXNUM EQ? EQUAL-FIXNUM?
+ FIXNUM-AND FIXNUM-ANDC FIXNUM-LSH FIXNUM-NOT FIXNUM-OR
+ FIXNUM-QUOTIENT FIXNUM-REMAINDER FIXNUM-XOR FIXNUM?
+ FLOATING-VECTOR-CONS FLOATING-VECTOR-LENGTH
+ FLOATING-VECTOR-REF FLOATING-VECTOR-SET! FLONUM-ABS
+ FLONUM-ACOS FLONUM-ADD FLONUM-ASIN FLONUM-ATAN FLONUM-ATAN2
+ FLONUM-CEILING FLONUM-COS FLONUM-DIVIDE FLONUM-EQUAL?
+ FLONUM-EXP FLONUM-FLOOR FLONUM-GREATER? FLONUM-LESS?
+ FLONUM-LOG FLONUM-MULTIPLY FLONUM-NEGATE FLONUM-NEGATIVE?
+ FLONUM-POSITIVE? FLONUM-ROUND FLONUM-SIN FLONUM-SQRT
+ FLONUM-SUBTRACT FLONUM-TAN FLONUM-TRUNCATE FLONUM-ZERO?
+ FLONUM? GCD-FIXNUM GET-INTERRUPT-ENABLES
+ GREATER-THAN-FIXNUM? HEAP-AVAILABLE? INDEX-FIXNUM?
+ INTEGER->CHAR INTEGER-ADD INTEGER-ADD-1 INTEGER-EQUAL?
+ INTEGER-GREATER? INTEGER-LESS? INTEGER-MULTIPLY
+ INTEGER-NEGATIVE? INTEGER-POSITIVE? INTEGER-QUOTIENT
+ INTEGER-REMAINDER INTEGER-SUBTRACT INTEGER-SUBTRACT-1
+ INTEGER-ZERO? LESS-THAN-FIXNUM? MINUS-FIXNUM
+ MINUS-ONE-PLUS-FIXNUM MULTIPLY-FIXNUM NEGATIVE-FIXNUM?
+ NEGATIVE? NULL? OBJECT-TYPE OBJECT-TYPE? ONE-PLUS-FIXNUM
+ PAIR? PLUS-FIXNUM POSITIVE-FIXNUM? POSITIVE?
+ PRIMITIVE-GET-FREE PRIMITIVE-INCREMENT-FREE
+ PRIMITIVE-OBJECT-REF PRIMITIVE-OBJECT-SET!
+ PRIMITIVE-OBJECT-SET-TYPE PRIMITIVE-OBJECT-TYPE QUOTIENT
+ REMAINDER SET-CAR! SET-CDR! SET-STRING-LENGTH!
+ STRING-ALLOCATE STRING-LENGTH STRING-REF STRING-SET!
+ STRING? SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-CXR1
+ SYSTEM-HUNK3-CXR2 SYSTEM-PAIR-CAR SYSTEM-PAIR-CDR
+ SYSTEM-PAIR-CONS SYSTEM-VECTOR-REF SYSTEM-VECTOR-SIZE
+ VECTOR VECTOR-8B-REF VECTOR-8B-SET! VECTOR-CONS
+ VECTOR-LENGTH VECTOR-REF VECTOR-SET! VECTOR? ZERO-FIXNUM?
+ ZERO?))
\ No newline at end of file
|#
-;;;; RTL Generation: Special primitive combinations. Intel i386 version.
+;;;; RTL Generation: Special primitive combinations. AMD x86-64 version.
;;; package: (compiler rtl-generator)
(declare (usual-integrations))
projects / mit-scheme.git / commitdiff