From 6211375e997a528ba3596366e2f18ef319650db5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 25 Jul 1991 02:46:19 +0000 Subject: [PATCH] Change LAP generator to use new PC-relative address cacheing mechanism. Also eliminate generation of PC-RELATIVE-OFFSET pseudo instruction, and of certain instructions that would make analysis of the LAP difficult. Change LAP to conform more closely to the MIPS spec, e.g. change "FADD DOUBLE" to "ADD.D". Implement simple LAP optimizer that eliminates some NOPs appearing in load delay slots. --- v7/src/compiler/machines/mips/instr1.scm | 509 ++++++++++++---------- v7/src/compiler/machines/mips/instr2a.scm | 107 ++--- v7/src/compiler/machines/mips/instr2b.scm | 62 +-- v7/src/compiler/machines/mips/instr3.scm | 206 ++++++--- v7/src/compiler/machines/mips/lapgen.scm | 217 +++++---- v7/src/compiler/machines/mips/rules1.scm | 54 ++- v7/src/compiler/machines/mips/rules3.scm | 221 ++++++---- v7/src/compiler/machines/mips/rulflo.scm | 59 +-- 8 files changed, 794 insertions(+), 641 deletions(-) diff --git a/v7/src/compiler/machines/mips/instr1.scm b/v7/src/compiler/machines/mips/instr1.scm index 0d64e9e82..5ba346361 100644 --- a/v7/src/compiler/machines/mips/instr1.scm +++ b/v7/src/compiler/machines/mips/instr1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr1.scm,v 1.2 1991/06/17 21:21:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr1.scm,v 1.3 1991/07/25 02:45:51 cph Exp $ Copyright (c) 1987-91 Massachusetts Institute of Technology @@ -39,41 +39,246 @@ MIT in each case. |# (declare (usual-integrations)) -(define-integrable (extract bit-string start end) - (bit-string->unsigned-integer (bit-substring bit-string start end))) +(let-syntax + ((arithmetic-immediate-instruction + (macro (keyword opcode special-opcode) + `(define-instruction ,keyword + (((? destination) (? source) (? immediate)) + (VARIABLE-WIDTH (evaluated-immediate immediate) + ((#x-8000 #x7fff) + (LONG (6 ,opcode) + (5 source) + (5 destination) + (16 evaluated-immediate SIGNED))) + ((#x8000 #xffff) + ;; ORI 1, 0, immediate + ;; reg-op destination, source, 1 + (LONG (6 13) ; ORI + (5 0) + (5 1) + (16 evaluated-immediate) + (6 0) ; reg-op + (5 1) + (5 source) + (5 destination) + (5 0) + (6 ,special-opcode))) + ((() ()) + ;; LUI 1, (top of immediate) + ;; ORI 1, 1, (bottom of immediate) + ;; reg-op destination, source, 1 + (LONG (6 15) ; LUI + (5 0) + (5 1) + (16 (top-16-bits evaluated-immediate)) + (6 13) ; ORI + (5 1) + (5 1) + (16 (bottom-16-bits evaluated-immediate)) + (6 0) ; reg-op + (5 1) + (5 source) + (5 destination) + (5 0) + (6 ,special-opcode))))))))) + (arithmetic-immediate-instruction addi 8 32) + (arithmetic-immediate-instruction addiu 9 33) + (arithmetic-immediate-instruction slti 10 42) + (arithmetic-immediate-instruction sltiu 11 43)) -(define-integrable (extract-signed bit-string start end) - (bit-string->signed-integer (bit-substring bit-string start end))) +(let-syntax + ((unsigned-immediate-instruction + (macro (keyword opcode special-opcode) + `(define-instruction ,keyword + (((? destination) (? source) (? immediate)) + (VARIABLE-WIDTH (evaluated-immediate immediate) + ((0 #xffff) + (LONG (6 ,opcode) + (5 source) + (5 destination) + (16 evaluated-immediate))) + ((() ()) + ;; LUI 1, (top of immediate) + ;; ORI 1, 1, (bottom of immediate) + ;; reg-op destination, source, 1 + (LONG (6 15) ; LUI + (5 0) + (5 1) + (16 (top-16-bits evaluated-immediate)) + (6 13) ; ORI + (5 1) + (5 1) + (16 (bottom-16-bits evaluated-immediate)) + (6 0) ; reg-op + (5 1) + (5 source) + (5 destination) + (5 0) + (6 ,special-opcode))))))))) + (unsigned-immediate-instruction andi 12 36) + (unsigned-immediate-instruction ori 13 37) + (unsigned-immediate-instruction xori 14 38)) + +(define-instruction lui + (((? destination) (? immediate)) + (LONG (6 15) + (5 0) + (5 destination) + (16 immediate)))) +(define-instruction li + (((? destination) (? immediate)) + (VARIABLE-WIDTH (evaluated-immediate immediate) + ((#x-8000 #x7fff) + ;; ADDI destination, 0, immediate + (LONG (6 32) + (5 0) + (5 destination) + (16 evaluated-immediate SIGNED))) + ((#x8000 #xffff) + ;; ORI destination, 0, immediate + (LONG (6 13) + (5 0) + (5 destination) + (16 evaluated-immediate))) + ((() ()) + ;; LUI destination, (top of immediate) + ;; ORI destination, destination, (bottom of immediate) + (LONG (6 15) ; LUI + (5 0) + (5 destination) + (16 (top-16-bits evaluated-immediate)) + (6 13) ; ORI + (5 destination) + (5 destination) + (16 (bottom-16-bits evaluated-immediate))))))) + (let-syntax - ((immediate-instruction + ((3-operand-instruction (macro (keyword opcode) `(define-instruction ,keyword - (((? dest-reg-ii) (? source-reg-ii) (? immediate)) - (LONG (6 ,opcode) - (5 source-reg-ii) - (5 dest-reg-ii) - (16 immediate SIGNED)))))) - (unsigned-immediate-instruction + (((? destination) (? source-1) (? source-2)) + (LONG (6 0) + (5 source-1) + (5 source-2) + (5 destination) + (5 0) + (6 ,opcode))))))) + (3-operand-instruction add 32) + (3-operand-instruction addu 33) + (3-operand-instruction sub 34) + (3-operand-instruction subu 35) + (3-operand-instruction and 36) + (3-operand-instruction or 37) + (3-operand-instruction xor 38) + (3-operand-instruction nor 39) + (3-operand-instruction slt 42) + (3-operand-instruction sltu 43)) + +(let-syntax + ((shift-instruction (macro (keyword opcode) `(define-instruction ,keyword - (((? dest-reg-uii) (? source-reg-uii) (? uimmediate)) - (LONG (6 ,opcode) - (5 source-reg-uii) - (5 dest-reg-uii) - (16 uimmediate)))))) + (((? destination) (? source) (? amount)) + (LONG (6 0) + (5 0) + (5 source) + (5 destination) + (5 amount) + (6 ,opcode))))))) + (shift-instruction sll 0) + (shift-instruction srl 2) + (shift-instruction sra 3)) - (special-instruction - (macro (keyword special-op) +(let-syntax + ((shift-variable-instruction + (macro (keyword opcode) `(define-instruction ,keyword - (((? dest-sp) (? reg-1-sp) (? reg-2-sp)) + (((? destination) (? source) (? amount)) (LONG (6 0) - (5 reg-1-sp) - (5 reg-2-sp) - (5 dest-sp) + (5 amount) + (5 source) + (5 destination) (5 0) - (6 ,special-op)))))) - (move-coprocessor-instruction + (6 ,opcode))))))) + (shift-variable-instruction sllv 4) + (shift-variable-instruction srlv 6) + (shift-variable-instruction srav 7)) + +(let-syntax + ((div/mul-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? source-1) (? source-2)) + (LONG (6 0) + (5 source-1) + (5 source-2) + (5 0) + (5 0) + (6 ,opcode))))))) + (div/mul-instruction div 26) + (div/mul-instruction divu 27) + (div/mul-instruction mult 24) + (div/mul-instruction multu 25)) + +(let-syntax + ((from-hi/lo-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? destination)) + (LONG (6 0) + (5 0) + (5 0) + (5 destination) + (5 0) + (6 ,opcode))))))) + (from-hi/lo-instruction mfhi 16) + (from-hi/lo-instruction mflo 18)) +#| +(let-syntax + ((to-hi/lo-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? source)) + (LONG (6 0) + (5 source) + (5 0) + (5 0) + (5 0) + (6 ,opcode))))))) + (to-hi/lo-instruction mthi 17) + (to-hi/lo-instruction mtlo 19)) + +(let-syntax + ((jump-instruction + (macro (keyword opcode) + `(define-instruction ,keyword + (((? address)) + (LONG (6 ,opcode) + (26 (quotient address 2)))))))) + (jump-instruction j 2) + (jump-instruction jal 3)) +|# +(define-instruction jalr + (((? destination) (? source)) + (LONG (6 0) + (5 source) + (5 0) + (5 destination) + (5 0) + (6 9)))) + +(define-instruction jr + (((? source)) + (LONG (6 0) + (5 source) + (5 0) + (5 0) + (5 0) + (6 8)))) + +(let-syntax + ((move-coprocessor-instruction (macro (keyword opcode move-op) `(define-instruction ,keyword (((? rt-mci) (? rd-mci)) @@ -81,240 +286,76 @@ MIT in each case. |# (5 ,move-op) (5 rt-mci) (5 rd-mci) - (11 0)))))) - (coprocessor-instruction + (11 0))))))) + ;; (move-coprocessor-instruction mfc0 16 #x000) + (move-coprocessor-instruction mfc1 17 #x000) + ;; (move-coprocessor-instruction mfc2 18 #x000) + ;; (move-coprocessor-instruction mfc3 19 #x000) + ;; (move-coprocessor-instruction cfc0 16 #x002) + (move-coprocessor-instruction cfc1 17 #x002) + ;; (move-coprocessor-instruction cfc2 18 #x002) + ;; (move-coprocessor-instruction cfc3 19 #x002) + ;; (move-coprocessor-instruction mtc0 16 #x004) + (move-coprocessor-instruction mtc1 17 #x004) + ;; (move-coprocessor-instruction mtc2 18 #x004) + ;; (move-coprocessor-instruction mtc3 19 #x004) + ;; (move-coprocessor-instruction ctc0 16 #x006) + (move-coprocessor-instruction ctc1 17 #x006) + ;; (move-coprocessor-instruction ctc2 18 #x006) + ;; (move-coprocessor-instruction ctc3 19 #x006) + ) +#| +(let-syntax + ((coprocessor-instruction (macro (keyword opcode) `(define-instruction ,keyword (((? cofun)) (LONG (6 ,opcode) (1 1) ; CO bit - (25 cofun)))))) - (div/mul-instruction - (macro (keyword funct) - `(define-instruction ,keyword - (((? rs-dm) (? rt-dm)) - (LONG (6 0) - (5 rs-dm) - (5 rt-dm) - (10 0) - (6 ,funct)))))) - (jump-instruction - (macro (keyword opcode) - `(define-instruction ,keyword - (((? dest-j)) - (LONG (6 ,opcode) - (26 dest-j)))))) + (25 cofun))))))) + (coprocessor-instruction cop0 16) + (coprocessor-instruction cop1 17) + (coprocessor-instruction cop2 18) + (coprocessor-instruction cop3 19)) - (from-hi/lo-instruction - (macro (keyword funct) - `(define-instruction ,keyword - (((? rd-fhl)) - (LONG (6 0) - (10 0) - (5 rd-fhl) - (5 0) - (6 ,funct)))))) - (to-hi/lo-instruction - (macro (keyword funct) - `(define-instruction ,keyword - (((? rd-thl)) - (LONG (6 0) - (5 rd-thl) - (15 0) - (6 ,funct)))))) - (cop0-instruction +(let-syntax + ((cop0-instruction (macro (keyword cp0-op) `(define-instruction ,keyword (() (LONG (6 16) (1 1) ; CO (20 0) - (5 ,cp0-op)))))) - (shift-instruction - (macro (keyword funct) - `(define-instruction ,keyword - (((? dest-sh) (? source-sh) (? amount)) - (LONG (6 0) - (5 0) - (5 source-sh) - (5 dest-sh) - (5 amount) - (6 ,funct)))))) - (shift-variable-instruction - (macro (keyword funct) - `(define-instruction ,keyword - (((? dest-sv) (? source-sv) (? amount-reg)) - (LONG (6 0) - (5 amount-reg) - (5 source-sv) - (5 dest-sv) - (5 0) - (6 ,funct))))))) - (special-instruction add 32) - (immediate-instruction addi 8) - (immediate-instruction addiu 9) - (special-instruction addu 33) - (special-instruction and 36) - (unsigned-immediate-instruction andi 12) - (define-instruction break - (((? code)) - (LONG (6 0) (20 code) (6 13)))) - (move-coprocessor-instruction cfc0 16 #x002) - (move-coprocessor-instruction cfc1 17 #x002) - (move-coprocessor-instruction cfc2 18 #x002) - (move-coprocessor-instruction cfc3 19 #x002) - (coprocessor-instruction cop0 16) - (coprocessor-instruction cop1 17) - (coprocessor-instruction cop2 18) - (coprocessor-instruction cop3 19) - (move-coprocessor-instruction ctc0 16 #x006) - (move-coprocessor-instruction ctc1 17 #x006) - (move-coprocessor-instruction ctc2 18 #x006) - (move-coprocessor-instruction ctc3 19 #x006) - (div/mul-instruction div 26) - (div/mul-instruction divu 27) - (jump-instruction j 2) - (jump-instruction jal 3) - (define-instruction jalr - (((? rd-jalr) (? rs-jalr)) - (LONG (6 0) (5 rs-jalr) (5 0) (5 rd-jalr) (5 0) (6 9)))) - (define-instruction jr - (((? rs-jr)) - (LONG (6 0) (5 rs-jr) (15 0) (6 8)))) - (define-instruction lui - (((? dest-lui) (? immediate-lui)) - (LONG (6 15) (5 0) (5 dest-lui) (16 immediate-lui)))) - (move-coprocessor-instruction mfc0 16 #x000) - (move-coprocessor-instruction mfc1 17 #x000) - (move-coprocessor-instruction mfc2 18 #x000) - (move-coprocessor-instruction mfc3 19 #x000) - (from-hi/lo-instruction mfhi 16) - (from-hi/lo-instruction mflo 18) - (move-coprocessor-instruction mtc0 16 #x004) - (move-coprocessor-instruction mtc1 17 #x004) - (move-coprocessor-instruction mtc2 18 #x004) - (move-coprocessor-instruction mtc3 19 #x004) - (to-hi/lo-instruction mthi 17) - (to-hi/lo-instruction mtlo 19) - (div/mul-instruction mult 24) - (div/mul-instruction multu 25) - (special-instruction nor 39) - (special-instruction or 37) - (unsigned-immediate-instruction ori 13) + (5 ,cp0-op))))))) (cop0-instruction rfe 16) - (shift-instruction sll 0) - (shift-variable-instruction sllv 4) - (special-instruction slt 42) - (immediate-instruction slti 10) - (immediate-instruction sltiu 11) - (special-instruction sltu 43) - (shift-instruction sra 3) - (shift-variable-instruction srav 7) - (shift-instruction srl 2) - (shift-variable-instruction srlv 6) - (special-instruction sub 34) - (special-instruction subu 35) - (define-instruction syscall - (() - (LONG (6 0) (20 0) (6 12)))) (cop0-instruction tlbp 8) (cop0-instruction tlbr 1) (cop0-instruction tlbwi 2) - (cop0-instruction tlbwr 6) - (special-instruction xor 38) - (unsigned-immediate-instruction xori 14)) + (cop0-instruction tlbwr 6)) -;;;; Assembler pseudo-ops - -(define-instruction WORD - (((? expression)) - (LONG (32 expression SIGNED)))) +(define-instruction syscall + (() + (LONG (6 0) (20 0) (6 12)))) -(define-instruction UWORD - (((? expression)) - (LONG (32 expression UNSIGNED)))) +(define-instruction break + (((? code)) + (LONG (6 0) (20 code) (6 13)))) +|# + +;;;; Assembler pseudo-ops -; External labels cause the output of GC header and format words (define-instruction EXTERNAL-LABEL + ;; External labels provide the garbage collector with header + ;; information and the runtime system with type, arity, and + ;; debugging information. (((? format-word) (@PCR (? label))) (if (eq? endianness 'LITTLE) (LONG (16 label BLOCK-OFFSET) (16 format-word UNSIGNED)) (LONG (16 format-word UNSIGNED) - (16 label BLOCK-OFFSET)))) - - (((? format-word) (@PCO (? offset))) - (if (eq? endianness 'LITTLE) - (LONG (16 offset UNSIGNED) - (16 format-word UNSIGNED)) - (LONG (16 format-word UNSIGNED) - (16 offset UNSIGNED))))) - -(define-instruction PC-RELATIVE-OFFSET - (((? target) (@PCR (? label))) - (VARIABLE-WIDTH (offset `(- ,label (+ *PC* 8))) - ((#x-8000 #x7FFF) - ; BGEZAL 0 X *PC* is here - ; ADDI target, 31, offset - ; X: ... - (LONG (6 1) ; BGEZAL - (5 0) - (5 17) - (16 1) - (6 8) ; ADDI - (5 31) - (5 target) - (16 offset SIGNED))) - ((() ()) - ; BGEZAL 0 X *PC* is here - ; ADDIU target, 31, (right of offset) - ; X: LUI 1, (left_adjust of offset) - ; ADD target, target, 1 - (LONG (6 1) ; BGEZAL - (5 0) - (5 17) - (16 1) - (6 9) ; ADDIU - (5 31) - (5 target) - (16 (adjusted:low offset) SIGNED) - (6 15) ; LUI - (5 0) - (5 1) - (16 (adjusted:high offset)) - (6 0) ; ADD - (5 1) - (5 target) - (5 target) - (5 0) - (6 32))))) - (((? target) (? offset) (? label)) - ; Load (into target) distance from here+offset to label - (VARIABLE-WIDTH (offset `(- ,label (+ ,offset *PC*))) - ((#x-8000 #x7FFF) - ; ADDI target, 0, offset - (LONG (6 8) ; ADDI - (5 0) - (5 target) - (16 offset SIGNED))) - ((#x8000 #xFFFF) - ; ORI target, 0, offset - (LONG (6 13) ; ORI - (5 0) - (5 target) - (16 offset))) - ((() ()) - ; LUI target, (left_adjust of offset) - ; ADDIU target, target, (right of offset) - (LONG (6 15) ; LUI - (5 0) - (5 target) - (16 (adjusted:high (- offset 4))) - (6 9) ; ADDIU - (5 target) - (5 target) - (16 (adjusted:low (- offset 4)) SIGNED)))))) + (16 label BLOCK-OFFSET))))) (define-instruction NOP - (() ; ADDI 0, 0 + ;; ADDI 0, 0 + (() (LONG (6 8) (5 0) (5 0) (16 0)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/instr2a.scm b/v7/src/compiler/machines/mips/instr2a.scm index 6ad7542ca..62c087520 100644 --- a/v7/src/compiler/machines/mips/instr2a.scm +++ b/v7/src/compiler/machines/mips/instr2a.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr2a.scm,v 1.3 1991/06/17 21:21:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr2a.scm,v 1.4 1991/07/25 02:45:56 cph Exp $ -Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -42,23 +42,23 @@ MIT in each case. |# ((branch (macro (keyword match-phrase forward reverse) `(define-instruction ,keyword - ((,@match-phrase (@PCO (? branch-dest-pco))) - (VARIABLE-WIDTH (offset (/ branch-dest-pco 4)) - ((#x-8000 #x7fff) (LONG ,@forward (16 offset signed))) - ((() ()) (LONG (32 "Can't branch tension @PCO operands"))))) - ((,@match-phrase (@PCR (? branch-dest-pcr))) - (VARIABLE-WIDTH (offset `(/ (- ,branch-dest-pcr (+ *PC* 4)) 4)) - ((#x-8000 #x7fff) (LONG ,@forward (16 offset signed))) + ((,@match-phrase (@PCO (? offset))) + (LONG ,@forward + (16 (quotient offset 4) SIGNED))) + ((,@match-phrase (@PCR (? label))) + (VARIABLE-WIDTH (offset `(/ (- ,label (+ *PC* 4)) 4)) + ((#x-8000 #x7fff) + (LONG ,@forward (16 offset SIGNED))) ((() ()) ;; xxx - ;; LUI $1,left_adj(branch-dest - 16) - ;; BGEZAL $0,yyy - ;; ADDIU $1,$1,right(branch-dest - 16) - ;; yyy: ADD $1,$1,$31 + ;; LUI $1, left_adj(offset*4 - 12) + ;; BGEZAL $0, yyy + ;; ADDIU $1, $1, right(offset*4 - 12) + ;; yyy: ADD $1, $1, $31 ;; JR $1 - ;; ADD $0,$0,$0 ;; xxx: - (LONG ,@reverse (16 6) ; reverse branch to (.+1)+6 + (LONG ,@reverse ; reverse branch to (.+1)+5 + (16 5) (6 15) ; LUI (5 0) (5 1) @@ -80,42 +80,45 @@ MIT in each case. |# (6 0) ; JR (5 1) (15 0) - (6 8) - (6 0) ; ADD - (5 0) - (5 0) - (5 0) - (5 0) - (6 32))))))))) - (branch bc0f () ((6 16) (10 #x100)) ((6 16) (10 #x101))) + (6 8))))))))) + (branch beq + ((? reg1) (? reg2)) + ((6 4) (5 reg1) (5 reg2)) + ((6 5) (5 reg1) (5 reg2))) + (branch bne + ((? reg1) (? reg2)) + ((6 5) (5 reg1) (5 reg2)) + ((6 4) (5 reg1) (5 reg2))) + (branch bgez + ((? reg)) + ((6 1) (5 reg) (5 1)) + ((6 1) (5 reg) (5 0))) + (branch bgtz + ((? reg)) + ((6 7) (5 reg) (5 0)) + ((6 6) (5 reg) (5 0))) + (branch blez + ((? reg)) + ((6 6) (5 reg) (5 0)) + ((6 7) (5 reg) (5 0))) + (branch bltz + ((? reg)) + ((6 1) (5 reg) (5 0)) + ((6 1) (5 reg) (5 1))) + (branch bgezal + ((? reg)) + ((6 1) (5 reg) (5 17)) + ((16 "can't branch tension a bgezal instruction"))) + (branch bltzal + ((? reg)) + ((6 1) (5 reg) (5 16)) + ((16 "can't branch tension a bltzal instruction"))) + ;; (branch bc0f () ((6 16) (10 #x100)) ((6 16) (10 #x101))) (branch bc1f () ((6 17) (10 #x100)) ((6 17) (10 #x101))) - (branch bc2f () ((6 18) (10 #x100)) ((6 18) (10 #x101))) - (branch bc3f () ((6 19) (10 #x100)) ((6 19) (10 #x101))) - (branch bc0t () ((6 16) (10 #x101)) ((6 16) (10 #x100))) + ;; (branch bc2f () ((6 18) (10 #x100)) ((6 18) (10 #x101))) + ;; (branch bc3f () ((6 19) (10 #x100)) ((6 19) (10 #x101))) + ;; (branch bc0t () ((6 16) (10 #x101)) ((6 16) (10 #x100))) (branch bc1t () ((6 17) (10 #x101)) ((6 17) (10 #x100))) - (branch bc2t () ((6 18) (10 #x101)) ((6 18) (10 #x100))) - (branch bc3t () ((6 19) (10 #x101)) ((6 19) (10 #x100))) - (branch beq ((? reg1) (? reg2)) - ((6 4) (5 reg1) (5 reg2)) - ((6 5) (5 reg1) (5 reg2))) - (branch bgez ((? reg)) - ((6 1) (5 reg) (5 1)) - ((6 1) (5 reg) (5 0))) - (branch bgezal ((? reg)) - ((6 1) (5 reg) (5 17)) - ((16 "can't branch tension a bgezal instruction"))) - (branch bgtz ((? reg)) - ((6 7) (5 reg) (5 0)) - ((6 6) (5 reg) (5 0))) - (branch blez ((? reg)) - ((6 6) (5 reg) (5 0)) - ((6 7) (5 reg) (5 0))) - (branch bltz ((? reg)) - ((6 1) (5 reg) (5 0)) - ((6 1) (5 reg) (5 1))) - (branch bltzal ((? reg)) - ((6 1) (5 reg) (5 16)) - ((16 "can't branch tension a bltzal instruction"))) - (branch bne ((? reg1) (? reg2)) - ((6 5) (5 reg1) (5 reg2)) - ((6 4) (5 reg1) (5 reg2)))) \ No newline at end of file + ;; (branch bc2t () ((6 18) (10 #x101)) ((6 18) (10 #x100))) + ;; (branch bc3t () ((6 19) (10 #x101)) ((6 19) (10 #x100))) + ) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/instr2b.scm b/v7/src/compiler/machines/mips/instr2b.scm index 580369d39..90716633f 100644 --- a/v7/src/compiler/machines/mips/instr2b.scm +++ b/v7/src/compiler/machines/mips/instr2b.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr2b.scm,v 1.2 1991/07/21 07:41:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr2b.scm,v 1.3 1991/07/25 02:45:59 cph Exp $ Copyright (c) 1987-91 Massachusetts Institute of Technology @@ -51,7 +51,7 @@ MIT in each case. |# (16 delta SIGNED))) ((() ()) ;; LUI 1,adjusted-left - ;; ADDU 1,1,base-reg + ;; ADDU 1,1,base-reg ;; LW source/dest-reg,right(1) (LONG (6 15) ; LUI (5 0) @@ -66,61 +66,25 @@ MIT in each case. |# (6 ,opcode); LW (5 1) (5 source/dest-reg) - (16 (adjusted:low delta) SIGNED))))) - (((? source/dest-reg) (@PCR (? label))) - (VARIABLE-WIDTH (delta `(- ,label (+ *PC* 8))) - ((#x-8000 #x7fff) - ; BGEZAL 0,X - ; LW source/dest-reg,delta(31) - ; X: - (LONG (6 1) ; BGEZAL - (5 0) - (5 17) - (16 1) - (6 ,opcode) ; LW - (5 31) - (5 source/dest-reg) - (16 delta))) - ((() ()) - ; BGEZAL 0,X - ; LUI 1,upper-half-adjusted - ; X: ADDU 1,31,1 - ; LW source/dest-reg,lower-half(1) - (LONG (6 1) ; BGEZAL - (5 0) - (5 17) - (16 1) - (6 15) ; LUI - (5 0) - (5 1) - (16 (adjusted:high delta)) - (6 0) ; ADDU - (5 1) - (5 31) - (5 1) - (5 0) - (6 33) - (6 ,opcode) ; LW - (5 1) - (5 source/dest-reg) (16 (adjusted:low delta) SIGNED))))))))) (load/store-instruction lb 32) (load/store-instruction lbu 36) (load/store-instruction lh 33) (load/store-instruction lhu 37) (load/store-instruction lw 35) - (load/store-instruction lwc0 48) + ;; (load/store-instruction lwc0 48) (load/store-instruction lwc1 49) - (load/store-instruction lwc2 50) - (load/store-instruction lwc3 51) - (load/store-instruction lwl 34) - (load/store-instruction lwr 38) + ;; (load/store-instruction lwc2 50) + ;; (load/store-instruction lwc3 51) + ;; (load/store-instruction lwl 34) + ;; (load/store-instruction lwr 38) (load/store-instruction sb 40) (load/store-instruction sh 41) (load/store-instruction sw 43) - (load/store-instruction swc0 56) + ;; (load/store-instruction swc0 56) (load/store-instruction swc1 57) - (load/store-instruction swc2 58) - (load/store-instruction swc3 59) - (load/store-instruction swl 42) - (load/store-instruction swr 46)) + ;; (load/store-instruction swc2 58) + ;; (load/store-instruction swc3 59) + ;; (load/store-instruction swl 42) + ;; (load/store-instruction swr 46) + ) diff --git a/v7/src/compiler/machines/mips/instr3.scm b/v7/src/compiler/machines/mips/instr3.scm index 69c1a0f05..2294bec71 100644 --- a/v7/src/compiler/machines/mips/instr3.scm +++ b/v7/src/compiler/machines/mips/instr3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr3.scm,v 1.1 1990/05/07 04:14:47 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/instr3.scm,v 1.2 1991/07/25 02:46:03 cph Exp $ -Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1987-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,79 +33,146 @@ promotional, or sales literature without prior written consent from MIT in each case. |# ;;;; MIPS instruction set, part 3 +;;; Floating point co-processor (R2010) (declare (usual-integrations)) -;;;; Floating point co-processor (R2010) - + (let-syntax ((three-reg (macro (keyword function-code) - `(define-instruction ,keyword - ((SINGLE (? fd) (? fs) (? ft)) - (LONG (6 17) - (1 1) - (4 0) ; single precision - (5 ft) - (5 fs) - (5 fd) - (6 ,function-code))) - ((DOUBLE (? fd) (? fs) (? ft)) - (LONG (6 17) - (1 1) - (4 1) ; double precision - (5 ft) - (5 fs) - (5 fd) - (6 ,function-code)))))) - (two-reg + `(BEGIN + (DEFINE-INSTRUCTION ,(symbol-append keyword '.S) + (((? fd) (? fs) (? ft)) + (LONG (6 17) + (1 1) + (4 0) ; single precision + (5 ft) + (5 fs) + (5 fd) + (6 ,function-code)))) + (DEFINE-INSTRUCTION ,(symbol-append keyword '.D) + (((? fd) (? fs) (? ft)) + (LONG (6 17) + (1 1) + (4 1) ; double precision + (5 ft) + (5 fs) + (5 fd) + (6 ,function-code)))))))) + + (three-reg add 0) + (three-reg sub 1) + (three-reg mul 2) + (three-reg div 3)) + +(let-syntax + ((two-reg (macro (keyword function-code) - `(define-instruction ,keyword - ((SINGLE (? fd) (? fs)) - (LONG (6 17) - (1 1) - (4 0) ; single precision - (5 0) - (5 fs) - (5 fd) - (6 ,function-code))) - ((DOUBLE (? fd) (? fs)) - (LONG (6 17) - (1 1) - (4 1) ; double precision - (5 0) - (5 fs) - (5 fd) - (6 ,function-code)))))) - (compare + `(BEGIN + (DEFINE-INSTRUCTION ,(symbol-append keyword '.S) + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 0) ; single precision + (5 0) + (5 fs) + (5 fd) + (6 ,function-code)))) + (DEFINE-INSTRUCTION ,(symbol-append keyword '.D) + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 1) ; double precision + (5 0) + (5 fs) + (5 fd) + (6 ,function-code)))))))) + (two-reg abs 5) + (two-reg mov 6) + (two-reg neg 7)) + +(define-instruction cvt.d.s + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 0) + (5 0) + (5 fs) + (5 fd) + (6 33)))) + +(define-instruction cvt.d.w + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 4) + (5 0) + (5 fs) + (5 fd) + (6 33)))) + +(define-instruction cvt.s.d + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 1) + (5 0) + (5 fs) + (5 fd) + (6 32)))) + +(define-instruction cvt.s.w + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 4) + (5 0) + (5 fs) + (5 fd) + (6 32)))) + +(define-instruction cvt.w.d + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 1) + (5 0) + (5 fs) + (5 fd) + (6 36)))) + +(define-instruction cvt.w.s + (((? fd) (? fs)) + (LONG (6 17) + (1 1) + (4 0) + (5 0) + (5 fs) + (5 fd) + (6 36)))) + +(let-syntax + ((compare (macro (keyword conditions) - `(define-instruction ,keyword - ((SINGLE (? fs) (? ft)) - (LONG (6 17) - (1 1) - (4 0) ; single precision - (5 ft) - (5 fs) - (5 0) - (6 ,conditions))) - ((DOUBLE (? fs) (? ft)) - (LONG (6 17) - (1 1) - (4 1) ; double precision - (5 ft) - (5 fs) - (5 0) - (6 ,conditions))))))) - - (three-reg fadd 0) - (three-reg fsub 1) - (three-reg fmul 2) - (three-reg fdiv 3) - (two-reg fabs 5) - (two-reg fmov 6) - (two-reg fneg 7) - (two-reg cvt.s 32) - (two-reg cvt.d 33) - (two-reg cvt.w 36) + `(BEGIN + (DEFINE-INSTRUCTION ,(symbol-append keyword '.S) + (((? fs) (? ft)) + (LONG (6 17) + (1 1) + (4 0) + (5 ft) + (5 fs) + (5 0) + (6 ,conditions)))) + (DEFINE-INSTRUCTION ,(symbol-append keyword '.D) + (((? fs) (? ft)) + (LONG (6 17) + (1 1) + (4 1) + (5 ft) + (5 fs) + (5 0) + (6 ,conditions)))))))) (compare c.f 48) (compare c.un 49) (compare c.eq 50) @@ -121,5 +188,4 @@ MIT in each case. |# (compare c.lt 60) (compare c.nge 61) (compare c.le 62) - (compare c.ngt 63)) - + (compare c.ngt 63)) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/lapgen.scm b/v7/src/compiler/machines/mips/lapgen.scm index ede66565a..565021cf4 100644 --- a/v7/src/compiler/machines/mips/lapgen.scm +++ b/v7/src/compiler/machines/mips/lapgen.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.4 1991/06/17 21:21:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/lapgen.scm,v 1.5 1991/07/25 02:46:06 cph Exp $ $MC68020-Header: lapgen.scm,v 4.26 90/01/18 22:43:36 GMT cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -143,8 +143,7 @@ MIT in each case. |# (define (memory->register-transfer offset base target) (case (register-type target) - ((GENERAL) (LAP (LW ,target (OFFSET ,offset ,base)) - (NOP))) + ((GENERAL) (LAP (LW ,target (OFFSET ,offset ,base)) (NOP))) ((FLOAT) (fp-load-doubleword offset base target #T)) (else (error "unknown register type" target)))) @@ -159,8 +158,10 @@ MIT in each case. |# (let ((delay-slot? (and (not (default-object? delay-slot?)) delay-slot?))) (if (non-pointer-object? constant) (load-immediate (non-pointer->literal constant) target) - (LAP ,@(load-pc-relative (constant->label constant) target) - ,@(if delay-slot? '((NOP)) '()))))) + (LAP ,@(load-pc-relative target + 'CONSTANT + (constant->label constant) + delay-slot?))))) (define (load-non-pointer type datum target) ;; Load a Scheme non-pointer constant, defined by type and datum, @@ -188,58 +189,60 @@ MIT in each case. |# ;;;; Regularized Machine Instructions -(define (copy r t) - (if (= r t) - (LAP) - (LAP (ADD ,t 0 ,r)))) +(define (adjusted:high n) + (let ((n (->unsigned n))) + (if (< (remainder n #x10000) #x8000) + (quotient n #x10000) + (+ (quotient n #x10000) 1)))) + +(define-integrable (adjusted:low n) + (remainder (->unsigned n) #x10000)) + +(define-integrable (top-16-bits n) + (quotient (->unsigned n) #x10000)) + +(define-integrable (bottom-16-bits n) + (remainder (->unsigned n) #x10000)) -(define-integrable (long->bits long) - ((if (negative? long) - signed-integer->bit-string - unsigned-integer->bit-string) 32 long)) +(define (->unsigned n) + (if (negative? n) (- #x100000000 n) n)) -(define (adjusted:high long) - (let ((n (long->bits long))) - (+ (extract n 16 32) - (if (> (extract n 0 16) #x7FFF) - 1 0)))) +(define-integrable (fits-in-16-bits-signed? value) + (<= #x-8000 value #x7fff)) -(define (adjusted:low long) - (extract-signed (long->bits long) 0 16)) +(define-integrable (fits-in-16-bits-unsigned? value) + (<= #x0 value #xffff)) -(define (top-16-bits long) - (extract (long->bits long) 16 32)) +(define-integrable (top-16-bits-only? value) + (zero? (bottom-16-bits value))) + +(define (copy r t) + (if (= r t) + (LAP) + (LAP (ADD ,t 0 ,r)))) (define (add-immediate value source dest) - (cond - ((fits-in-16-bits-signed? value) - (LAP (ADDI ,dest ,source ,value))) - ((top-16-bits-only? value) - (LAP (LUI ,regnum:assembler-temp ,(top-16-bits value)) - (ADD ,dest ,regnum:assembler-temp ,source))) - (else - (LAP (ADDIU ,dest ,source ,(adjusted:low value)) - (LUI ,regnum:assembler-temp ,(adjusted:high value)) - (ADD ,dest ,dest ,regnum:assembler-temp))))) + (if (fits-in-16-bits-signed? value) + (LAP (ADDI ,dest ,source ,value)) + (LAP ,@(load-immediate value regnum:assembler-temp) + (ADD ,dest ,regnum:assembler-temp ,source)))) (define (load-immediate value dest) - (cond - ((fits-in-16-bits-signed? value) - (LAP (ADDI ,dest 0 ,value))) - ((top-16-bits-only? value) - (LAP (LUI ,dest ,(top-16-bits value)))) - ((fits-in-16-bits-unsigned? value) - (LAP (ORI ,dest 0 ,value))) - (else - (LAP - (LUI ,regnum:assembler-temp ,(adjusted:high value)) - (ADDIU ,dest ,regnum:assembler-temp ,(adjusted:low value)))))) - + (cond ((fits-in-16-bits-signed? value) + (LAP (ADDI ,dest 0 ,value))) + ((fits-in-16-bits-unsigned? value) + (LAP (ORI ,dest 0 ,value))) + ((top-16-bits-only? value) + (LAP (LUI ,dest ,(top-16-bits value)))) + (else + (LAP (LUI ,regnum:assembler-temp ,(adjusted:high value)) + (ADDIU ,dest ,regnum:assembler-temp ,(adjusted:low value)))))) + (define (fp-copy from to) (if (= to from) (LAP) - (LAP (FMOV DOUBLE ,(float-register->fpr to) - ,(float-register->fpr from))))) + (LAP (MOV.D ,(float-register->fpr to) + ,(float-register->fpr from))))) ;; Handled by VARIABLE-WIDTH in instr1.scm @@ -262,29 +265,80 @@ MIT in each case. |# (SWC1 ,most (OFFSET ,(+ offset 4) ,base))) (LAP (SWC1 ,least (OFFSET ,(+ offset 4) ,base)) (SWC1 ,most (OFFSET ,offset ,base)))))) + +;;;; PC-relative addresses -(define (load-pc-relative label target) +(define (load-pc-relative target type label delay-slot?) ;; Load a pc-relative location's contents into a machine register. - (LAP (LW ,target (@PCR ,label)))) - -(define (load-pc-relative-address label target) + ;; Optimization: if there is a register that contains the value of + ;; another label, use that register as the base register. + ;; Otherwise, allocate a temporary and load it with the value of the + ;; label, then use the temporary as the base register. This + ;; strategy of loading a temporary wins if the temporary is used + ;; again, but loses if it isn't, since loading the temporary takes + ;; two instructions in addition to the LW instruction, while doing a + ;; pc-relative LW instruction takes only two instructions total. + ;; But pc-relative loads of various kinds are quite common, so this + ;; should almost always be advantageous. + (with-values (lambda () (get-typed-label type)) + (lambda (label* alias) + (if label* + (LAP (LW ,target (OFFSET (- ,label ,label*) ,alias)) + ,@(if delay-slot? (LAP (NOP)) (LAP))) + (let ((temporary (standard-temporary!))) + (set-typed-label! type label temporary) + (LAP ,@(%load-pc-relative-address temporary label) + (LW ,target (OFFSET 0 ,temporary)) + ,@(if delay-slot? (LAP (NOP)) (LAP)))))))) + +(define (load-pc-relative-address target type label) ;; Load address of a pc-relative location into a machine register. - (LAP (PC-RELATIVE-OFFSET ,target (@PCR ,label)))) + ;; Optimization: if there is another register that contains the + ;; value of another label, add the difference between the labels to + ;; that register's contents instead. The ADDI takes one + ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so + ;; this is always advantageous. + (let ((instructions + (with-values (lambda () (get-typed-label type)) + (lambda (label* alias) + (if label* + (LAP (ADDI ,target ,alias (- ,label ,label*))) + (%load-pc-relative-address target label)))))) + (set-typed-label! type label target) + instructions)) + +(define (%load-pc-relative-address target label) + (let ((label* (generate-label))) + (LAP (BGEZAL 0 (@PCO 4)) + (LABEL ,label*) + (ADDI ,target 31 (- ,label (+ ,label* 4)))))) + +;;; Typed labels provide further optimization. There are two types, +;;; CODE and CONSTANT, that say whether the label is located in the +;;; code block or the constants block of the output. Statistically, +;;; a label is likely to be closer to another label of the same type +;;; than to a label of the other type. + +(define (get-typed-label type) + (let ((entries (register-map-labels *register-map* 'GENERAL))) + (let loop ((entries* entries)) + (cond ((null? entries*) + ;; If no entries of the given type, use any entry that is + ;; available. + (if (null? entries) + (values false false) + (values (cdaar entries) (cadar entries)))) + ((eq? type (caaar entries*)) + (values (cdaar entries*) (cadar entries*))) + (else + (loop (cdr entries*))))))) + +(define (set-typed-label! type label alias) + (set! *register-map* + (set-machine-register-label *register-map* alias (cons type label))) + unspecific) -(define (branch-generator! cc = < > <> >= <=) - (let ((forward - (case cc - ((=) =) ((<) <) ((>) >) - ((<>) <>) ((>=) >=) ((<=) <=))) - (inverse - (case cc - ((=) <>) ((<) >=) ((>) <=) - ((<>) =) ((>=) <) ((<=) >)))) - (set-current-branches! - (lambda (label) - (LAP (,@forward (@PCR ,label)) (NOP))) - (lambda (label) - (LAP (,@inverse (@PCR ,label)) (NOP)))))) +;;;; Comparisons (define (compare-immediate comp i r2) ; Branch if immediate r2 @@ -298,7 +352,10 @@ MIT in each case. |# `(BNE 0 ,r2) `(BGEZ ,r2) `(BLEZ ,r2)) (LAP)) (let ((temp (standard-temporary!))) - (if (fits-in-16-bits-signed? i) + (if (fits-in-16-bits-signed? + (if (or (eq? '> cc) (eq? '<= cc)) + (+ i 1) + i)) (begin (branch-generator! cc `(BEQ ,temp ,r2) `(BNE 0 ,temp) `(BEQ 0 ,temp) @@ -322,8 +379,21 @@ MIT in each case. |# ((= <>) (LAP)) ((< >=) (LAP (SLT ,temp ,r1 ,r2))) ((> <=) (LAP (SLT ,temp ,r2 ,r1)))))) - -;;;; Conditions + +(define (branch-generator! cc = < > <> >= <=) + (let ((forward + (case cc + ((=) =) ((<) <) ((>) >) + ((<>) <>) ((>=) >=) ((<=) <=))) + (inverse + (case cc + ((=) <>) ((<) >=) ((>) <=) + ((<>) =) ((>=) <) ((<=) >)))) + (set-current-branches! + (lambda (label) + (LAP (,@forward (@PCR ,label)) (NOP))) + (lambda (label) + (LAP (,@inverse (@PCR ,label)) (NOP)))))) (define (invert-condition condition) (let ((place (assq condition condition-inversion-table))) @@ -422,15 +492,6 @@ MIT in each case. |# (cdr (or (assq operator (cdr methods)) (error "Unknown operator" operator)))) -(define (fits-in-16-bits-signed? value) - (<= #x-8000 value #x7FFF)) - -(define (fits-in-16-bits-unsigned? value) - (<= #x0 value #xFFFF)) - -(define (top-16-bits-only? value) - (zero? (remainder value #x10000))) - (define-integrable (ea/mode ea) (car ea)) (define-integrable (register-ea/register ea) (cadr ea)) (define-integrable (offset-ea/offset ea) (cadr ea)) diff --git a/v7/src/compiler/machines/mips/rules1.scm b/v7/src/compiler/machines/mips/rules1.scm index 0334795d6..f575de4f8 100644 --- a/v7/src/compiler/machines/mips/rules1.scm +++ b/v7/src/compiler/machines/mips/rules1.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.3 1991/06/17 21:21:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules1.scm,v 1.4 1991/07/25 02:46:10 cph Exp $ $MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -149,51 +149,49 @@ MIT in each case. |# (define-rule statement ;; load the address of a variable reference cache (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) - (LAP - ,@(load-pc-relative (free-reference-label name) - (standard-target! target)) - (NOP))) + (load-pc-relative (standard-target! target) + 'CONSTANT (free-reference-label name) + true)) (define-rule statement ;; load the address of an assignment cache (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) - (LAP - ,@(load-pc-relative (free-assignment-label name) - (standard-target! target)) - (NOP))) + (load-pc-relative (standard-target! target) + 'CONSTANT (free-assignment-label name) + true)) (define-rule statement ;; load the address of a procedure's entry point (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) - (load-pc-relative-address label (standard-target! target))) + (load-pc-relative-address (standard-target! target) 'CODE label)) (define-rule statement ;; load the address of a continuation (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) - (load-pc-relative-address label (standard-target! target))) - -;;; Spectrum optimizations converted to MIPS - -(define (load-entry label target) - (let ((target (standard-target! target))) - (LAP ,@(load-pc-relative-address label target) - ,@(address->entry target)))) + (load-pc-relative-address (standard-target! target) 'CODE label)) (define-rule statement ;; load a procedure object (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) - (QUALIFIER (= type (ucode-type compiled-entry))) - (load-entry label target)) + (load-entry target type label)) (define-rule statement ;; load a return address object (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (ENTRY:CONTINUATION (? label)))) - (QUALIFIER (= type (ucode-type compiled-entry))) - (load-entry label target)) + (load-entry target type label)) + +(define (load-entry target type label) + (let ((temporary (standard-temporary!)) + (target (standard-target! target))) + ;; Loading the address into a temporary makes it more useful, + ;; because it can be reused later. + (LAP ,@(load-pc-relative-address temporary 'CODE label) + (AND ,target ,temporary ,regnum:address-mask) + ,@(put-type type target)))) ;;;; Transfers to Memory @@ -269,16 +267,14 @@ MIT in each case. |# (define-rule statement ;; convert char object to ASCII byte ;; Missing optimization: If source is home and this is the last - ;; reference (it is dead afterwards), an LB could be done instead - ;; of an LW followed by an object->datum. This is unlikely since - ;; the value will be home only if we've spilled it, which happens - ;; rarely. + ;; reference (it is dead afterwards), an LB could be done instead of + ;; an LW followed by an ANDI. This is unlikely since the value will + ;; be home only if we've spilled it, which happens rarely. (ASSIGN (REGISTER (? target)) (CHAR->ASCII (REGISTER (? source)))) (standard-unary-conversion source target (lambda (source target) - (LAP (SLL ,target ,source 24) - (SRL ,target ,target 24))))) + (LAP (ANDI ,target ,source #xFF))))) (define-rule statement ;; store null byte in memory diff --git a/v7/src/compiler/machines/mips/rules3.scm b/v7/src/compiler/machines/mips/rules3.scm index 71ef8c090..8e8769c35 100644 --- a/v7/src/compiler/machines/mips/rules3.scm +++ b/v7/src/compiler/machines/mips/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.5 1991/06/17 21:22:05 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rules3.scm,v 1.6 1991/07/25 02:46:15 cph Exp $ $MC68020-Header: /scheme/compiler/bobcat/RCS/rules3.scm,v 4.30 1991/05/07 13:45:31 jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -77,10 +77,14 @@ MIT in each case. |# (define-rule statement (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) continuation ;ignore - (LAP ,@(clear-map!) - ,@(load-immediate number-pushed regnum:third-arg) - ,@(load-pc-relative-address label regnum:second-arg) - ,@(invoke-interface code:compiler-lexpr-apply))) + (let* ((clear-second-arg (clear-registers! regnum:second-arg)) + (load-second-arg + (load-pc-relative-address regnum:second-arg 'CODE label))) + (LAP ,@clear-second-arg + ,@load-second-arg + ,@(clear-map!) + ,@(load-immediate number-pushed regnum:third-arg) + ,@(invoke-interface code:compiler-lexpr-apply)))) (define-rule statement (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation)) @@ -92,7 +96,7 @@ MIT in each case. |# ,@(load-immediate number-pushed regnum:third-arg) ,@(object->address regnum:second-arg) ,@(invoke-interface code:compiler-lexpr-apply))) - + (define-rule statement (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) continuation ;ignore @@ -112,11 +116,15 @@ MIT in each case. |# (? continuation) (? extension register-expression)) continuation ;ignore - (LAP ,@(load-interface-args! extension false false false) - ,@(load-immediate frame-size regnum:fourth-arg) - ,@(load-pc-relative-address *block-label* regnum:third-arg) - ,@(invoke-interface code:compiler-cache-reference-apply))) - + (let* ((clear-third-arg (clear-registers! regnum:third-arg)) + (load-third-arg + (load-pc-relative-address regnum:third-arg 'CODE *block-label*))) + (LAP ,@clear-third-arg + ,@load-third-arg + ,@(load-interface-args! extension false false false) + ,@(load-immediate frame-size regnum:fourth-arg) + ,@(invoke-interface code:compiler-cache-reference-apply)))) + (define-rule statement (INVOCATION:LOOKUP (? frame-size) (? continuation) @@ -127,7 +135,7 @@ MIT in each case. |# ,(load-constant name regnum:third-arg) ,(load-immediate frame-size regnum:fourth-arg) ,@(invoke-interface code:compiler-lookup-apply))) - + (define-rule statement (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) continuation ;ignore @@ -135,39 +143,45 @@ MIT in each case. |# (LAP ,@(clear-map!) ,@(load-immediate frame-size regnum:second-arg) ,@(invoke-interface code:compiler-error)) - (LAP ,@(clear-map!) - ,@(load-pc-relative (constant->label primitive) - regnum:second-arg) - ,@(let ((arity (primitive-procedure-arity primitive))) - (cond ((not (negative? arity)) - (invoke-interface code:compiler-primitive-apply)) - ((= arity -1) - (LAP ,@(load-immediate (-1+ frame-size) - regnum:assembler-temp) - - (SW ,regnum:assembler-temp - ,reg:lexpr-primitive-arity) - ,@(invoke-interface - code:compiler-primitive-lexpr-apply))) - (else - ;; Unknown primitive arity. Go through apply. - (LAP ,@(load-immediate frame-size regnum:third-arg) - ,@(invoke-interface code:compiler-apply)))))))) + (let* ((clear-second-arg (clear-registers! regnum:second-arg)) + (load-second-arg + (load-pc-relative regnum:second-arg + 'CONSTANT + (constant->label primitive) + false))) + (LAP ,@clear-second-arg + ,@load-second-arg + ,@(clear-map!) + ,@(let ((arity (primitive-procedure-arity primitive))) + (cond ((not (negative? arity)) + (invoke-interface code:compiler-primitive-apply)) + ((= arity -1) + (LAP ,@(load-immediate (-1+ frame-size) + regnum:assembler-temp) + + (SW ,regnum:assembler-temp + ,reg:lexpr-primitive-arity) + ,@(invoke-interface + code:compiler-primitive-lexpr-apply))) + (else + ;; Unknown primitive arity. Go through apply. + (LAP ,@(load-immediate frame-size regnum:third-arg) + ,@(invoke-interface code:compiler-apply))))))))) (let-syntax ((define-special-primitive-invocation (macro (name) - `(define-rule statement + `(DEFINE-RULE STATEMENT (INVOCATION:SPECIAL-PRIMITIVE - (? frame-size) - (? continuation) + (? FRAME-SIZE) + (? CONTINUATION) ,(make-primitive-procedure name true)) - frame-size continuation + FRAME-SIZE CONTINUATION ,(list 'LAP - (list 'UNQUOTE-SPLICING '(clear-map!)) + (list 'UNQUOTE-SPLICING '(CLEAR-MAP!)) (list 'UNQUOTE-SPLICING - `(INVOKE-INTERFACE ,(symbol-append 'CODE:COMPILER- - name)))))))) + `(INVOKE-INTERFACE + ,(symbol-append 'CODE:COMPILER- name)))))))) (define-special-primitive-invocation &+) (define-special-primitive-invocation &-) (define-special-primitive-invocation &*) @@ -203,8 +217,8 @@ MIT in each case. |# (define-rule statement ;; Move words back to SP+offset - (INVOCATION-PREFIX:MOVE-FRAME-UP - (? frame-size) (OFFSET-ADDRESS (REGISTER 3) (? offset))) + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER 3) (? offset))) (let ((how-far (* 4 (- offset frame-size)))) (cond ((zero? how-far) (LAP)) @@ -236,6 +250,7 @@ MIT in each case. |# (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (OFFSET-ADDRESS (REGISTER (? base)) (? offset))) + (QUALIFIER (not (= base 3))) (generate/move-frame-up frame-size (lambda (reg) (add-immediate (* 4 offset) (standard-source! base) reg)))) @@ -495,7 +510,8 @@ MIT in each case. |# (let ((dest (standard-target! target)) (gc-offset-word (build-gc-offset-word - 8 (make-procedure-code-word min max)))) + 8 (make-procedure-code-word min max))) + (return-label (generate-label))) ;; Note: dest is used as a temporary before the JALR ;; instruction, and is written immediately afterwards. ;; The interface (scheme_to_interface-88) expects: @@ -506,13 +522,14 @@ MIT in each case. |# (LAP ,@flush-reg ,@(load-immediate (+ size closure-entry-size) 1) (LUI 25 ,(quotient gc-offset-word #x10000)) - (PC-RELATIVE-OFFSET 4 16 - ,(rtl-procedure/external-label (label->object label))) - (ADDI ,dest ,regnum:scheme-to-interface -88) ; + 4 - (JALR 31 ,dest) ; + 8 - (ORI 25 25 ,(remainder gc-offset-word #x10000)) ; +12 - ,@(add-immediate (* 4 (- (+ size 2))) ; +16 - regnum:free dest))))) + (ADDI ,regnum:first-arg 0 + (- ,(rtl-procedure/external-label (label->object label)) + ,return-label)) + (ADDI ,dest ,regnum:scheme-to-interface -88) + (JALR 31 ,dest) + (ORI 25 25 ,(remainder gc-offset-word #x10000)) + (LABEL ,return-label) + ,@(add-immediate (* 4 (- (+ size 2))) regnum:free dest))))) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -529,14 +546,12 @@ MIT in each case. |# (let ((dest (standard-target! target)) (temp (standard-temporary!))) (LAP (ADD ,dest 0 ,regnum:free) - ,@(load-non-pointer - (ucode-type manifest-vector) size temp) + ,@(load-non-pointer (ucode-type manifest-vector) size temp) (SW ,temp (OFFSET 0 ,regnum:free)) (ADDI ,regnum:free ,regnum:free ,(* 4 (+ size 1)))))) ((1) (let ((entry (vector-ref entries 0))) - (cons-closure - target (car entry) (cadr entry) (caddr entry) size))) + (cons-closure target (car entry) (cadr entry) (caddr entry) size))) (else (cons-multiclosure target nentries size (vector->list entries))))) @@ -557,18 +572,20 @@ MIT in each case. |# (let ((gc-offset-word (build-gc-offset-word offset - (make-procedure-code-word - (cadr entry) (caddr entry))))) - (LAP - (LUI 1 ,(quotient gc-offset-word #x10000)) - (PC-RELATIVE-OFFSET 4 16 ,(rtl-procedure/external-label - (label->object (car entry)))) - (ADDI ,temp ,regnum:scheme-to-interface -80) ; + 4 - (JALR 31 ,temp) ; + 8 - (ORI 1 1 ,(remainder gc-offset-word #x10000)) ; + 12 - ,@(generate-entries (cdr entries) ; + 16 - (+ (* closure-entry-size 4) - offset))))))) + (make-procedure-code-word (cadr entry) (caddr entry)))) + (return-label (generate-label))) + (LAP + (LUI 1 ,(quotient gc-offset-word #x10000)) + (ADDI ,regnum:first-arg 0 + (- ,(rtl-procedure/external-label + (label->object (car entry))) + ,return-label)) + (ADDI ,temp ,regnum:scheme-to-interface -80) + (JALR 31 ,temp) + (ORI 1 1 ,(remainder gc-offset-word #x10000)) + (LABEL ,return-label) + ,@(generate-entries (cdr entries) + (+ (* closure-entry-size 4) offset))))))) (LAP ,@(load-non-pointer (ucode-type manifest-closure) total-size temp) @@ -587,36 +604,63 @@ MIT in each case. |# ;; Calls the linker ;; On MIPS, regnum:first-arg is used as a temporary here since ;; load-pc-relative-address uses the assembler temporary. - (LAP - ; Grab interp's env. and store in code block at environment-label - (LW ,regnum:first-arg ,reg:environment) - ,@(load-pc-relative-address environment-label regnum:second-arg) - (SW ,regnum:first-arg (OFFSET 0 ,regnum:second-arg)) - ; Now invoke the linker (arg. 1 is return address, supplied by interface) - ,@(load-pc-relative-address *block-label* regnum:third-arg) - ,@(load-pc-relative-address free-ref-label regnum:fourth-arg) - ,@(load-immediate n-sections regnum:first-arg) - (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer)) - ,@(link-to-interface code:compiler-link) - ,@(make-external-label (continuation-code-word false) - (generate-label)))) + (in-assembler-environment (empty-register-map) + (list regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda () + (let* ((i1 + (load-pc-relative-address regnum:second-arg + 'CONSTANT environment-label)) + (i2 (load-pc-relative-address regnum:third-arg + 'CODE *block-label*)) + (i3 (load-pc-relative-address regnum:fourth-arg + 'CONSTANT free-ref-label))) + (LAP + ;; Grab interp's env. and store in code block at environment-label + (LW ,regnum:first-arg ,reg:environment) + ,@i1 + (SW ,regnum:first-arg (OFFSET 0 ,regnum:second-arg)) + ;; Now invoke the linker + ;; (arg1 is return address, supplied by interface) + ,@i2 + ,@i3 + ,@(load-immediate n-sections regnum:first-arg) + (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer)) + ,@(link-to-interface code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label))))))) (define (generate/remote-link code-block-label environment-offset free-ref-offset n-sections) ;; Link all of the top level procedures within the file - (LAP ,@(load-pc-relative code-block-label regnum:third-arg) - (LW ,regnum:fourth-arg ,reg:environment) - ,@(object->address regnum:third-arg) - ,@(add-immediate environment-offset regnum:third-arg regnum:second-arg) - (SW ,regnum:fourth-arg (OFFSET 0 ,regnum:second-arg)) - ,@(add-immediate free-ref-offset regnum:third-arg regnum:fourth-arg) - ,@(load-immediate n-sections regnum:first-arg) - (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer)) - ,@(link-to-interface code:compiler-link) - ,@(make-external-label (continuation-code-word false) - (generate-label)))) + (in-assembler-environment (empty-register-map) + (list regnum:first-arg regnum:second-arg + regnum:third-arg regnum:fourth-arg) + (lambda () + (LAP ,@(load-pc-relative regnum:third-arg 'CODE code-block-label false) + (LW ,regnum:fourth-arg ,reg:environment) + ,@(object->address regnum:third-arg) + ,@(add-immediate environment-offset regnum:third-arg + regnum:second-arg) + (SW ,regnum:fourth-arg (OFFSET 0 ,regnum:second-arg)) + ,@(add-immediate free-ref-offset regnum:third-arg regnum:fourth-arg) + ,@(load-immediate n-sections regnum:first-arg) + (SW ,regnum:first-arg (OFFSET 16 ,regnum:C-stack-pointer)) + ,@(link-to-interface code:compiler-link) + ,@(make-external-label (continuation-code-word false) + (generate-label)))))) + +(define (in-assembler-environment map needed-registers thunk) + (fluid-let ((*register-map* map) + (*prefix-instructions* (LAP)) + (*suffix-instructions* (LAP)) + (*needed-registers* needed-registers)) + (let ((instructions (thunk))) + (LAP ,@*prefix-instructions* + ,@instructions + ,@*suffix-instructions*)))) (define (generate/constants-block constants references assignments uuo-links global-links static-vars) @@ -688,7 +732,8 @@ MIT in each case. |# ,@(inner name (cdr assoc))))) (if (null? uuos) '() - (inner (caar uuos) (cdar uuos)))) ; caar is name, cdar is alist of frame sizes + ;; caar is name, cdar is alist of frame sizes + (inner (caar uuos) (cdar uuos)))) ;;; Local Variables: *** ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** diff --git a/v7/src/compiler/machines/mips/rulflo.scm b/v7/src/compiler/machines/mips/rulflo.scm index ee1fffc9b..11d36c056 100644 --- a/v7/src/compiler/machines/mips/rulflo.scm +++ b/v7/src/compiler/machines/mips/rulflo.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.4 1991/07/16 20:53:28 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/rulflo.scm,v 1.5 1991/07/25 02:46:19 cph Exp $ $MC68020-Header: rules1.scm,v 4.33 90/05/03 15:17:28 GMT jinx Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -103,32 +103,9 @@ MIT in each case. |# (macro (primitive-name opcode) `(define-arithmetic-method ',primitive-name flonum-methods/1-arg (lambda (target source) - (LAP (,opcode DOUBLE ,',target ,',source))))))) - (define-flonum-operation flonum-abs FABS) - (define-flonum-operation flonum-negate FNEG)) - -; Well, I thought this would work, but the fine print in the manual -; says that CVT.D only works with a source type of single precision. - -; (define-arithmetic-method 'FLONUM-ROUND flonum-methods/1-arg -; (lambda (target source) -; (let ((temp (standard-temporary!))) -; (LAP (CFC1 ,regnum:assembler-temp 31) ; Status register -; (ORI ,temp ,regnum:assembler-temp 3) ; Rounding Mode <- -; (XORI ,temp ,temp 3) ;; 0 (nearest) -; (CTC1 ,temp 31) ; Store mode back -; (CVT.D DOUBLE ,target ,source) ; Move & round -; (CTC1 ,regnum:assembler-temp 31))))) ; Restore status - -; (define-arithmetic-method 'FLONUM-TRUNCATE flonum-methods/1-arg -; (lambda (target source) -; (let ((temp (standard-temporary!))) -; (LAP (CFC1 ,regnum:assembler-temp 31) ; Status register -; (ORI ,temp ,regnum:assembler-temp 3) ; Rounding Mode <- -; (XORI ,temp ,temp 2) ;; 1 (toward zero) -; (CTC1 ,temp 31) ; Store mode back -; (CVT.D DOUBLE ,target ,source) ; Move & round -; (CTC1 ,regnum:assembler-temp 31))))) ; Restore status + (LAP (,opcode ,',target ,',source))))))) + (define-flonum-operation flonum-abs ABS.D) + (define-flonum-operation flonum-negate NEG.D)) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -154,11 +131,11 @@ MIT in each case. |# (macro (primitive-name opcode) `(define-arithmetic-method ',primitive-name flonum-methods/2-args (lambda (target source1 source2) - (LAP (,opcode DOUBLE ,',target ,',source1 ,',source2))))))) - (define-flonum-operation flonum-add FADD) - (define-flonum-operation flonum-subtract FSUB) - (define-flonum-operation flonum-multiply FMUL) - (define-flonum-operation flonum-divide FDIV)) + (LAP (,opcode ,',target ,',source1 ,',source2))))))) + (define-flonum-operation flonum-add ADD.D) + (define-flonum-operation flonum-subtract SUB.D) + (define-flonum-operation flonum-multiply MUL.D) + (define-flonum-operation flonum-divide DIV.D)) ;;;; Flonum Predicates @@ -172,9 +149,9 @@ MIT in each case. |# (NOP) ,@(flonum-compare (case predicate - ((FLONUM-ZERO?) 'C.EQ) - ((FLONUM-NEGATIVE?) 'C.LT) - ((FLONUM-POSITIVE?) 'C.GT) + ((FLONUM-ZERO?) 'C.EQ.D) + ((FLONUM-NEGATIVE?) 'C.LT.D) + ((FLONUM-POSITIVE?) 'C.GT.D) (else (error "unknown flonum predicate" predicate))) source temp)))) @@ -183,9 +160,9 @@ MIT in each case. |# (REGISTER (? source1)) (REGISTER (? source2))) (flonum-compare (case predicate - ((FLONUM-EQUAL?) 'C.EQ) - ((FLONUM-LESS?) 'C.LT) - ((FLONUM-GREATER?) 'C.GT) + ((FLONUM-EQUAL?) 'C.EQ.D) + ((FLONUM-LESS?) 'C.LT.D) + ((FLONUM-GREATER?) 'C.GT.D) (else (error "unknown flonum predicate" predicate))) (flonum-source! source1) (flonum-source! source2))) @@ -196,6 +173,6 @@ MIT in each case. |# (LAP (BC1T (@PCR ,label)) (NOP))) (lambda (label) (LAP (BC1F (@PCR ,label)) (NOP)))) - (if (eq? cc 'C.GT) - (LAP (C.LT DOUBLE ,r2 ,r1) (NOP)) - (LAP (,cc DOUBLE ,r1 ,r2) (NOP)))) \ No newline at end of file + (if (eq? cc 'C.GT.D) + (LAP (C.LT.D ,r2 ,r1) (NOP)) + (LAP (,cc ,r1 ,r2) (NOP)))) \ No newline at end of file -- 2.25.1