From 85b6ab6909a33205166da0d19dddef8042a3c514 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Fri, 30 Oct 2009 17:39:17 -0400 Subject: [PATCH] Write machine parameters and instruction syntaxer for AMD x86-64. --- src/compiler/machines/x86-64/assmd.scm | 6 +- src/compiler/machines/x86-64/coerce.scm | 6 +- src/compiler/machines/x86-64/inerly.scm | 2 +- src/compiler/machines/x86-64/insmac.scm | 177 ++++--- src/compiler/machines/x86-64/insutl.scm | 615 ++++++++++++++++++++---- src/compiler/machines/x86-64/machin.scm | 266 +++++++--- src/compiler/machines/x86-64/rgspcm.scm | 2 +- 7 files changed, 820 insertions(+), 254 deletions(-) diff --git a/src/compiler/machines/x86-64/assmd.scm b/src/compiler/machines/x86-64/assmd.scm index 3cc0c956f..9f48786b2 100644 --- a/src/compiler/machines/x86-64/assmd.scm +++ b/src/compiler/machines/x86-64/assmd.scm @@ -23,7 +23,7 @@ USA. |# -;;;; Assembler Machine Dependencies. Intel 386 version +;;;; Assembler Machine Dependencies. AMD x86-64 version (declare (usual-integrations)) @@ -36,8 +36,8 @@ USA. (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 diff --git a/src/compiler/machines/x86-64/coerce.scm b/src/compiler/machines/x86-64/coerce.scm index 581c76e21..9cef02e14 100644 --- a/src/compiler/machines/x86-64/coerce.scm +++ b/src/compiler/machines/x86-64/coerce.scm @@ -25,7 +25,7 @@ USA. |# -;;;; Intel i386 Specific Coercions +;;;; AMD x86-64 Specific Coercions (declare (usual-integrations)) @@ -42,7 +42,9 @@ USA. (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 diff --git a/src/compiler/machines/x86-64/inerly.scm b/src/compiler/machines/x86-64/inerly.scm index f60c63fed..6040b62fe 100644 --- a/src/compiler/machines/x86-64/inerly.scm +++ b/src/compiler/machines/x86-64/inerly.scm @@ -23,7 +23,7 @@ USA. |# -;;; i386 Instruction Set Macros. Early version +;;; AMD x86-64 Instruction Set Macros. Early version ;;; NOPs for now. (declare (usual-integrations)) diff --git a/src/compiler/machines/x86-64/insmac.scm b/src/compiler/machines/x86-64/insmac.scm index 55b129594..90302a524 100644 --- a/src/compiler/machines/x86-64/insmac.scm +++ b/src/compiler/machines/x86-64/insmac.scm @@ -33,9 +33,9 @@ USA. (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))))) @@ -52,20 +52,22 @@ USA. ,(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 @@ -82,11 +84,6 @@ USA. `(MATCH-RESULT))))) (ill-formed-syntax form))))) -;; *** 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)) @@ -96,8 +93,7 @@ USA. (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) @@ -109,86 +105,83 @@ USA. (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))))) (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 ), for fixed digits + ;; (ModR/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 diff --git a/src/compiler/machines/x86-64/insutl.scm b/src/compiler/machines/x86-64/insutl.scm index 39a98ad51..99379a9d5 100644 --- a/src/compiler/machines/x86-64/insutl.scm +++ b/src/compiler/machines/x86-64/insutl.scm @@ -30,172 +30,619 @@ USA. ;;;; 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))) + +;;;; 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))) + +;;;; 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)) - - ((@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))) + +;;;; 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))) + +;;;; 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))) + + ((@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))) + + ((@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)))) -(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))) + +(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))) + +(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 diff --git a/src/compiler/machines/x86-64/machin.scm b/src/compiler/machines/x86-64/machin.scm index 109fddfd4..700dc6c19 100644 --- a/src/compiler/machines/x86-64/machin.scm +++ b/src/compiler/machines/x86-64/machin.scm @@ -23,7 +23,7 @@ USA. |# -;;;; Machine Model for the Intel 386, i486, and successors +;;;; Machine Model for the AMD x86-64 ;;; package: (compiler) (declare (usual-integrations)) @@ -33,7 +33,7 @@ USA. (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. @@ -46,7 +46,7 @@ USA. (- 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)) @@ -65,7 +65,7 @@ USA. (define-integrable signed-fixnum/upper-limit ;; (expt 2 (-1+ scheme-datum-width)) *** - 33554432) + #x0200000000000000) (define-integrable signed-fixnum/lower-limit (- signed-fixnum/upper-limit)) @@ -78,80 +78,152 @@ USA. ;;;; 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 )) 48 B8 +;;; (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) ;;;; 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) + (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) @@ -159,10 +231,16 @@ USA. (= 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) @@ -174,30 +252,48 @@ USA. (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)) ;;;; 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) @@ -342,16 +438,44 @@ USA. (rtl:cons-pointer-datum expression))))) (else false)))) + +;;; 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 diff --git a/src/compiler/machines/x86-64/rgspcm.scm b/src/compiler/machines/x86-64/rgspcm.scm index e9796b29f..2d2e90162 100644 --- a/src/compiler/machines/x86-64/rgspcm.scm +++ b/src/compiler/machines/x86-64/rgspcm.scm @@ -25,7 +25,7 @@ USA. |# -;;;; RTL Generation: Special primitive combinations. Intel i386 version. +;;;; RTL Generation: Special primitive combinations. AMD x86-64 version. ;;; package: (compiler rtl-generator) (declare (usual-integrations)) -- 2.25.1