#| -*-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
(declare (usual-integrations))
\f
-(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))
+\f
+(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)))))))
+\f
(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))
+\f
+(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))))
+\f
+(let-syntax
+ ((move-coprocessor-instruction
(macro (keyword opcode move-op)
`(define-instruction ,keyword
(((? rt-mci) (? rd-mci))
(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))))
+|#
+\f
+;;;; 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
#| -*-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
((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)))
((() ())
;; <reverse> 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)
(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
#| -*-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
(16 delta SIGNED)))
((() ())
;; LUI 1,adjusted-left<offset>
- ;; ADDU 1,1,base-reg
+ ;; ADDU 1,1,base-reg
;; LW source/dest-reg,right<offset>(1)
(LONG (6 15) ; LUI
(5 0)
(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)
+ )
#| -*-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
MIT in each case. |#
;;;; MIPS instruction set, part 3
+;;; Floating point co-processor (R2010)
(declare (usual-integrations))
-;;;; Floating point co-processor (R2010)
-
+\f
(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))
+\f
+(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))))
+\f
+(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)
(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
#| -*-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
(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))))
(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,
\f
;;;; 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))))))
-\f
+ (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
(SWC1 ,most (OFFSET ,(+ offset 4) ,base)))
(LAP (SWC1 ,least (OFFSET ,(+ offset 4) ,base))
(SWC1 ,most (OFFSET ,offset ,base))))))
+\f
+;;;; 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)
\f
-(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 <comp> r2
`(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)
((= <>) (LAP))
((< >=) (LAP (SLT ,temp ,r1 ,r2)))
((> <=) (LAP (SLT ,temp ,r2 ,r1))))))
-\f
-;;;; 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)))
(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))
#| -*-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
(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))))
\f
;;;; Transfers to Memory
(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
#| -*-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
(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))
,@(load-immediate number-pushed regnum:third-arg)
,@(object->address regnum:second-arg)
,@(invoke-interface code:compiler-lexpr-apply)))
-
+\f
(define-rule statement
(INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
continuation ;ignore
(? 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)))
-\f
+ (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)
,(load-constant name regnum:third-arg)
,(load-immediate frame-size regnum:fourth-arg)
,@(invoke-interface code:compiler-lookup-apply)))
-
+\f
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
continuation ;ignore
(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 &*)
(define-rule statement
;; Move <frame-size> 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))
(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))))
(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:
(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))
(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)))))
(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)
;; 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*))))
\f
(define (generate/constants-block constants references assignments uuo-links
global-links static-vars)
,@(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))))
\f
;;; Local Variables: ***
;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
#| -*-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
(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))
(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))
\f
;;;; Flonum Predicates
(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))))
(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)))
(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
projects / mit-scheme.git / commitdiff