From 6380804c5dc41199b4c74eeaf468c0525ef41ba5 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Mon, 14 Jan 2019 07:43:42 +0000 Subject: [PATCH] Various work to get this going. Enough to compile and assemble advice.scm, the first file in the runtime. Still a ways from doing anything. --- src/compiler/machines/aarch64/TODO | 3 + src/compiler/machines/aarch64/insmac.scm | 27 +- src/compiler/machines/aarch64/instr1.scm | 359 ++++++++++++---------- src/compiler/machines/aarch64/instr2.scm | 126 +++++--- src/compiler/machines/aarch64/insutl.scm | 94 +++++- src/compiler/machines/aarch64/lapgen.scm | 275 +++++++---------- src/compiler/machines/aarch64/machine.scm | 56 +++- src/compiler/machines/aarch64/rules1.scm | 34 +- src/compiler/machines/aarch64/rules2.scm | 44 ++- src/compiler/machines/aarch64/rules3.scm | 167 +++++++--- src/compiler/machines/aarch64/rules4.scm | 62 ++-- src/compiler/machines/aarch64/rulfix.scm | 58 ++-- src/compiler/machines/aarch64/rulrew.scm | 2 +- 13 files changed, 785 insertions(+), 522 deletions(-) diff --git a/src/compiler/machines/aarch64/TODO b/src/compiler/machines/aarch64/TODO index 4553b6e04..e90c62748 100644 --- a/src/compiler/machines/aarch64/TODO +++ b/src/compiler/machines/aarch64/TODO @@ -10,9 +10,12 @@ . trampoline code, if necessary . wherever else - Verify the branch condition codes. +- Verify variable-width cases. +- Logical immediate encoding. - Open-coded flonum arithmetic. - Better fixnum operations with constant operands. - Fast division by multiplication. - Fixnum multiply-add/sub/negate. - Consider NaN-tagging. - Write a disassembler. +- Share interrupt hook invocations. diff --git a/src/compiler/machines/aarch64/insmac.scm b/src/compiler/machines/aarch64/insmac.scm index 3c3de986f..cfb7d4120 100644 --- a/src/compiler/machines/aarch64/insmac.scm +++ b/src/compiler/machines/aarch64/insmac.scm @@ -65,7 +65,9 @@ USA. (define (process-fixed form environment) (receive (expansion bits) (expand-fields (cdr form) environment) - (values (optimize-group-syntax expansion #f environment) bits))) + (values `(,(close-syntax 'LIST environment) + ,(optimize-group-syntax expansion #f environment)) + bits))) (define (process-variable form environment) (let ((variable (cadr form)) @@ -77,24 +79,27 @@ USA. expression environment options))) - (values expression #f))))) + (values `(,(close-syntax 'LIST environment) ,expression) #f))))) (define ((process-variable-clause environment) clause) (let ((range (car clause)) (forms (cdr clause))) - (receive (expansion bits) (process* (car forms) (cdr forms) environment) - (assert bits "Variable within variable prohibited!") - (assert (zero? (remainder bits 32)) "Wrong number of bits!") - `(,expansion ,bits ,range)))) + (let ((lo (car range)) + (hi (cadr range))) + (receive (expansion bits) (process* (car forms) (cdr forms) environment) + (assert bits "Variable within variable prohibited!") + (assert (zero? (remainder bits 32)) "Wrong number of bits!") + `(,expansion ,bits ,lo ,hi))))) (define (process-macro form environment) (let ((width (cadr form)) (expansion (caddr form))) - (values ;; XXX Check the width here. Check for cycles. - `((,(close-syntax 'INSTRUCTION-LOOKUP environment) - (,(close-syntax 'QUASIQUOTE environment) - ,expansion))) - width))) + (values + ;; XXX Check the width here. Check for cycles. + `((,(close-syntax 'INSTRUCTION-LOOKUP environment) + (,(close-syntax 'QUASIQUOTE environment) + ,expansion))) + width))) (define (expand-fields fields environment) (let loop ((fields fields) (elements '()) (bits 0)) diff --git a/src/compiler/machines/aarch64/instr1.scm b/src/compiler/machines/aarch64/instr1.scm index ac30505f6..95bd96f68 100644 --- a/src/compiler/machines/aarch64/instr1.scm +++ b/src/compiler/machines/aarch64/instr1.scm @@ -56,78 +56,40 @@ USA. ;;; C3.1.1 Conditional branch -(let-syntax - ((define-conditional-branch-instruction - (sc-macro-transformer - (lambda (form environment) - environment - (let ((mnemonic (list-ref form 1)) - (o0 (list-ref form 2)) - (o1 (list-ref form 3)) - (condition (list-ref form 4))) - `(define-instruction ,mnemonic - (((@PCO (? offset))) - (BITS (7 #b0101010) - (1 ,o1) - (19 offset SIGNED) - (1 ,o0) - (4 ,condition))) - (((@PCR (? target) (? temp register<31))) - (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4) - ;; If it fits in a signed 19-bit displacement, great. - ((#x-40000 #x3ffff) - (MACRO 32 (,mnemonic (@PCO ,',offset)))) - ;; If not, we have to use ADRP and ADD with a - ;; temporary register. Preserve forward or backward - ;; branches to preserve static branch predictions. - ;; The PC relative to which we compute the target - ;; address is marked with (*) to explain the curious - ;; bounds. - ((0 #x100000001) - ;; Forward branch. - (MACRO 32 (,mnemonic (@PCO 2))) ;1f - (MACRO 32 (B (@PCO 4))) ;2f - ;; 1: - (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*) - (MACRO 32 (BR ,',temp)) - ;; 2: - ) - ((#x-fffffffe -1) - ;; Backward branch. - (MACRO 32 (B (@PCO 4))) ;1f - ;; 2: - (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*) - (MACRO 32 (BR ,',temp)) - ;; 1: - (MACRO 32 (,mnemonic (@PCO -3))) ;2b - ))))))))) - ;; PSTATE condition bits: - ;; .n = negative - ;; .z = zero - ;; .c = carry - ;; .v = overflow - ;; Branch if... - (define-conditional-branch-instruction B.EQ 0 0 #b0000) ;equal - (define-conditional-branch-instruction B.NE 0 0 #b0001) ;not equal - (define-conditional-branch-instruction B.CS 0 0 #b0010) ;carry set - (define-conditional-branch-instruction B.CC 0 0 #b0011) ;carry clear - (define-conditional-branch-instruction B.MI 0 0 #b0100) ;negative `minus' - (define-conditional-branch-instruction B.PL 0 0 #b0101) ;nonnegative `plus' - (define-conditional-branch-instruction B.VS 0 0 #b0110) ;overflow set - (define-conditional-branch-instruction B.VC 0 0 #b0111) ;overflow clear - (define-conditional-branch-instruction B.HI 0 0 #b1000) ;carry and nonzero - (define-conditional-branch-instruction B.LS 0 0 #b1001) ;!carry or zero - (define-conditional-branch-instruction B.GE 0 0 #b1010) ;greater or equal - ;n = v - (define-conditional-branch-instruction B.LT 0 0 #b1011) ;less - ;n != v - (define-conditional-branch-instruction B.GT 0 0 #b1100) ;greater - ;n = v and !z - (define-conditional-branch-instruction B.LE 0 0 #b1101) ;less or equal - ;n != v or z - (define-conditional-branch-instruction B.AL 0 0 #b1110) ;always - #; ;never? - (define-conditional-branch-instruction B. 0 0 #b1111)) +(define-instruction B. + (((? condition branch-condition) (@PCO (* 4 (? offset signed-19)))) + (BITS (7 #b0101010) + (1 0) ;o1 + (19 offset SIGNED) + (1 0) ;o0 + (4 condition))) + (((? condition) (@PCR (? target) (? temp register<31))) + (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4) + ;; If it fits in a signed 19-bit displacement, great. + ((#x-40000 #x3ffff) + (MACRO 32 (B. ,condition (@PCO (* 4 ,offset))))) + ;; If not, we have to use ADRP and ADD with a temporary register. + ;; Preserve forward or backward branches to preserve static branch + ;; predictions. The PC relative to which we compute the target + ;; address is marked with (*) to explain the curious bounds. + ((0 #x100000001) + ;; Forward branch. + (MACRO 32 (B. ,condition (@PCO (* 4 2)))) ;1f + (MACRO 32 (B (@PCO (* 4 4)))) ;2f + ;; 1: + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 (- offset 2))))) ;(*) + (MACRO 32 (BR ,temp)) + ;; 2: + ) + ((#x-fffffffe -1) + ;; Backward branch. + (MACRO 32 (B (@PCO (* 4 4)))) ;1f + ;; 2: + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 (- offset 2))))) ;(*) + (MACRO 32 (BR ,temp)) + ;; 1: + (MACRO 32 (B. ,condition (@PCO (* 4 -3)))) ;2b + )))) (let-syntax ((define-compare&branch-instruction @@ -136,7 +98,9 @@ USA. environment (receive (mnemonic op) (apply values (cdr form)) `(define-instruction ,mnemonic - (((? sf sf-size) (? Rt register-31=z) (@PCO (? offset))) + (((? sf sf-size) + (? Rt register-31=z) + (@PCO (* 4 (? offset signed-19)))) (BITS (1 sf) (6 #b011010) (1 ,op) @@ -145,24 +109,26 @@ USA. (((? sf) (? Rt) (@PCR (? target) (? temp register<31))) (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4) ((#x-40000 #x3ffff) - (MACRO 32 (,mnemonic (@PCO ,',offset)))) - ((0 #x100000001) + (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO (* 4 ,',offset))))) + ((0 #x40000001) ;; Forward branch. - (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO 2))) ;1f - (MACRO 32 (B (@PCO 4))) ;2f + (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO (* 4 2)))) ;1f + (MACRO 32 (B (@PCO (* 4 4)))) ;2f ;; 1: - (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*) + (MACRO 64 (ADRP-ADD X ,',temp + (@PCO ,',(* 4 (- offset 2))))) ;(*) (MACRO 32 (BR ,',temp)) ;; 2: ) - ((#x-fffffffe -1) + ((#x-3ffffffe -1) ;; Backward branch. - (MACRO 32 (B (@PCO 4))) ;1f + (MACRO 32 (B (@PCO (* 4 4)))) ;1f ;; 2: - (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*) + (MACRO 64 (ADRP-ADD X ,',temp + (@PCO ,',(* 4 (- offset 2))))) ;(*) (MACRO 32 (BR ,',temp)) ;; 1: - (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO -3))) ;2b + (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO (* 4 -3)))) ;2b ))))))))) ;; Compare and branch on zero (define-compare&branch-instruction CBZ 0) @@ -178,7 +144,7 @@ USA. `(define-instruction ,mnemonic ((W (? Rt register-31=z) (&U (? bit unsigned-5)) - (@PCO (? offset))) + (@PCO (* 4 (? offset)))) (BITS (1 0) ;b5, fifth bit of bit index (6 #b011011) (1 ,op) @@ -187,7 +153,7 @@ USA. (5 Rt))) ((X (? Rt register-31=z) (&U (? bit unsigned-6)) - (@PCO (? offset))) + (@PCO (* 4 (? offset)))) (BITS (1 (shift-right bit 5)) (6 #b011011) (5 (bitwise-and bit #b1111)) @@ -197,27 +163,31 @@ USA. (? Rt) (&U (? bit)) (@PCR (? target) (? temp register<31))) - (VARIABLE-WIDTH offset (/ `(- ,target *PC*) 4) + (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4) ((#x-2000 #x1fff) (MACRO 32 - (,mnemonic ,',sf ,',Rt (&U ,',bit) (@PCO ,',offset)))) + (,mnemonic ,',sf ,',Rt (&U ,',bit) + (@PCO (* 4 ,',offset))))) ((0 #x100000001) ;; Forward branch. - (MACRO 32 (,mnemonic ,',sf ,',Rt (&U ,',bit) (@PCO 2))) ;1f + (MACRO 32 (,mnemonic ,',sf ,',Rt (&U ,',bit) + (@PCO (* 4 2)))) ;1f (MACRO 32 (B (@PCO 4))) ;2f ;; 1: - (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*) + (MACRO 64 (ADRP-ADD X ,',temp + (@PCO ,',(* 4 (- offset 2))))) ;(*) (MACRO 32 (BR ,',temp)) ;; 2: ) ((#x-fffffffe -1) ;; Backward branch. - (MACRO 32 (B (@PCO 4))) ;1f + (MACRO 32 (B (@PCO (* 4 4)))) ;1f ;; 2: - (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*) + (MACRO 64 (ADRP-ADD X ,',temp + (@PCO ,',(* 4 (- offset 2))))) ;(*) (MACRO 32 (BR ,',temp)) ;; 1: - (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO -3))) ;2b + (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO (* 4 -3)))) ;2b ))))))))) ;; Test and branch if zero (define-test&branch-instruction TBZ 0) @@ -229,31 +199,38 @@ USA. ;; Branch unconditional to PC-relative. (define-instruction B - (((@PCO (? offset))) + (((@PCO (* 4 (? offset)))) (BITS (1 0) ;no link (5 #b00101) (26 offset SIGNED))) (((@PCR (? target) (? temp register<31))) - (VARIABLE-WIDTH offset (/ `(- ,target *PC*) 4) + (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4) + ((#x-2000000 #x1ffffff) + (MACRO 32 (B (@PCO (* 4 ,offset))))) + ((#x-100000000 #xffffffff) + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 offset)))) ;(*) + (MACRO 32 (BR ,temp))))) + (((@PCR (+ (? target) (* 4 (? addend))) (? temp register<31))) + (VARIABLE-WIDTH offset `(+ (/ (- ,target *PC*) 4) ,addend) ((#x-2000000 #x1ffffff) - (MACRO 32 (B (@PCO ,offset)))) + (MACRO 32 (B (@PCO (* 4 ,offset))))) ((#x-100000000 #xffffffff) - (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*) + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 offset)))) ;(*) (MACRO 32 (BR ,temp)))))) ;; Branch and link unconditional to PC-relative (define-instruction BL - (((@PCO (? offset))) + (((@PCO (* 4 (? offset)))) (BITS (1 1) ;link (5 #b00101) (26 offset SIGNED))) (((@PCR (? target) (? temp register<31))) - (VARIABLE-WIDTH offset (/ `(- ,target *PC*) 4) + (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4) ((#x-2000000 #x1ffffff) - (MACRO 32 (BL (@PCO ,offset)))) + (MACRO 32 (BL (@PCO (* 4 ,offset))))) ((#x-100000000 #xffffffff) - (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*) + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 offset)))) ;(*) (MACRO 32 (BLR ,temp)))))) ;;; C.3.1.3 Unconditional branch (register) @@ -752,7 +729,9 @@ USA. (define-load/store-instruction STR 0) (define-load/store-instruction LDR 1 ;; LDR PC-relative literal (C6.2.120). - (((? opc ldr-literal-size) (? Rt register-31=z) (@PCO (? offset))) + (((? opc ldr-literal-size) + (? Rt register-31=z) + (@PCO (* 4 (? offset signed-19)))) (BITS (2 opc) (3 #b011) (1 0) ;general @@ -762,12 +741,12 @@ USA. (((? size) (? Rt) (@PCR (? label) (? temp register<31))) (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4) ((#x-40000 #x3ffff) - (MACRO 32 (LDR ,size ,Rt (@PCO ,offset)))) + (MACRO 32 (LDR ,size ,Rt (@PCO (* 4 ,offset))))) ((#x-100000000 #xffffffff) ;; Could maybe use ADRP and LDR with unsigned 8-byte offset, ;; but only if the offset is even because this instruction is ;; aligned, wich the assembler can't handle easily. - (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*) + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 offset)))) ;(*) (MACRO 32 (LDR X ,Rt ,temp))))))) ;;; C3.2.9 Load/Store scalar SIMD and floating-point @@ -1026,7 +1005,9 @@ USA. (define-simd/fp-load/store-instruction STR.V 0) (define-simd/fp-load/store-instruction LDR.V 1 ;; LDR PC-relative literal, SIMD&FP (C7.2.177) - (((? opc ldr-literal-simd/fp-size) (? Vt vregister) (@PCO (? offset))) + (((? opc ldr-literal-simd/fp-size) + (? Vt vregister) + (@PCO (? offset signed-19))) (BITS (2 opc) (3 #b011) (1 1) ;SIMD/FP @@ -1036,84 +1017,71 @@ USA. (((? size) (? Vt) (@PCR (? label) (? temp register<31))) (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4) ((#x-40000 #x3ffff) - (MACRO 32 (LDR.V ,size ,Vt (@PCO ,offset)))) + (MACRO 32 (LDR.V ,size ,Vt (@PCO (* 4 ,offset))))) ((#x-100000000 #xffffffff) - (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*) + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 offset)))) ;(*) (MACRO 32 (LDR.V X ,Vt ,temp))))))) -;; Load register signed +;; Load register signed (i.e., sign-extended). This does not detect +;; the nonsensical (LDRS W W ...) operand combination -- it will +;; assemble into a possibly different instruction. (define-instruction LDRS ;; Immediate, zero unsigned offset - (((? Rt register-31=z) (? Rn register-31=sp)) - (BITS (2 #b10) ;size + (((? size load-signed-size) + (? opc load-signed-opc) + (? Rt register-31=z) + (? Rn register-31=sp)) + (BITS (2 size) (3 #b111) (1 0) (2 #b01) - (2 #b10) ;opc + (2 opc) (12 0) ;imm12 (5 Rn) (5 Rt))) ;; Immediate, unsigned offset - (((? Rt register-31=z) + (((? size load-signed-size) + (? opc load-signed-opc) + (? Rt register-31=z) (+ (? Rn register-31=sp) (&U (? offset unsigned-12)))) - (BITS (2 #b10) ;size + (BITS (2 size) (3 #b111) (1 0) (2 #b01) - (2 #b10) ;opc + (2 opc) (12 offset) ;imm12 (5 Rn) (5 Rt))) - ;; Post-indexed signed offset - (((? Rt register-31=z) - (POST+ (? Rn register-31=sp) (& (? offset signed-9)))) - (BITS (2 #b10) ;size + ;; Pre/post-indexed signed offset + (((? opc load-signed-opc) + (? size load-signed-size) + (? Rt register-31=z) + ((? pre/post load/store-pre/post-index) + (? Rn register-31=sp) + (& (? offset signed-9)))) + (BITS (2 size) (3 #b111) (1 0) (2 #b00) - (2 #b10) ;opc + (2 opc) (1 0) (9 offset SIGNED) - (2 #b01) ;post-index - (5 Rn) - (5 Rt))) - ;; Pre-indexed signed offset - (((? Rt register-31=z) - (POST+ (? Rn register-31=sp) (& (? offset signed-9)))) - (BITS (2 #b10) ;size - (3 #b111) - (1 0) - (2 #b00) - (2 #b10) ;opc - (1 0) - (9 offset SIGNED) - (2 #b11) ;pre-index + (2 pre/post) (5 Rn) (5 Rt))) - ;; Literal - (((? Rt register-31=z) (@PCO (? offset))) - (BITS (2 #b10) ;opc - (3 #b011) - (1 0) ;general - (2 #b00) - (19 offset SIGNED) - (5 Rt))) - (((? Rt register-31=z) (@PCR (? label) (? temp register<31))) - (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4) - ((#x-40000 #x3ffff) - (MACRO 32 (LDRS ,Rt (@PCO ,offset)))) - ((#x-100000000 #xffffffff) - (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*) - (MACRO 32 (LDRS ,Rt ,temp))))) ;; Register, no extend - (((? Rt register-31=z) (? Rn register-31=sp) (? Rm register-31=z)) - (BITS (2 #b10) ;size + (((? size load-signed-size) + (? opc load-signed-opc) + (? Rt register-31=z) + (+ (? Rn register-31=sp) + (? Rm register-31=z))) + (BITS (2 size) (3 #b111) (1 0) (2 #b00) - (2 #b10) ;opc + (2 opc) (1 1) (5 Rm) (3 #b011) ;option=LSL @@ -1121,23 +1089,100 @@ USA. (5 Rn) (5 Rt))) ;; Extended register - (((? Rt register-31=z) - (? Rn register-31=sp) - (? Rm register-31=z) - (? option ldrsw-extend-type) - (? S ldrsw-extend-amount)) - (BITS (2 #b10) ;size + (((? size load-signed-size) + (? opc load-signed-opc) + (? Rt register-31=z) + (+ (? Rn register-31=sp) + ((? option load/store-extend-type) + (? Rm register-31=z) + (? S load/store32-extend-amount)))) + (BITS (2 size) (3 #b111) (1 0) (2 #b00) - (2 #b10) ;opc + (2 opc) (1 1) (5 Rm) (3 option) (1 S) (2 #b10) (5 Rn) - (5 Rt)))) + (5 Rt))) + ;; Literal -- only loading W into X. + ((X W (? Rt register-31=z) (@PCO (* 4 (? offset signed-19)))) + (BITS (2 #b10) ;opc + (3 #b011) + (1 0) ;general + (2 #b00) + (19 offset SIGNED) + (5 Rt))) + ((X W (? Rt register-31=z) (@PCR (? label) (? temp register<31))) + (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4) + ((#x-40000 #x3ffff) + (MACRO 32 (LDRS ,Rt (@PCO (* 4 ,offset))))) + ((#x-100000000 #xffffffff) + (MACRO 64 (ADRP-ADD X ,temp (@PCO ,(* 4 offset)))) ;(*) + (MACRO 32 (LDRS ,Rt ,temp)))))) + +;;; C3.4.11 Conditional select + +(let-syntax + ((define-conditional-select-instruction + (sc-macro-transformer + (lambda (form environment) + environment + (receive (mnemonic op o2) (apply values (cdr form)) + `(define-instruction ,mnemonic + (((? sf sf-size) + (? condition branch-condition) + (? Rd register-31=z) + (? Rn register-31=z) + (? Rm register-31=z)) + (BITS (1 sf) + (1 ,op) + (1 0) + (1 1) + (4 #b1010) + (3 #b100) + (5 Rm) + (4 condition) + (1 0) + (1 ,o2) + (5 Rn) + (5 Rd))))))))) + ;; Rd := Rn if condition else Rm + (define-conditional-select-instruction CSEL 0 0) + ;; Rd := Rn if condition else (Rm + 1) + (define-conditional-select-instruction CSINC 0 1) + ;; Rd := Rn if condition else ~Rn + (define-conditional-select-instruction CSINV 1 0) + ;; Rd := Rn if condition else -Rn + (define-conditional-select-instruction CSNEG 1 1)) + +;; Rd := 1 if condition else 0 +(define-instruction CSET + (((? sf) (? condition) (? Rd)) + (MACRO 32 (CSINC ,sf ,condition ,Rd Z Z)))) + +;; Rd := -1 if condition else 0 +(define-instruction CSETM + (((? sf) (? condition) (? Rd)) + (MACRO 32 (CSINV ,sf ,condition ,Rd Z Z)))) + +;; Rd := (Rn + 1) if condition else Rn +(define-instruction CINC + (((? sf) (? condition) (? Rd) (? Rn)) + (MACRO 32 (CSINC ,sf ,(invert-branch-condition condition) ,Rd ,Rn ,Rn)))) + +;; Rd := (~Rn) if condition else Rn +(define-instruction CINV + (((? sf) (? condition) (? Rd) (? Rn)) + (MACRO 32 (CSINV ,sf ,(invert-branch-condition condition) ,Rd ,Rn ,Rn)))) + +;; Rd := (-Rn) if condition else Rn +(define-instruction CNEG + (((? sf) (? condition) (? Rd) (? Rn)) + (MACRO 32 (CSNEG ,sf ,(invert-branch-condition condition) ,Rd ,Rn ,Rn)))) ;;; Local Variables: ;;; eval: (put 'variable-width 'scheme-indent-function 2) diff --git a/src/compiler/machines/aarch64/instr2.scm b/src/compiler/machines/aarch64/instr2.scm index 949a4ae1e..26e95846a 100644 --- a/src/compiler/machines/aarch64/instr2.scm +++ b/src/compiler/machines/aarch64/instr2.scm @@ -38,12 +38,12 @@ USA. environment (receive (mnemonic op divisor) (apply values (cdr form)) `(define-instruction ,mnemonic - ((X (? Rd register-31=z) (@PCO (? offset))) + ((X (? Rd register-31=z) (@PCO (? offset signed-21))) (BITS (1 ,op) (2 (bitwise-and offset #b11)) (1 1) (4 #b0000) - (19 (bitwise-and (shift-right offset 2) #x1ffff)) + (19 (shift-right offset 2) SIGNED) (5 Rd))))))))) ;; PC-relative byte offset (define-adr-instruction %ADR 0 1) @@ -51,19 +51,19 @@ USA. (define-adr-instruction %ADRP 1 4096)) (define-instruction ADRP-ADD - ((X (? Rd) (@PCO ,offset)) + ((X (? Rd) (@PCO (? offset signed-33))) (MACRO 32 (ADRP X ,Rd ,(shift-right offset 12))) (MACRO 32 (ADD X ,Rd ,Rd ,(bitwise-and offset #xfff))))) (define-instruction ADR - ((X (? Rd) (@PCO (? offset))) + ((X (? Rd) (@PCO (? offset signed-21))) (MACRO 32 (%ADR X ,Rd (@PCO ,offset)))) ((X (? Rd) (@PCR (? label) (? temp register<31))) (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4) ((#x-40000 #x3ffff) (MACRO 32 (ADR X ,Rd (@PCO ,offset)))) ((#x-100000000 #xffffffff) - (MACRO 64 (ADRP-ADD X ,Rd (@PCO ,offset))))))) + (MACRO 64 (ADRP-ADD X ,Rd (@PCO ,(* 4 offset)))))))) (let-syntax ((define-addsub-instruction @@ -240,7 +240,7 @@ USA. (? Rm register-31=z) (? type logical-shift/rotate-type) (? amount unsigned-5)) - (BITS (1 sf) + (BITS (1 0) ;sf=0, 32-bit operand size (2 ,opc) (1 0) (4 #b1010) @@ -256,7 +256,7 @@ USA. (? Rm register-31=z) (? type logical-shift/rotate-type) (? amount unsigned-6)) - (BITS (1 sf) + (BITS (1 1) ;sf=1, 64-bit operand size (2 ,opc) (1 0) (4 #b1010) @@ -399,7 +399,7 @@ USA. (1 0) (1 0) ;N, must match sf (1 0) ;high bit of r - (5 `(REMAINDER (- ,shift) 32)) + (5 `(MODULO (- 0 ,shift) 32)) (1 0) ;high bit of s (5 `(- 31 ,shift)) (5 Rn) @@ -414,7 +414,7 @@ USA. (4 #b0011) (1 0) (1 1) ;N, must match sf - (6 `(REMAINDER (- ,shift) 64)) + (6 `(MODULO (- 0 ,shift) 64)) (6 `(- 63 ,shift)) (5 Rn) (5 Rd))))))))) @@ -521,8 +521,8 @@ USA. (5 Rd))) ((X (? Rd register-31=z) ,@(if Rn '() `((? Rn ,register-31=src))) - (&U (? lsb unsigned-5)) - (&U (? width unsigned-5+1))) + (&U (? lsb unsigned-6)) + (&U (? width unsigned-6+1))) (BITS (1 1) ;sf=1, 32-bit operand size (2 ,opc) (1 1) @@ -545,29 +545,29 @@ USA. `(- (+ ,lsb ,width) 1)) ;s ;; Signed bitfield insert in zeros, alias for SBFM (define-bitfield-insert/extract-instruction SFBIZ #b00 - `(REMAINDER (- ,lsb) 32) ;r32 - `(REMAINDER (- ,lsb) 64) ;r64 + `(MODULO (- 0 ,lsb) 32) ;r32 + `(MODULO (- 0 ,lsb) 64) ;r64 `(- ,width 1)) ;s ;; Bitfield extract and insert low copies (define-bitfield-insert/extract-instruction BFXIL #b01 - `(REMAINDER (- ,lsb) 32) ;r32 - `(REMAINDER (- ,lsb) 64) ;r64 + `(MODULO (- 0 ,lsb) 32) ;r32 + `(MODULO (- 0 ,lsb) 64) ;r64 (- width 1)) ;s ;; Bitfield insert: copy bits at from source (define-bitfield-insert/extract-instruction BFI #b01 - `(REMAINDER (- ,lsb) 32) ;r32 - `(REMAINDER (- ,lsb) 64) ;r64 + `(MODULO (- 0 ,lsb) 32) ;r32 + `(MODULO (- 0 ,lsb) 64) ;r64 `(- ,width 1) ;s register<31) ;Rn must not be 31 ;; Bitfield clear: clear bit positions at (define-bitfield-insert/extract-instruction BFC #b01 - `(REMAINDER (- ,lsb) 32) ;r32 - `(REMAINDER (- ,lsb) 64) ;r64 + `(MODULO (- 0 ,lsb) 32) ;r32 + `(MODULO (- 0 ,lsb) 64) ;r64 `(- ,width 1) ;s #f 31) ;Rn is 31 (define-bitfield-insert/extract-instruction UFBIZ #b10 - `(REMAINDER (- ,lsb) 32) ;r32 - `(REMAINDER (- ,lsb) 64) ;r64 + `(MODULO (- 0 ,lsb) 32) ;r32 + `(MODULO (- 0 ,lsb) 64) ;r64 `(- ,width 1))) ;s (let-syntax @@ -589,7 +589,7 @@ USA. (1 1) (4 #b0011) (1 1) - (1 sf) ;N, must match sf + (1 0) ;N, must match sf (1 ,o0) (5 ,(if m=n? 'Rn 'Rm)) (1 0) ;high bit of lsb index, 0 for 32-bit @@ -605,7 +605,7 @@ USA. (1 1) (4 #b0011) (1 1) - (1 sf) ;N, must match sf + (1 0) ;N, must match sf (1 ,o0) (5 ,(if m=n? 'Rn 'Rm)) (6 s) @@ -655,11 +655,23 @@ USA. (5 Rn) (5 Rt1))) ;; No write back, signed increment. - (((? sf sf-size) - (? Rt1 register-31=z) - (? Rt2 register-31=z) - (+ (? Rn register-31=sp)) (& (? imm signed-7*4))) - (BITS (1 sf) + ((W (? Rt1 register-31=z) + (? Rt2 register-31=z) + (+ (? Rn register-31=sp)) (& (* 4 (? imm signed-7)))) + (BITS (1 0) ;sf=0, 32-bit operand size + (1 0) ;opc[1] + (3 #b101) + (1 0) + (3 #b010) + (1 ,L) + (7 imm SIGNED) + (5 Rt2) + (5 Rn) + (5 Rt1))) + ((X (? Rt1 register-31=z) + (? Rt2 register-31=z) + (+ (? Rn register-31=sp)) (& (* 8 (? imm signed-7)))) + (BITS (1 1) ;sf=1, 64-bit operand size (1 0) ;opc[1] (3 #b101) (1 0) @@ -670,11 +682,10 @@ USA. (5 Rn) (5 Rt1))) ;; Pre-index signed offset. - (((? sf sf-size) - (? Rt1 register-31=z) - (? Rt2 register-31=z) - (PRE+ (? Rn register-31=sp) (& (? imm signed-7*4)))) - (BITS (1 sf) + ((W (? Rt1 register-31=z) + (? Rt2 register-31=z) + (PRE+ (? Rn register-31=sp) (& (* 4 (? imm signed-7))))) + (BITS (1 0) ;sf=0, 32-bit operand size (1 0) ;opc[1] (3 #b101) (1 0) @@ -683,13 +694,25 @@ USA. (7 imm SIGNED) (5 Rt2) (5 Rn) - (5 Rt))) + (5 Rt1))) + ((X (? Rt1 register-31=z) + (? Rt2 register-31=z) + (PRE+ (? Rn register-31=sp) (& (* 8 (? imm signed-7))))) + (BITS (1 1) ;sf=1, 64-bit operand size + (1 0) ;opc[1] + (3 #b101) + (1 0) + (3 #b011) + (1 ,L) + (7 imm SIGNED) + (5 Rt2) + (5 Rn) + (5 Rt1))) ;; Post-index signed offset. - (((? sf sf-size) - (? Rt1 register-31=z) - (? Rt2 register-31=z) - (POST+ (? Rn register-31=sp) (& (? imm signed-7*4)))) - (BITS (1 sf) + ((W (? Rt1 register-31=z) + (? Rt2 register-31=z) + (POST+ (? Rn register-31=sp) (& (* 4 (? imm signed-7))))) + (BITS (1 0) ;sf=0, 32-bit operand size (1 0) ;opc[1] (3 #b101) (1 0) @@ -698,18 +721,23 @@ USA. (7 imm SIGNED) (5 Rt2) (5 Rn) - (5 Rt))))))))) + (5 Rt1))) + ((W (? Rt1 register-31=z) + (? Rt2 register-31=z) + (POST+ (? Rn register-31=sp) (& (* 8 (? imm signed-7))))) + (BITS (1 1) ;sf=1, 64-bit operand size + (1 0) ;opc[1] + (3 #b101) + (1 0) + (3 #b001) + (1 ,L) + (7 imm SIGNED) + (5 Rt2) + (5 Rn) + (5 Rt1))))))))) (define-load/store-pair-instruction LDP 1) (define-load/store-pair-instruction STP 1)) -(define (load/store-size sz) - (case sz - ((B) #b00) - ((H) #b01) - ((W) #b10) - ((X) #b11) - (else #f))) - (let-syntax ((define-load/store-exclusive-instruction (sc-macro-transformer @@ -721,7 +749,7 @@ USA. (? Rs register-31=z) (? Rt register-31=z) (? Rn register-31=sp)) - (BITS (2 size) + (BITS (2 sz) (2 #b00) (4 #b1000) (1 ,o2) diff --git a/src/compiler/machines/aarch64/insutl.scm b/src/compiler/machines/aarch64/insutl.scm index acd494618..7bc3a52e4 100644 --- a/src/compiler/machines/aarch64/insutl.scm +++ b/src/compiler/machines/aarch64/insutl.scm @@ -28,11 +28,31 @@ USA. (declare (usual-integrations)) +(define (signed-7 x) + (and (exact-integer? x) + (<= #x-40 x #x3f) + x)) + (define (signed-9 x) (and (exact-integer? x) (<= #x-200 x #x1ff) x)) +(define (signed-19 x) + (and (exact-integer? x) + (<= #x-40000 x #x3ffff) + x)) + +(define (signed-21 x) + (and (exact-integer? x) + (<= #x-100000 x #xfffff) + x)) + +(define (signed-33 x) + (and (exact-integer? x) + (<= #x-100000000 x #xffffffff) + x)) + (define (unsigned-2 x) (and (exact-nonnegative-integer? x) (<= 0 x 3) @@ -63,6 +83,11 @@ USA. (<= 0 x #x3f) x)) +(define (unsigned-6+1 x) + (and (exact-nonnegative-integer? x) + (<= 1 x #x40) + x)) + (define (unsigned-7 x) (and (exact-nonnegative-integer? x) (<= 0 x #x7f) @@ -77,6 +102,52 @@ USA. (and (exact-nonnegative-integer? x) (<= 0 x #xffff) x)) + +(define (branch-condition condition) + ;; PSTATE condition bits: + ;; .n = negative + ;; .z = zero + ;; .c = carry + ;; .v = overflow + ;; Branch if... + (case condition + ((EQ) #b0000) ;equal (z) + ((NE) #b0001) ;not equal (!z) + ((CS) #b0010) ;carry set (c) + ((CC) #b0011) ;carry clear (!c) + ((MI) #b0100) ;negative `minus' (n) + ((PL) #b0101) ;nonnegative `plus' (!n) + ((VS) #b0110) ;overflow set (v) + ((VC) #b0111) ;overflow clear (!v) + ((HI) #b1000) ;carry and nonzero (c & !z) + ((LS) #b1001) ;!carry or zero (!c | z) + ((GE) #b1010) ;greater or equal (n = v) + ((LT) #b1011) ;less (n != v) + ((GT) #b1100) ;greater ((n = v) & !z) + ((LE) #b1101) ;less or equal ((n != v) | z) + ((AL) #b1110) ;always + ;(() #b1111) ;never? + (else #f))) + +(define (invert-branch-condition condition) + (case condition + ((EQ) 'NE) + ((NE) 'EQ) + ((CS) 'CC) + ((CC) 'CS) + ((MI) 'PL) + ((PL) 'MI) + ((VS) 'VC) + ((VC) 'VS) + ((HI) 'LS) + ((LS) 'HI) + ((GE) 'LT) + ((LT) 'GE) + ((GT) 'LE) + ((LE) 'GT) + ((AL) 'NV) + ((NV) 'AL) + (else #f))) (define (sf-size size) (case size @@ -85,20 +156,22 @@ USA. (else #f))) (define (vregister v) - (and (<= 0 v 31) + (and (exact-integer? v) + (<= 0 v 31) v)) (define (register<31 r) - (and (<= 0 r 30) + (and (exact-integer? r) + (<= 0 r 30) r)) (define (register-31=z r) (cond ((eq? r 'Z) 31) - ((<= 0 r 30) r) + ((and (exact-nonnegative-integer? r) (<= 0 r 30)) r) (else #f))) (define (register-31=sp r) - (cond ((<= 0 r 31) r) + (cond ((and (exact-nonnegative-integer? r) (<= 0 r 31)) r) (else #f))) (define (msr-pstatefield x) @@ -270,3 +343,16 @@ USA. ((OSHST) #b0010) ((OSHLD) #b0001) (else #f))) + +(define (load-signed-opc size) ;operand size + (case size + ((W) #b11) + ((X) #b10) + (else #f))) + +(define (load-signed-size sz) ;memory load size + (case sz + ((B) #b00) + ((H) #b01) + ((W) #b10) + (else #f))) diff --git a/src/compiler/machines/aarch64/lapgen.scm b/src/compiler/machines/aarch64/lapgen.scm index e6305e9c5..ab045fee8 100644 --- a/src/compiler/machines/aarch64/lapgen.scm +++ b/src/compiler/machines/aarch64/lapgen.scm @@ -55,17 +55,16 @@ USA. ;r19 - interpreter register block ;r20 - free pointer ;r21 - dynamic link - ;r22 - memtop + r22 ;XXX memtop? ;r23 - scheme-to-interface r24 r25 r26 r27 - r28 + ;r28 - stack pointer ;r29 - C frame pointer, callee-saved and left alone by Scheme ;r30 - link register (could maybe allocate) - ;r31 - stack pointer or zero register, depending on instruction - ; XXX could pick another one for our stack and leave this alone? + ;r31 - C stack pointer or zero register, depending on instruction ;; Vector registers, always available. v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15 v16 v17 v18 v19 v20 v21 v22 v23 v24 v25 v26 v27 v28 v29 v30 v31)) @@ -79,6 +78,12 @@ USA. ((register-value-class=word? register) 'GENERAL) ((register-value-class=float? register) 'FLOAT) (else (error "Unknown register type:" register)))) + +;;; References, for machine register allocator. Not used by LAP +;;; syntax. + +;; Following assumes objects and floats have the same indexing. +(assert (= scheme-object-width float-width 64)) (define register-reference (let ((references (make-vector number-of-machine-registers))) @@ -90,6 +95,34 @@ USA. (vector-set! references register (INST-EA (V ,(- register 32))))) (named-lambda (register-reference register) (vector-ref references register)))) + +(define (pseudo-register-home register) + (let ((number (register-renumber register))) + (assert number) + (INST-EA (HOME ,number)))) + +(define (ea/mode ea) (car ea)) + +(define (home-ea? ea) + (eq? 'HOME (ea/mode ea))) + +(define (home-ea/index ea) + (guarantee home-ea? ea) + (cadr ea)) + +(define (register-ea? ea) + (eq? 'R (ea/mode ea))) + +(define (register-ea/register ea) + (guarantee register-ea? ea) + (cadr ea)) + +(define (vector-ea? ea) + (eq? 'V (ea/mode ea))) + +(define (vector-ea/register ea) + (guarantee vector-ea? ea) + (cadr ea)) (define (register=? a b) (= a b)) @@ -102,85 +135,41 @@ USA. ((GENERAL) (if (or (= source rsp) (= target rsp)) (LAP (ADD X ,target ,source (&U 0))) - (LAP (ORR X ,target ,source (&U 0))))) + (LAP (ORR X ,target Z ,source)))) ((FLOAT) (LAP (FMOV D ,target ,source))) (else (error "Unknown register type:" source target))))) -(define (pseudo-register-home register) - (INST-EA (OFFSET ,regnum:regs-pointer ,(register-renumber register)))) +(define (spill-ea index) + ;; XXX fix register block indexing + (regblock-ea (+ 16 80 index))) -(define (home->register-transfer source target) - (memory->register-transfer regnum:regs-pointer - (pseudo-register-byte-offset source) - target)) +(define (home->register-transfer register alias) + (load-register alias (spill-ea (register-renumber register)))) -(define (register->home-transfer source target) - (register->memory-transfer source - regnum:regs-pointer - (pseudo-register-byte-offset target))) +(define (register->home-transfer alias register) + (store-register alias (spill-ea (register-renumber register)))) (define (reference->register-transfer source target) (case (ea/mode source) ((R) (register->register-transfer (register-ea/register source) target)) ((V) (register->register-transfer (vector-ea/register source) target)) - ((OFFSET) - (memory->register-transfer (offset-ea/offset source) - (offset-ea/register source) - target)) + ((HOME) (load-register target (spill-ea (home-ea/index source)))) (else (error "Unknown effective address mode:" source target)))) -(define (memory->register-transfer offset base target) - (case (register-type target) - ((GENERAL) - (LAP (LDR X ,target (OFFSET ,base ,offset)))) - ((FLOAT) - (LAP (LDR D ,target (OFFSET ,base ,offset)))) - (else - (error "Unknown register type:" target)))) - -(define (register->memory-transfer source offset base) - (case (register-type source) - ((GENERAL) - (LAP (STR X ,source (OFFSET ,base ,offset)))) - ((FLOAT) - (LAP (STR D ,source (OFFSET ,base ,offset)))) - (else - (error "Unknown register type:" source)))) - -;;; References, for machine register allocator. - -(define (ea/mode ea) (car ea)) - -(define (offset-reference register offset) - (INST-EA (OFFSET ,register ,offset))) - -(define (offset-ea? ea) - (eq? 'OFFSET (ea/mode ea))) - -(define (offset-ea/register ea) - (guarantee offset-ea? ea) - (cadr ea)) - -(define (offset-ea/offset ea) - (guarantee offset-ea? ea) - (caddr ea)) - -(define (register-ea? ea) - (eq? 'R (ea/mode ea))) - -(define (register-ea/register ea) - (guarantee register-ea? ea) - (cadr ea)) - -(define (vector-ea? ea) - (eq? 'V (ea/mode ea))) - -(define (vector-ea/register ea) - (guarantee vector-ea? ea) - (cadr ea)) +(define (load-register register ea) + (case (register-type register) + ((GENERAL) (LAP (LDR X ,register ,ea))) + ((FLOAT) (LAP (LDR D ,register ,ea))) + (else (error "Unknown register type:" register)))) + +(define (store-register register ea) + (case (register-type register) + ((GENERAL) (LAP (STR X ,register ,ea))) + ((FLOAT) (LAP (STR D ,register ,ea))) + (else (error "Unknown register type:" register)))) ;;; Utilities @@ -272,40 +261,26 @@ USA. (define (pop register) (LAP (LDR X ,register - (POST+ ,regnum:stack-pointer ,address-units-per-object)))) + (POST+ ,regnum:stack-pointer + (& ,(* address-units-per-object 1)))))) (define (push register) (LAP (STR X ,register - (PRE- ,regnum:stack-pointer ,address-units-per-object)))) + (PRE+ ,regnum:stack-pointer + (& ,(* address-units-per-object -1)))))) (define (pop2 reg1 reg2) ;; (LAP ,@(pop reg1) ,@(pop reg2)) - (LAP (LDRP X ,reg1 ,reg2 - (POST+ ,regnum:stack-pointer - ,(* 2 address-units-per-object))))) + (LAP (LDP X ,reg1 ,reg2 + (POST+ ,regnum:stack-pointer + (& (* ,address-units-per-object 2)))))) (define (push2 reg1 reg2) ;; (LAP ,@(push reg2) ,@(push reg1)) - (LAP (STRP X ,reg2 ,reg1 - (PRE- ,regnum:stack-pointer ,(* 2 address-units-per-object))))) - -(define (fits-in-unsigned-12? x) - (<= 0 x #xfff)) + (LAP (STP X ,reg2 ,reg1 + (PRE+ ,regnum:stack-pointer + (& (* ,address-units-per-object -2)))))) -(define (fits-in-unsigned-16? x) - (<= 0 x #xffff)) - -(define (fits-in-unsigned-32? x) - (<= 0 x #xffffffff)) - -(define (fits-in-unsigned-48? x) - (<= 0 x #xffffffffffff)) - -;; XXX doesn't belong here - -(define-integrable type-code:fixnum #x1a) -(define-integrable type-code:manifest-closure #x0d) - (define (scale->shift scale) (case scale ((1) 0) @@ -324,6 +299,21 @@ USA. (lambda (target base offset) (LAP (ADD X ,target ,base (LSL ,offset ,(scale->shift scale))))))) +(define (load-pc-relative-address target label) + (LAP (ADR X ,target (@PCR ,label ,regnum:scratch-0)))) + +(define (load-pc-relative target label) + (LAP ,@(load-pc-relative-address target label) + (LDR X ,target ,target))) + +(define (load-tagged-immediate target type datum) + (load-unsigned-immediate target (make-non-pointer-literal type datum))) + +(define (load-constant target object) + (if (non-pointer-object? object) + (load-unsigned-immediate target (non-pointer->literal object)) + (load-pc-relative target (constant->label object)))) + (define (load-signed-immediate target imm) (load-unsigned-immediate target (bitwise-and imm #xffffffffffffffff))) @@ -338,10 +328,11 @@ USA. (try-shift imm 32) (try-shift imm 48))) (define (chunk16 pos) - (bitwise-and (shift-right imm 16) pos)) + (bitwise-and (shift-right imm pos) #xffff)) (cond ((find-shift imm) => (lambda (shift) - (LAP (MOVZ X ,target (LSL (&U ,imm) ,shift))))) + (LAP (MOVZ X ,target + (LSL (&U ,(shift-right imm shift)) ,shift))))) ((find-shift (bitwise-not imm)) => (lambda (shift) (LAP (MOVN X ,target (LSL (&U ,(bitwise-not imm)) ,shift))))) @@ -364,21 +355,10 @@ USA. (MOVK X ,target (LSL (&U ,(chunk16 32)) 32)) (MOVK X ,target (LSL (&U ,(chunk16 48)) 48)))))) -(define (load-pc-relative-address target label) - ;; XXX What happens if label is >1 MB away? - (LAP (ADR X ,target (@PCR ,label)))) - -(define (load-pc-relative target label) - (LAP ,@(load-pc-relative-address target label) - (LDR X ,target ,target))) - -(define (load-tagged-immediate target type datum) - (load-unsigned-immediate target (make-non-pointer-literal type datum))) - -(define (load-constant target object) - (if (non-pointer-object? object) - (load-unsigned-immediate target (non-pointer->literal object)) - (load-pc-relative target (constant->label object)))) +(define (logical-immediate? x) + x + ;; XXX + #f) (define (add-immediate target source imm) (define (add addend) (LAP (ADD X ,target ,source ,addend))) @@ -401,16 +381,16 @@ USA. (cond ((fits-in-unsigned-12? imm) (add `(&U ,imm))) ((and (zero? (bitwise-and imm (bit-mask 12 0))) - (fits-in-unsigned-12? (shift-right immediate 12))) + (fits-in-unsigned-12? (shift-right imm 12))) (add `(&U ,imm LSL 12))) - ((fits-in-unsigned-12? (- immediate)) - (sub `(&U ,(- immediate)))) + ((fits-in-unsigned-12? (- imm)) + (sub `(&U ,(- imm)))) ((and (zero? (bitwise-and imm (bit-mask 12 0))) - (fits-in-unsigned-12? (shift-right (- immediate) 12))) - (sub `(&U ,(- immediate) LSL 12))) + (fits-in-unsigned-12? (shift-right (- imm) 12))) + (sub `(&U ,(- imm) LSL 12))) (else (let ((temp (allocate-temporary-register! 'GENERAL))) - (LAP ,@(load-unsigned-immediate temp immediate) + (LAP ,@(load-unsigned-immediate temp imm) ,@(add temp)))))) (define (affix-type target type datum) @@ -423,13 +403,7 @@ USA. ((logical-immediate? (make-non-pointer-literal type 0)) ;; Works for tags with only contiguous one bits, including ;; tags with only one bit set. - (LAP (ORR ,target ,datum (&U ,(make-non-pointer-literal type 0))))) - ((fits-in-unsigned-12? - (shift-left type (- scheme-datum-width 48))) - ;; Works for 2-bit tags. - (let ((imm (shift-left type (- scheme-datum-width 48))) - (shift 48)) - (LAP (ADD ,target ,datum (LSL (&U ,imm) ,shift))))) + (LAP (ORR X ,target ,datum (&U ,(make-non-pointer-literal type 0))))) (else ;; Works for all tags up to 16 bits, but costs two ;; instructions. @@ -438,8 +412,8 @@ USA. ;; could use a single MOVK instruction. (let ((imm (shift-left type (- 16 scheme-type-width))) (shift 48)) - (LAP (MOVZ ,target (LSL (&U ,imm) ,shift)) - (ORR ,target ,target ,datum)))))) + (LAP (MOVZ X ,target (LSL (&U ,imm) ,shift)) + (ORR X ,target ,target ,datum)))))) (define (object->type target source) (let ((lsb scheme-datum-width) @@ -468,9 +442,12 @@ USA. (LAP (ENTRY-POINT ,label) ,@(make-external-label expression-code-word label))) +(define entry-padding-bit-string + (unsigned-integer->bit-string 32 0)) + (define (make-external-label type/arity label) (set! *external-labels* (cons label *external-labels*)) - (LAP (PADDING 32 64 0) + (LAP (PADDING 32 64 ,entry-padding-bit-string) (EXTERNAL-LABEL ,type/arity ,label) (DATA 64 U 0) (LABEL ,label))) @@ -483,34 +460,20 @@ USA. ;;;; Named registers, codes, and entries -(define reg:memtop - (offset-reference regnum:regs-pointer - register-block/memtop-offset)) - -(define reg:environment - (offset-reference regnum:regs-pointer - register-block/environment-offset)) +(define (regblock-ea offset) + ;; LDR/STR operand. + (INST-EA (+ ,regnum:regs-pointer (&U (* 8 ,offset))))) +(define reg:memtop (regblock-ea register-block/memtop-offset)) +(define reg:environment (regblock-ea register-block/environment-offset)) (define reg:lexpr-primitive-arity - (offset-reference regnum:regs-pointer - register-block/lexpr-primitive-arity-offset)) - -(define reg:stack-guard - (offset-reference regnum:regs-pointer - register-block/stack-guard-offset)) - -(define reg:int-mask - (offset-reference regnum:regs-pointer - register-block/int-mask-offset)) - -(define reg:int-code - (offset-reference regnum:regs-pointer - register-block/int-code-offset)) - + (regblock-ea register-block/lexpr-primitive-arity-offset)) +(define reg:stack-guard (regblock-ea register-block/stack-guard-offset)) +(define reg:int-mask (regblock-ea register-block/int-mask-offset)) +(define reg:int-code (regblock-ea register-block/int-code-offset)) (define reg:reflect-to-interface - (offset-reference regnum:regs-pointer - register-block/reflect-to-interface-offset)) - + (regblock-ea register-block/reflect-to-interface-offset)) + (define-syntax define-codes (sc-macro-transformer (lambda (form environment) @@ -565,7 +528,7 @@ USA. quotient remainder modulo) - + (define-syntax define-entries (sc-macro-transformer (lambda (form environment) @@ -621,7 +584,7 @@ USA. apply-setup-size-7 apply-setup-size-8 set-interrupt-enables!) - + (define-integrable (invoke-hook entry) (LAP (LDR X ,regnum:scratch-0 (+ ,regnum:regs-pointer (&U (* 8 ,entry)))) (BR ,regnum:scratch-0))) @@ -689,11 +652,3 @@ USA. (determine-interrupt-checks (edge-right-node edge))) (rgraph-entry-edges rgraph))) rgraphs)) - -;; XXX - -(define (back-end:object-type object) - (object-type object)) - -(define (back-end:object-datum object) - (object-datum object)) diff --git a/src/compiler/machines/aarch64/machine.scm b/src/compiler/machines/aarch64/machine.scm index 83cca0e8c..01562ecf4 100644 --- a/src/compiler/machines/aarch64/machine.scm +++ b/src/compiler/machines/aarch64/machine.scm @@ -194,10 +194,10 @@ USA. (define-integrable r25 25) ;temporary callee-saved (define-integrable r26 26) ;temporary callee-saved (define-integrable r27 27) ;temporary callee-saved -(define-integrable r28 28) ;temporary callee-saved +(define-integrable r28 28) ;stack pointer callee-saved (define-integrable r29 29) ;C frame pointer frame pointer (define-integrable rlr 30) ;link register link register -(define-integrable rsp 31) ;stack pointer stack pointer +(define-integrable rsp 31) ;C stack pointer stack pointer ;; Note: Register 31 is alternately the stack pointer or the zero ;; register, depending on instruction. @@ -260,11 +260,12 @@ USA. (define-integrable regnum:regs-pointer r19) (define-integrable regnum:free-pointer r20) (define-integrable regnum:dynamic-link r21) ;Pointer to parent stack frame. -(define-integrable regnum:memtop r22) +;; (define-integrable regnum:memtop r22) (define-integrable regnum:scheme-to-interface r23) +(define-integrable regnum:stack-pointer r27) (define-integrable regnum:c-frame-pointer r29) (define-integrable regnum:link-register rlr) ;Return address. -(define-integrable regnum:stack-pointer rsp) +(define-integrable regnum:c-stack-pointer rsp) ;; XXX Maybe we're playing a dangerous game to use the scratch registers for ;; these. @@ -290,9 +291,11 @@ USA. (vector-set! classes regnum:regs-pointer value-class=address) (vector-set! classes regnum:free-pointer value-class=address) (vector-set! classes regnum:dynamic-link value-class=address) - (vector-set! classes regnum:memtop value-class=address) - (vector-set! classes regnum:c-frame-pointer value-class=address) + ;; (vector-set! classes regnum:memtop value-class=address) (vector-set! classes regnum:stack-pointer value-class=address) + (vector-set! classes regnum:c-frame-pointer value-class=address) + (vector-set! classes regnum:link-register value-class=address) + (vector-set! classes regnum:c-stack-pointer value-class=address) (named-lambda (machine-register-value-class register) (assert (<= 0 register)) (assert (< register number-of-machine-registers)) @@ -365,7 +368,7 @@ USA. (case register-name ((DYNAMIC-LINK) (interpreter-dynamic-link)) ((FREE) (interpreter-free-pointer)) - ((MEMORY-TOP) (rtl:make-machine-register regnum:memtop)) + ;; ((MEMORY-TOP) (rtl:make-machine-register regnum:memtop)) ((STACK-POINTER) (interpreter-stack-pointer)) ((VALUE) (interpreter-value-register)) ((INTERPRETER-CALL-RESULT:ACCESS) @@ -386,13 +389,13 @@ USA. (case rtl-register ((INT-MASK) register-block/int-mask-offset) ((ENVIRONMENT) register-block/environment-offset) - ((DYNAMIC-LINK) register-block/dynamic-link-offset) + ((MEMORY-TOP) register-block/memtop-offset) (else #f))) (define (rtl:interpreter-register->offset locative) (or (rtl:interpreter-register? locative) (error "Unknown interpreter register:" locative))) - + (define (rtl:constant-cost expression) ;; XXX Justify this by reference to cycle counts, &c. This really ;; depends on which instruction we're talking about -- sometimes @@ -415,6 +418,7 @@ USA. ((or (fits-in-unsigned-32? immediate) (fits-in-unsigned-32? (- immediate))) cost:imm32) + ;; XXX logical immediate ((or (fits-in-unsigned-48? immediate) (fits-in-unsigned-48? (- immediate))) cost:imm48) @@ -446,6 +450,7 @@ USA. (+ (immediate-cost offset) cost:add)))) cost:add))))) + (case (rtl:expression-type expression) ((MACHINE-CONSTANT) (immediate-cost (rtl:machine-constant-value expression))) @@ -482,6 +487,39 @@ USA. (tagged-immediate-cost type datum))))) (else #f)))) +(define (fits-in-signed-9? x) + (<= #x-100 x #xff)) + +(define (fits-in-unsigned-12? x) + (<= 0 x #xfff)) + +(define (fits-in-unsigned-16? x) + (<= 0 x #xffff)) + +(define (fits-in-unsigned-32? x) + (<= 0 x #xffffffff)) + +(define (fits-in-unsigned-48? x) + (<= 0 x #xffffffffffff)) + +;; XXX doesn't belong here + +(define-integrable type-code:fixnum #x1a) +(define-integrable type-code:manifest-closure #x0d) +(define-integrable type-code:manifest-vector #x00) + +;; XXX + +(define (non-pointer->literal object) + (make-non-pointer-literal (back-end:object-type object) + (back-end:object-datum object))) + +(define (back-end:object-type object) + (object-type object)) + +(define (back-end:object-datum object) + (object-datum object)) + (define compiler:open-code-floating-point-arithmetic? ;; XXX not yet #f) diff --git a/src/compiler/machines/aarch64/rules1.scm b/src/compiler/machines/aarch64/rules1.scm index 5579d952a..55dcfe73c 100644 --- a/src/compiler/machines/aarch64/rules1.scm +++ b/src/compiler/machines/aarch64/rules1.scm @@ -109,8 +109,8 @@ USA. (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) (rtl-target:=machine-register! target regnum:link-register) (let ((linked (generate-label 'LINKED))) - (LAP (BL (@PCR ,linked)) - (B (@PCR ,label)) + (LAP (BL (@PCR ,linked ,regnum:scratch-0)) + (B (@PCR ,label ,regnum:scratch-0)) (LABEL ,linked)))) (define-rule statement @@ -207,41 +207,43 @@ USA. (define-rule statement (ASSIGN (REGISTER (? target)) (PRE-INCREMENT (REGISTER (? sp)) (? offset))) - (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63)) + (QUALIFIER (fits-in-signed-9? (* address-units-per-object offset))) (standard-unary target sp (lambda (target sp) - (LAP (LDR X ,target (PRE+ ,sp (& ,offset))))))) + (LAP (LDR X ,target + (PRE+ ,sp (& ,(* address-units-per-object offset)))))))) ;;; Load with post-increment: *x++ (define-rule statement (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? sp)) (? offset))) - (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63)) + (QUALIFIER (fits-in-signed-9? (* address-units-per-object offset))) (standard-unary target sp (lambda (target sp) - (LAP (LDR X ,target (POST+ ,sp (& ,offset))))))) + (LAP (LDR X ,target + (POST+ ,sp (& ,(* address-units-per-object offset)))))))) ;;; Store with pre-increment: *++x = y (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER (? sp)) (? offset)) (? source register-expression)) - (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63)) - (standard-binary-effect sp source - (lambda (sp source) - (let ((offset (* offset (quotient address-units-per-object 4)))) - (LAP (STR X ,source (PRE+ ,sp (& ,offset)))))))) + (QUALIFIER (fits-in-signed-9? (* address-units-per-object offset))) + (standard-binary-effect source sp + (lambda (source sp) + (LAP (STR X ,source + (PRE+ ,sp (& ,(* address-units-per-object offset)))))))) ;;; Store with post-increment: *x++ = y (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER (? sp)) (? offset)) (? source register-expression)) - (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63)) - (standard-binary-effect sp source - (lambda (sp source) - (let ((offset (* offset (quotient address-units-per-object 4)))) - (LAP (STR X ,source (POST+ ,sp (& ,offset)))))))) + (QUALIFIER (fits-in-signed-9? (* address-units-per-object offset))) + (standard-binary-effect source sp + (lambda (source sp) + (LAP (STR X ,source + (POST+ ,sp (& ,(* address-units-per-object offset)))))))) ;;;; Byte access diff --git a/src/compiler/machines/aarch64/rules2.scm b/src/compiler/machines/aarch64/rules2.scm index c629be907..bef249b29 100644 --- a/src/compiler/machines/aarch64/rules2.scm +++ b/src/compiler/machines/aarch64/rules2.scm @@ -85,18 +85,6 @@ USA. (LAP (LSR X ,temp (&U ,(- scheme-datum-width 1))) (CMP X ,temp (&U ,(* 2 type-code:fixnum)))))) -(define (set-equal-branches!) - (set-current-branches! (lambda (label) (LAP (B.EQ (@PCR ,label)))) - (lambda (label) (LAP (B.NE (@PCR ,label)))))) - -(define (set-not-equal-branches!) - (set-current-branches! (lambda (label) (LAP (B.NE (@PCR ,label)))) - (lambda (label) (LAP (B.EQ (@PCR ,label)))))) - -(define (set-equal-zero-branches! source) - (set-current-branches! (lambda (label) (LAP (CBZ ,source (@PCR ,label)))) - (lambda (label) (LAP (CBNZ ,source (@PCR ,label)))))) - (define (zero-test! register) (set-equal-zero-branches! register) (LAP)) @@ -110,3 +98,35 @@ USA. (begin (set-equal-branches!) (cmp-immediate register immediate)))) + +(define (set-always-branches!) + (set-current-branches! + (lambda (label) (LAP (B (@PCR ,label ,regnum:scratch-0)))) + (lambda (label) label (LAP)))) + +(define (set-never-branches!) + (set-current-branches! + (lambda (label) label (LAP)) + (lambda (label) (LAP (B (@PCR ,label ,regnum:scratch-0)))))) + +(define (set-equal-zero-branches! source) + (set-current-branches! + (lambda (label) (LAP (CBZ X ,source (@PCR ,label ,regnum:scratch-0)))) + (lambda (label) (LAP (CBNZ X ,source (@PCR ,label ,regnum:scratch-0)))))) + +(define (set-condition-branches! cc ~cc) + (set-current-branches! + (lambda (label) (LAP (B. ,cc (@PCR ,label ,regnum:scratch-0)))) + (lambda (label) (LAP (B. ,~cc (@PCR ,label ,regnum:scratch-0)))))) + +(define (set-carry-branches!) + (set-condition-branches! 'CS 'CC)) + +(define (set-overflow-branches!) + (set-condition-branches! 'VS 'VC)) + +(define (set-equal-branches!) + (set-condition-branches! 'EQ 'NE)) + +(define (set-not-equal-branches!) + (set-condition-branches! 'NE 'EQ)) diff --git a/src/compiler/machines/aarch64/rules3.scm b/src/compiler/machines/aarch64/rules3.scm index b06de2637..ef8f3d296 100644 --- a/src/compiler/machines/aarch64/rules3.scm +++ b/src/compiler/machines/aarch64/rules3.scm @@ -33,7 +33,7 @@ USA. (define-rule statement (POP-RETURN) - (let* ((checks (get-interrupt-checks)) + (let* ((checks (get-exit-interrupt-checks)) (prefix (clear-map!)) (suffix (if (pair? checks) @@ -49,11 +49,11 @@ USA. (define (pop-return/interrupt-check) (share-instruction-sequence! 'POP-RETURN - (lambda (shared-label) (LAP (B (@PCR ,shared-label)))) + (lambda (shared-label) (LAP (B (@PCR ,shared-label ,regnum:scratch-0)))) (lambda (shared-label) (let ((interrupt-label (generate-label 'INTERRUPT))) (LAP (LABEL ,shared-label) - ,@(interrupt-check '(HEAP) label) + ,@(interrupt-check '(HEAP) interrupt-label) ,@(pop-return) (LABEL ,interrupt-label) ,@(invoke-hook entry:compiler-interrupt-continuation-2)))))) @@ -87,7 +87,7 @@ USA. frame-size continuation (expect-no-exit-interrupt-checks) (LAP ,@(clear-map!) - (B (@PCR ,label)))) + (B (@PCR ,label ,regnum:scratch-0)))) (define (entry->pc pc entry) ;; XXX Would be nice to skip the SUB, but LDR doesn't have a signed @@ -129,16 +129,18 @@ USA. continuation (expect-no-exit-interrupt-checks) (LAP ,@(clear-map!) - (B (@PCRO ,(free-uuo-link-label name frame-size) - ,(uuo-link-label-offset))))) + (B (@PCR (+ ,(free-uuo-link-label name frame-size) + (* 4 ,(uuo-link-label-instruction-offset))) + ,regnum:scratch-0)))) (define-rule statement (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name)) continuation (expect-no-exit-interrupt-checks) (LAP ,@(clear-map!) - (B (@PCRO ,(global-uuo-link-label name frame-size) - ,(uuo-link-label-offset))))) + (B (@PCR (+ ,(global-uuo-link-label name frame-size) + (* 4 ,(uuo-link-label-instruction-offset))) + ,regnum:scratch-0)))) (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) @@ -172,7 +174,7 @@ USA. (define (generate/generic-primitive frame-size primitive) (let* ((prefix (clear-map!)) - (arg0 (load-constant primitive regnum:utility-arg0))) + (arg0 (load-constant regnum:utility-arg0 primitive))) (LAP ,@prefix ,@arg0 ,@(let ((arity (primitive-procedure-arity primitive))) @@ -191,7 +193,7 @@ USA. (load-unsigned-immediate regnum:scratch-0 (- frame-size 1))) (invocation (invoke-hook entry:compiler-primitive-lexpr-apply))) (LAP ,@load-nargs - (STR X ,regnum:scratch-0 ,reg:lexpr-primitive-apply) + (STR X ,regnum:scratch-0 ,reg:lexpr-primitive-arity) ,@invocation))) (define (generate/generic-apply frame-size) @@ -264,7 +266,7 @@ USA. (define-rule statement (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? address))) (let ((address (standard-source! address))) - (assert (not (= register regnum:stack-pointer))) + (assert (not (= address regnum:stack-pointer))) (generate/move-frame-up frame-size address))) (define-rule statement @@ -279,17 +281,17 @@ USA. (assert (not (= address regnum:stack-pointer))) (assert (not (= dynamic-link regnum:stack-pointer))) (LAP (CMP X ,address ,dynamic-link) - (CSEL.GT ,address ,address ,dynamic-link) + (CSEL X GT ,address ,address ,dynamic-link) ,@(generate/move-frame-up frame-size address)))) (define (generate/move-frame-up frame-size address) - (assert (not (= register regnum:stack-pointer))) + (assert (not (= address regnum:stack-pointer))) (if (<= frame-size 6) ;Covers vast majority of cases. (generate/move-frame-up/unrolled frame-size address) (generate/move-frame-up/loop frame-size address))) (define (generate/move-frame-up/loop frame-size address) - (assert (not (= register regnum:stack-pointer))) + (assert (not (= address regnum:stack-pointer))) (assert (>= frame-size 2)) (assert (fits-in-unsigned-12? (* 8 frame-size))) ;XXX (assert (= 8 address-units-per-object)) @@ -302,17 +304,17 @@ USA. (loop-count (- frame-size (remainder frame-size 2)))) (assert (= loop-count (* (quotient frame-size 2) 2))) (LAP (ADD X ,regnum:stack-pointer ,regnum:stack-pointer - (&U ,(* 8 frame-size))) + (&U ,(* 8 frame-size))) ,@(if (odd? frame-size) - (LAP (LDR X ,temp1 (PRE- ,regnum:stack-pointer (&U 8))) - (STR X ,temp1 (PRE- ,address (&U 8)))) + (LAP (LDR X ,temp1 (PRE+ ,regnum:stack-pointer (& (* 8 -1)))) + (STR X ,temp1 (PRE+ ,address (& (* 8 -1))))) (LAP)) ,@(load-unsigned-immediate index loop-count) (LABEL ,label) (SUB X ,index (&U #x10)) - (LDRP X ,temp1 ,temp2 (PRE- ,regnum:stack-pointer (&U #x10))) - (STRP X ,temp1 ,temp2 (PRE- ,address (&U #x10))) - (CBNZ X ,index (@PCR ,label)) + (LDRP X ,temp1 ,temp2 (PRE+ ,regnum:stack-pointer (& (* 8 -2)))) + (STRP X ,temp1 ,temp2 (PRE+ ,address (& (* 8 -2)))) + (CBNZ X ,index (@PCR ,label ,regnum:scratch-0)) ,@(register->register-transfer address regnum:stack-pointer)))) (define (generate/move-frame-up/unrolled frame-size address) @@ -407,12 +409,12 @@ USA. (LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks)) (LAP (LDR X ,regnum:scratch-0 ,reg:memtop) (CMP X ,regnum:free-pointer ,regnum:scratch-0) - (B.GE (@PCR ,label))) + (B. GE (@PCR ,label ,regnum:scratch-0))) (LAP)) ,@(if (memq 'STACK checks) (LAP (LDR X ,regnum:scratch-0 ,reg:stack-guard) (CMP X ,regnum:stack-pointer ,regnum:scratch-0) - (B.LT (@PCR ,label))) + (B. LT (@PCR ,label ,regnum:scratch-0))) (LAP)))) (define (simple-procedure-header code-word label entry) @@ -542,17 +544,17 @@ USA. (temp (allocate-temporary-register! 'GENERAL)) (manifest-type type-code:manifest-closure) (manifest-size (closure-manifest-size size)) - (Free Free)) + (Free regnum:free-pointer)) (LAP ,@(load-tagged-immediate manifest-type manifest-size temp) (STR X ,temp (POST+ ,Free (& 8))) - ,@(generate-closure-entry label min max 1 temp) + ,@(generate-closure-entry label 1 min max 1 temp) ;; Free now points at the entry. Save it in target. ,@(register->register-transfer Free target) ;; Bump Free to point at the last component, one word before ;; the next object. We do this because we need to set the ;; last component here, but we do not have negative load/store ;; offsets without pre/post-increment. - ,@(add-immediate Free Free (* 8 size)) + ,@(add-immediate Free Free (* 8 size)) ;; Set the last component to be the relocation reference point. ,@(affix-type temp type-code:compiled-entry target) (STR X ,temp (POST+ ,Free (& 8)))))) @@ -589,7 +591,7 @@ USA. ;; the next object. We do this because we need to set the ;; last component here, but we do not have negative load/store ;; offsets without pre/post-increment. - ,@(add-immediate Free Free (* 8 size)) + ,@(add-immediate Free Free (* 8 size)) ;; Set the last component to be the relocation reference point. ,@(affix-type temp type-code:compiled-entry target) (STR X ,temp (POST+ ,Free (& 8)))))) @@ -616,7 +618,7 @@ USA. (LAP ,@(load-unsigned-immediate temp (padded-word)) (STR X ,temp (POST+ ,Free (& 8))) ;; Set temp := label - 8. - (ADR X ,temp (@PCR (- ,label* 8))) + (ADR X ,temp (@PCR (- ,label* 8) ,regnum:scratch-0)) ;; Set temp := label - 8 - free = label - (free + 8). (SUB X ,temp ,temp ,Free) ;; Store the PC offset. @@ -633,25 +635,116 @@ USA. ;;;; Entry Header +;;; XXX Why are these hand-coded assembly routines and not C functions? +;;; For that matter, why aren't they just the job of the loader? + +;;; (GENERATE/QUOTATION-HEADER ) +;;; +;;; Store the interpreter's environment register in this block's +;;; environment slot; then call link(block_addr, constants_addr, +;;; nsects). + (define (generate/quotation-header environment-label free-ref-label n-sections) (let ((continuation-label (generate-label 'LINKED))) (LAP (LDR X ,r0 ,reg:environment) - (ADR X ,r1 (@PCR ,environment-label)) + (ADR X ,r1 (@PCR ,environment-label ,regnum:scratch-0)) (STR X ,r0 ,r1) - (ADR X ,regnum:utility-arg0 (@PCR ,*block-label*)) - (ADR X ,regnum:utility-arg1 (@PCR ,free-ref-label)) - ,@(load-unsigned-immediate regnum:utility-arg2 n-sections) + (ADR X ,regnum:utility-arg1 (@PCR ,*block-label* ,regnum:scratch-0)) + (ADR X ,regnum:utility-arg2 (@PCR ,free-ref-label ,regnum:scratch-0)) + ,@(load-unsigned-immediate regnum:utility-arg3 n-sections) ,@(invoke-hook/call entry:compiler-link continuation-label) ,@(make-external-label (continuation-code-word #f) continuation-label)))) -;;; XXX Why is this hand-coded assembly and not a C function? - +(define (generate/remote-link code-block-label + environment-offset + free-ref-offset + n-sections) + (let ((continuation-label (generate-label 'LINKED)) + ;; arg0 will be the return address. + (arg1 regnum:utility-arg1) + (arg2 regnum:utility-arg2) + (arg3 regnum:utility-arg3) + (temp r1)) + (LAP (LDR X ,temp ,reg:environment) + ;; arg1 := block address + ,@(load-pc-relative arg1 code-block-label) + ,@(object->address arg1 arg1) + ;; Set this block's environment. + (STR X ,temp (+ ,arg1 (&U (* 8 ,environment-offset)))) + ;; arg2 := constants address + ,@(add-immediate arg2 arg1 free-ref-offset) + ;; arg3 := n sections + ,@(load-unsigned-immediate arg3 n-sections) + ,@(invoke-interface/call code:compiler-link continuation-label) + ,@(make-external-label (continuation-code-word #f) + continuation-label)))) + (define (generate/remote-links n-blocks vector-label nsects) - vector-label nsects (if (zero? n-blocks) (LAP) - (error "XXX not yet implemented"))) + (let* ((loop-label (generate-label 'LOOP)) + (nsects-label (generate-label 'NSECTS)) + (end-label (generate-label 'END)) + (continuation-label (generate-label 'LINKED)) + (counter r24) ;unallocated, callee-saves + (temp1 r1) ;unallocated + (temp2 r2) ;unallocated + ;; arg0 will be return address. + (arg1 regnum:utility-arg1) + (arg2 regnum:utility-arg2) + (arg3 regnum:utility-arg3)) + (LAP ,@(load-unsigned-immediate counter n-blocks) + (LABEL ,loop-label) + ,@(load-pc-relative arg1 vector-label) ;arg1 := vector + ,@(object->address arg1 arg1) ;arg1 := vector addr + (LDR X ,arg1 (+ ,arg1 (LSL ,counter 3))) ;arg1 := vector[ctr-1] + ,@(object->address arg1 arg1) ;arg1 := block addr + (LDR X ,temp1 ,reg:environment) ;temp1 := environment + (LDR X ,temp2 ,arg1) ;temp2 := manifest + ,@(object->datum temp2 temp2) ;temp2 := block length + (STR X ,temp1 (+ ,arg1 (LSL ,temp2 3))) ;set block environment + (LDR X ,temp1 (+ ,arg1 (&U (* 8 1)))) ;temp1 := manifest-nmv + ,@(object->datum temp1 temp1) ;temp1 := unmarked size + (ADD X ,temp1 ,temp1 (&U #x10)) ;temp1 := consts offset + (ADD X ,arg2 ,arg1 ,temp1) ;temp1 := consts addr + (SUB X ,counter (&U 1)) ;ctr := ctr - 1 + (ADR X ,arg3 (@PCR ,nsects ,regnum:scratch-0)) ;arg3 := nsects + (LDR B ,arg3 (+ ,arg3 ,counter)) ;arg3 := nsects[ctr] + ,@(invoke-interface/call code:compiler-link continuation-label) + ,@(make-external-label (continuation-code-word #f) + continuation-label) + (CBNZ X ,counter ;repeat if ctr != 0 + (@PCR ,loop-label ,regnum:scratch-0)) + (B (@PCR ,end-label ,regnum:scratch-0)) ;otherwise go on + (LABEL ,nsects-label) + ,@(generate/nsects nsects) + (LABEL ,end-label))))) + +(define (generate/nsects nsects) + (let ((n (vector-length nsects))) + (define (adjoin/be byte word bits) + (bitwise-ior (shift-left byte bits) word)) + (define (adjoin/le byte word bits) + bits + (bitwise-ior byte (shift-left word 8))) + (define adjoin + (case endianness + ((BIG) adjoin/be) + ((LITTLE) adjoin/le) + (else (error "Unknown endianness:" endianness)))) + (let loop + ((i (* (quotient (+ n 7) 8) 8)) + (words (LAP))) + (if (< 0 i) + (let subloop ((j 0) (word 0)) + (if (< j 8) + (let ((byte (if (< (+ i j) n) (vector-ref nsects (+ i j)) 0))) + (subloop (+ j 1) (adjoin byte word (* j 8)))) + (loop (- i 8) + (LAP (DATA 64 U ,word) + ,@words)))) + words)))) (define (generate/constants-block constants references assignments uuo-links global-links static-vars) @@ -729,7 +822,7 @@ USA. (cdr variable.caches))) variable.caches-list)) -(define (uuo-link-label-offset) +(define (uuo-link-label-instruction-offset) (case endianness ;; On big-endian systems, the label points exactly at the code, ;; aligned on an object boundary. @@ -737,5 +830,5 @@ USA. ;; On little-endian systems, the code starts halfway in the middle ;; of the frame size object, clobbering the fixnum tag but leaving ;; the 16-bit value intact. - ((LITTLE) 4) + ((LITTLE) 1) (else (error "Unknown endianness:" endianness)))) diff --git a/src/compiler/machines/aarch64/rules4.scm b/src/compiler/machines/aarch64/rules4.scm index a7f638637..78673e708 100644 --- a/src/compiler/machines/aarch64/rules4.scm +++ b/src/compiler/machines/aarch64/rules4.scm @@ -32,51 +32,47 @@ USA. ;;;; Variable cache trap handling. (define-rule statement - (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?)) - (QUALIFIER (interpreter-call-argument? extension)) - (define (get-argument value register) - (interpreter-call-argument->machine-register! value register)) - (let ((set-extension (get-argument extension regnum:utility-arg1))) + (INTERPRETER-CALL:CACHE-REFERENCE (? continuation) + (REGISTER (? extension)) + (? safe?)) + ;; arg0 will be the return address. + (require-register! regnum:utility-arg1) + (let* ((set-extension (load-machine-register! extension regnum:utility-arg1)) + (prefix (clear-map!))) (LAP ,@set-extension - ,@(clear-map!) - #| + ,@prefix ,@(invoke-interface/call (if safe? code:compiler-safe-reference-trap code:compiler-reference-trap) - cont) - |# - ,@(invoke-hook/call - (if safe? - entry:compiler-safe-reference-trap - entry:compiler-reference-trap) - cont)))) + continuation)))) (define-rule statement - (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value)) - (QUALIFIER (and (interpreter-call-argument? extension) - (interpreter-call-argument? value))) - (define (get-argument value register) - (interpreter-call-argument->machine-register! value register)) - (let* ((set-extension (get-argument extension regnum:utility-arg1)) - (set-value (get-argument extension regnum:utility-arg2))) + (INTERPRETER-CALL:CACHE-ASSIGNMENT (? continuation) + (REGISTER (? extension)) + (REGISTER (? value))) + ;; arg0 will be the return address. + (require-register! regnum:utility-arg1) + (require-register! regnum:utility-arg2) + (let* ((set-extension (load-machine-register! extension regnum:utility-arg1)) + (set-value (load-machine-register! value regnum:utility-arg1)) + (prefix (clear-map!))) (LAP ,@set-extension ,@set-value - ,@(clear-map!) - #| - ,@(invoke-interface/call code:compiler-assignment-trap cont) - |# - ,@(invoke-hook/call entry:compiler-assignment-trap cont)))) + ,@prefix + ,@(invoke-interface/call code:compiler-reference-trap continuation)))) (define-rule statement - (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension)) - (QUALIFIER (interpreter-call-argument? extension)) - (define (get-argument value register) - (interpreter-call-argument->machine-register! value register)) - (let ((set-extension (get-argument extension regnum:utility-arg1))) + (INTERPRETER-CALL:CACHE-UNASSIGNED? (? continuation) + (REGISTER (? extension))) + ;; arg0 will be the return address. + (require-register! regnum:utility-arg1) + (let* ((set-extension (load-machine-register! extension regnum:utility-arg1)) + (prefix (clear-map!))) (LAP ,@set-extension - ,@(clear-map!) - ,@(invoke-interface/call code:compiler-unassigned?-trap cont)))) + ,@prefix + ,@(invoke-interface/call code:compiler-unassigned?-trap + continuation)))) ;;; Obsolete interpreter calls, should be flushed. diff --git a/src/compiler/machines/aarch64/rulfix.scm b/src/compiler/machines/aarch64/rulfix.scm index 4f5ab88ec..d8cf2aa20 100644 --- a/src/compiler/machines/aarch64/rulfix.scm +++ b/src/compiler/machines/aarch64/rulfix.scm @@ -59,7 +59,8 @@ USA. (LAP (LSL X ,target ,source (&U ,scheme-type-width)))) (define (fixnum->object target source) - (LAP (ORR X ,target ,source (&U ,type-code:fixnum)) + ;; XXX See if ORR can do the trick. + (LAP (ADD X ,target ,source (&U ,type-code:fixnum)) (ROR X ,target ,target (&U ,scheme-type-width)))) (define (address->fixnum target source) @@ -102,18 +103,6 @@ USA. (lambda (target source overflow?) (fixnum-add-constant target source -1 overflow?))) -(define (set-always-branches!) - (set-current-branches! (lambda (label) (LAP (B (@PCR ,label)))) - (lambda (label) label (LAP)))) - -(define (set-never-branches!) - (set-current-branches! (lambda (label) label (LAP)) - (lambda (label) (LAP (B (@PCR ,label)))))) - -(define (set-carry-branches!) - (set-current-branches! (lambda (label) (LAP (B.CS (@PCR ,label)))) - (lambda (label) (LAP (B.CC (@PCR ,label)))))) - (define (fixnum-add-constant target source n overflow?) (let ((imm (* fixnum-1 n))) (cond ((not overflow?) @@ -122,7 +111,7 @@ USA. (set-never-branches!) (register->register-transfer source target)) (else - (set-carry-branches!) + (set-overflow-branches!) (add-immediate-with-flags target source imm))))) (define (load-fixnum-constant target n) @@ -150,13 +139,13 @@ USA. target source1 source2 overflow?) (if overflow? (begin - (set-carry-branches!) - (LAP (,flags ,target ,source1 ,source2))) - (LAP (,no-flags ,target ,source1 ,source2)))) + (set-overflow-branches!) + (LAP (,flags X ,target ,source1 ,source2))) + (LAP (,no-flags X ,target ,source1 ,source2)))) (define ((fixnum-2-args/bitwise op) target source1 source2 overflow?) (assert (not overflow?)) - (LAP (,op ,target ,source1 ,source2))) + (LAP (,op X ,target ,source1 ,source2))) (define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args (fixnum-2-args/additive 'ADDS 'ADD)) @@ -195,9 +184,9 @@ USA. ;; overflow. (LAP (MOVZ X ,mask (&U 0)) (CMP X ,source1 (&U 0)) - (CINV.LT X ,mask ,mask) + (CINV X LT ,mask ,mask) (CMP X ,source2 (&U 0)) - (CINV.LT X ,mask ,mask) + (CINV X LT ,mask ,mask) (ASR X ,regnum:scratch-0 ,source1 (&U ,scheme-type-width)) (SMULH ,hi ,regnum:scratch-0 ,source2) (MUL X ,target ,regnum:scratch-0 ,source2) @@ -227,10 +216,16 @@ USA. ;;;; Fixnum Predicates +(define-rule predicate + (OVERFLOW-TEST) + ;; Preceding RTL instruction is always a fixnum operation with + ;; OVERFLOW? set to true which will generate the right branch. + (LAP)) + (define-rule predicate (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register))) (fixnum-branch! (fixnum-predicate/unary->binary predicate)) - (LAP (CMP X ,(standard-source! register) (& 0)))) + (LAP (CMP X ,(standard-source! register) (&U 0)))) (define-rule predicate (FIXNUM-PRED-1-ARG FIXNUM-ZERO? (REGISTER (? register))) @@ -241,8 +236,8 @@ USA. (REGISTER (? source1)) (REGISTER (? source2))) (fixnum-branch! predicate) - (standard-unary-effect source1 source2 - (lambda () + (standard-binary-effect source1 source2 + (lambda (source1 source2) (LAP (CMP X ,source1 ,source2))))) (define (fixnum-predicate/unary->binary predicate) @@ -257,16 +252,13 @@ USA. ((EQUAL-FIXNUM?) (set-equal-branches!)) ((LESS-THAN-FIXNUM?) - (set-current-branches! (lambda (label) (LAP (B.LT (@PCR ,label)))) - (lambda (label) (LAP (B.GE (@PCR ,label)))))) - ((GREATER-THAN-THAN-FIXNUM?) - (set-current-branches! (lambda (label) (LAP (B.GT (@PCR ,label)))) - (lambda (label) (LAP (B.LE (@PCR ,label)))))) - ((UNSIGNED-LESS-THAN-FIXNUM?) - (set-current-branches! (lambda (label) (LAP (B.MI (@PCR ,label)))) - (lambda (label) (LAP (B.PL (@PCR ,label)))))) + (set-condition-branches! 'LT 'GE)) + ((GREATER-THAN-FIXNUM?) + (set-condition-branches! 'GT 'LE)) ((UNSIGNED-LESS-THAN-FIXNUM?) - (set-current-branches! (lambda (label) (LAP (B.PL (@PCR ,label)))) - (lambda (label) (LAP (B.MI (@PCR ,label)))))) + (set-condition-branches! 'MI 'PL)) + #; ;XXX broken but not sure this ever appears + ((UNSIGNED-GREATER-THAN-FIXNUM?) + (set-condition-branches! 'PL 'MI)) (else (error "Unknown fixnum predicate:" predicate)))) diff --git a/src/compiler/machines/aarch64/rulrew.scm b/src/compiler/machines/aarch64/rulrew.scm index d8d7a9c6c..db7da51d8 100644 --- a/src/compiler/machines/aarch64/rulrew.scm +++ b/src/compiler/machines/aarch64/rulrew.scm @@ -191,6 +191,7 @@ USA. (QUALIFIER (and (rtl:register? operand-1) (rtl:constant-fixnum-test operand-2 (lambda (n) n true)))) (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F)) +|# (define (rtl:constant-fixnum? expression) (and (rtl:constant? expression) @@ -204,4 +205,3 @@ USA. (let ((n (rtl:constant-value expression))) (and (fix:fixnum? n) (predicate n))))))) -|# -- 2.25.1