#| -*-Scheme-*-

$Id: dassm3.scm,v 1.6 2003/02/14 18:28:03 cph Exp $

Copyright (c) 1987-1999 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;; MIPS Disassembler: Internals

(declare (usual-integrations))

;;;; Utilities

(define (get-longword)
  (let ((word (read-bits *current-offset 32)))
    (set! *current-offset (+ *current-offset 4))
    word))

(declare (integrate-operator extract))
(declare (integrate-operator extract-signed))

(define (extract bit-string start end)
  (declare (integrate bit-string start end))
  (bit-string->unsigned-integer (bit-substring bit-string start end)))

(define (extract-signed bit-string start end)
  (declare (integrate bit-string start end))
  (bit-string->signed-integer (bit-substring bit-string start end)))

;; Debugging assistance

(define (verify-instruction instruction)
  (let ((bits (car (lap:syntax-instruction instruction))))
    (if (bit-string? bits)
	(begin
	  (let ((disassembly (disassemble bits)))
	    (if (and (null? (cdr disassembly))
		     (equal? (car disassembly) instruction))
		   #T
		   disassembly)))
	(error "Assember oddity" bits))))

(define (v i) (verify-instruction i))

;;;; The disassembler proper

(define (handle-bad-instruction word)
  word
  (invalid-instruction))

(define (disassemble bit-string)
  (let ((stop (bit-string-length bit-string)))
    (let loop ((from 0)
	       (to 32)
	       (result '()))
      (if (> to stop)
	  result
	  (loop to (+ to 32) (cons (disassemble-word (bit-substring bit-string from to))
				   result))))))

(define disassemblers (make-vector (expt 2 6) handle-bad-instruction))

(define (disassemble-word word)
  (let ((op-code (extract word 26 32)))
    ((vector-ref disassemblers op-code) word)))

(vector-set! disassemblers special-op
  (lambda (word) (disassemble-special word)))
(vector-set! disassemblers bcond-op
  (lambda (word) (disassemble-branch-zero word)))
(vector-set! disassemblers j-op
  (lambda (word) (disassemble-jump word 'j)))
(vector-set! disassemblers jal-op
  (lambda (word) (disassemble-jump word 'jal)))
(vector-set! disassemblers beq-op
  (lambda (word) (disassemble-compare word 'beq)))
(vector-set! disassemblers bne-op
  (lambda (word) (disassemble-compare word 'bne)))
(vector-set! disassemblers blez-op
  (lambda (word) (disassemble-branch-zero-op word 'blez)))
(vector-set! disassemblers bgtz-op
  (lambda (word) (disassemble-branch-zero-op word 'bgtz)))
(vector-set! disassemblers addi-op
  (lambda (word) (disassemble-immediate word 'addi)))
(vector-set! disassemblers addiu-op
  (lambda (word) (disassemble-immediate word 'addiu)))
(vector-set! disassemblers slti-op
  (lambda (word) (disassemble-immediate word 'slti)))
(vector-set! disassemblers sltiu-op
  (lambda (word) (disassemble-immediate word 'sltiu)))
(vector-set! disassemblers andi-op
  (lambda (word) (disassemble-unsigned-immediate word 'andi)))
(vector-set! disassemblers ori-op
  (lambda (word) (disassemble-unsigned-immediate word 'ori)))
(vector-set! disassemblers xori-op
  (lambda (word) (disassemble-unsigned-immediate word 'xori)))
(vector-set! disassemblers lui-op
  (lambda (word) (disassemble-lui word)))
(vector-set! disassemblers cop0-op
  (lambda (word) (disassemble-coprocessor word 0)))
(vector-set! disassemblers cop1-op
  (lambda (word) (disassemble-coprocessor word 1)))
(vector-set! disassemblers cop2-op
  (lambda (word) (disassemble-coprocessor word 2)))
(vector-set! disassemblers cop3-op
  (lambda (word) (disassemble-coprocessor word 3)))
(vector-set! disassemblers lb-op
  (lambda (word) (disassemble-load/store word 'lb)))
(vector-set! disassemblers lh-op
  (lambda (word) (disassemble-load/store word 'lh)))
(vector-set! disassemblers lwl-op
  (lambda (word) (disassemble-load/store word 'lwl)))
(vector-set! disassemblers lw-op
  (lambda (word) (disassemble-load/store word 'lw)))
(vector-set! disassemblers lbu-op
  (lambda (word) (disassemble-load/store word 'lbu)))
(vector-set! disassemblers lhu-op
  (lambda (word) (disassemble-load/store word 'lhu)))
(vector-set! disassemblers lwr-op
  (lambda (word) (disassemble-load/store word 'lwr)))
(vector-set! disassemblers sb-op
  (lambda (word) (disassemble-load/store word 'sb)))
(vector-set! disassemblers sh-op
  (lambda (word) (disassemble-load/store word 'sh)))
(vector-set! disassemblers swl-op
  (lambda (word) (disassemble-load/store word 'swl)))
(vector-set! disassemblers sw-op
  (lambda (word) (disassemble-load/store word 'sw)))
(vector-set! disassemblers swr-op
  (lambda (word) (disassemble-load/store word 'swr)))
(vector-set! disassemblers lwc0-op
  (lambda (word) (disassemble-load/store word 'lwc0)))
(vector-set! disassemblers lwc1-op
  (lambda (word) (disassemble-load/store word 'lwc1)))
(vector-set! disassemblers lwc2-op
  (lambda (word) (disassemble-load/store word 'lwc2)))
(vector-set! disassemblers lwc3-op
  (lambda (word) (disassemble-load/store word 'lwc3)))
(vector-set! disassemblers swc0-op
  (lambda (word) (disassemble-load/store word 'swc0)))
(vector-set! disassemblers swc1-op
  (lambda (word) (disassemble-load/store word 'swc1)))
(vector-set! disassemblers swc2-op
  (lambda (word) (disassemble-load/store word 'swc2)))
(vector-set! disassemblers swc3-op
  (lambda (word) (disassemble-load/store word 'swc3)))

(define special-disassemblers (make-vector (expt 2 6) handle-bad-instruction))

(define (disassemble-special word)
  (let ((function-code (extract word 0 6)))
    ((vector-ref special-disassemblers function-code) word)))

(vector-set! special-disassemblers sll-funct (lambda (word) (shift word 'sll)))
(vector-set! special-disassemblers srl-funct (lambda (word) (shift word 'srl)))
(vector-set! special-disassemblers sra-funct (lambda (word) (shift word 'sra)))
(vector-set! special-disassemblers sllv-funct (lambda (word) (shift-variable word 'sllv)))
(vector-set! special-disassemblers srlv-funct (lambda (word) (shift-variable word 'srlv)))
(vector-set! special-disassemblers srav-funct (lambda (word) (shift-variable word 'srav)))
(vector-set! special-disassemblers jr-funct
  (lambda (word)
    (let ((MBZ (extract word 6 21))
	  (rs (extract word 21 26)))
      (if (zero? MBZ)
	  `(jr ,rs)
	  (invalid-instruction)))))
(vector-set! special-disassemblers jalr-funct
  (lambda (word)
    (let ((MBZ1 (extract word 16 21))
	  (MBZ2 (extract word 6 11))
	  (rs (extract word 21 26))
	  (rd (extract word 11 16)))
      (if (and (zero? MBZ1) (zero? MBZ2))
	  `(JALR ,rd ,rs)
	  (invalid-instruction)))))
(vector-set! special-disassemblers syscall-funct
  (lambda (word)
    (let ((MBZ (extract word 6 26)))
      (if (zero? MBZ)
	  '(SYSCALL)
	  (invalid-instruction)))))
(vector-set! special-disassemblers break-funct (lambda (word) `(BREAK ,(extract word 6 26))))
(vector-set! special-disassemblers mfhi-funct (lambda (word) (from-hi/lo word 'mfhi)))
(vector-set! special-disassemblers mthi-funct (lambda (word) (to-hi/lo word 'mthi)))
(vector-set! special-disassemblers mflo-funct (lambda (word) (from-hi/lo word 'mflo)))
(vector-set! special-disassemblers mtlo-funct (lambda (word) (to-hi/lo word 'mtlo)))
(vector-set! special-disassemblers mult-funct (lambda (word) (mul/div word 'mult)))
(vector-set! special-disassemblers multu-funct (lambda (word) (mul/div word 'multu)))
(vector-set! special-disassemblers div-funct (lambda (word) (mul/div word 'div)))
(vector-set! special-disassemblers divu-funct (lambda (word) (mul/div word 'divu)))
(vector-set! special-disassemblers add-funct (lambda (word) (arith word 'add)))
(vector-set! special-disassemblers addu-funct (lambda (word) (arith word 'addu)))
(vector-set! special-disassemblers sub-funct (lambda (word) (arith word 'sub)))
(vector-set! special-disassemblers subu-funct (lambda (word) (arith word 'subu)))
(vector-set! special-disassemblers and-funct (lambda (word) (arith word 'and)))
(vector-set! special-disassemblers or-funct (lambda (word) (arith word 'or)))
(vector-set! special-disassemblers xor-funct (lambda (word) (arith word 'xor)))
(vector-set! special-disassemblers nor-funct (lambda (word) (arith word 'nor)))
(vector-set! special-disassemblers slt-funct (lambda (word) (arith word 'slt)))
(vector-set! special-disassemblers sltu-funct (lambda (word) (arith word 'sltu)))

(define (shift word op)
  (let ((MBZ (extract word 21 26))
	(rt (extract word 16 21))
	(rd (extract word 11 16))
	(shamt (extract word 6 11)))
    (if (zero? MBZ)
	`(,op ,rd ,rt ,shamt)
	(invalid-instruction))))

(define (shift-variable word op)
  (let ((MBZ (extract word 6 11))
	(rs (extract word 21 26))
	(rt (extract word 16 21))
	(rd (extract word 11 16)))
    (if (zero? MBZ)
	`(,op ,rd ,rt ,rs)
	(invalid-instruction))))

(define (from-hi/lo word op)
  (let ((MBZ1 (extract word 16 26))
	(MBZ2 (extract word 6 11))
	(rd (extract word 11 16)))
    (if (and (zero? MBZ1) (zero? MBZ2))
	`(,op ,rd)
	(invalid-instruction))))

(define (to-hi/lo word op)
  (let ((MBZ (extract word 6 21))
	(rs (extract word 21 26)))
    (if (zero? MBZ)
	`(,op ,rs)
	(invalid-instruction))))

(define (mul/div word op)
  (let ((MBZ (extract word 6 16))
	(rs (extract word 21 26))
	(rt (extract word 16 21)))
    (if (zero? MBZ)
	`(,op ,rs ,rt)
	(invalid-instruction))))

(define (arith word op)
  (let ((MBZ (extract word 6 11))
	(rs (extract word 21 26))
	(rt (extract word 16 21))
	(rd (extract word 11 16)))
    (if (zero? MBZ)
	`(,op ,rd ,rs ,rt)
	(invalid-instruction))))

(define (disassemble-jump word op)
  `(,op ,(extract word 0 26)))

(define (relative-offset word)
  (offset->@pcr (+ *current-offset (* 4 (extract-signed word 0 16)))))

(define (offset->@pcr offset)
  `(@PCR ,(or (and disassembler/symbolize-output?
		   (disassembler/lookup-symbol *symbol-table offset))
	      offset)))

(define (disassemble-branch-zero word)
  (let ((conditions (extract word 16 21))
	(rs (extract word 21 26))
	(offset (relative-offset word)))
    (cond ((= conditions bltz-cond) `(BLTZ ,rs ,offset))
	  ((= conditions bltzal-cond) `(BLTZAL ,rs ,offset))
	  ((= conditions bgez-cond) `(BGEZ ,rs ,offset))
	  ((= conditions bgezal-cond) `(BGEZAL ,rs ,offset))
	  (else (invalid-instruction)))))

(define (disassemble-branch-zero-op word op)
  (let ((MBZ (extract word 16 21))
	(rs (extract word 21 26)))
    (if (zero? MBZ)
	`(,op ,rs ,(relative-offset word))
	(invalid-instruction))))

(define (disassemble-compare word op)
  `(,op ,(extract word 21 26)
	,(extract word 16 21)
	,(relative-offset word)))

(define (disassemble-immediate word op)
  `(,op ,(extract word 16 21)
	,(extract word 21 26)
	,(extract-signed word 0 16)))

(define (disassemble-unsigned-immediate word op)
  `(,op ,(extract word 16 21)
	,(extract word 21 26)
	,(extract word 0 16)))

(define (disassemble-lui word)
  (if (zero? (extract word 21 26))
      `(LUI ,(extract word 16 21)
	    ,(extract word 0 16))
      (invalid-instruction)))

(define (floating-point-cases code)
  (let ((format (extract code 21 25))
	(ft (extract code 16 21))
	(fs (extract code 11 16))
	(fd (extract code 6 11))
	(fp-code (extract code 0 6)))
    (let ((fmt (case format ((0) 'SINGLE) ((1) 'DOUBLE) (else '()))))
      (define (two-arg op-name)
	(if (zero? ft)
	    (list op-name fmt fd fs)
	    (invalid-instruction)))
      (define (compare op-name)
	(if (zero? fd)
	    (list op-name fmt fs ft)
	    (invalid-instruction)))
      (if fmt
	  (cond
	   ((= fp-code addf-op) `(FADD ,fmt ,fd ,fs ,ft))
	   ((= fp-code subf-op) `(FSUB ,fmt ,fd ,fs ,ft))
	   ((= fp-code mulf-op) `(FMUL ,fmt ,fd ,fs ,ft))
	   ((= fp-code divf-op) `(FDIV ,fmt ,fd ,fs ,ft))
	   ((= fp-code absf-op) (two-arg 'FABS))
	   ((= fp-code movf-op) (two-arg 'FMOV))
	   ((= fp-code negf-op) (two-arg 'FNEG))
	   ((= fp-code cvt.sf-op) (two-arg 'CVT.S))
	   ((= fp-code cvt.df-op) (two-arg 'CVT.D))
	   ((= fp-code cvt.wf-op) (two-arg 'CVT.W))
	   ((= fp-code c.ff-op) (compare 'C.F))
	   ((= fp-code c.unf-op) (compare 'C.UN))
	   ((= fp-code c.eqf-op) (compare 'C.EQ))
	   ((= fp-code c.ueqf-op) (compare 'C.UEQ))
	   ((= fp-code c.oltf-op) (compare 'C.OLT))
	   ((= fp-code c.ultf-op) (compare 'C.ULT))
	   ((= fp-code c.olef-op) (compare 'C.OLE))
	   ((= fp-code c.ulef-op) (compare 'C.ULE))
	   ((= fp-code c.sff-op) (compare 'C.SF))
	   ((= fp-code c.nglef-op) (compare 'C.NGLE))
	   ((= fp-code c.seqf-op) (compare 'C.SEQ))
	   ((= fp-code c.nglf-op) (compare 'C.NGL))
	   ((= fp-code c.ltf-op) (compare 'C.LT))
	   ((= fp-code c.ngef-op) (compare 'C.NGE))
	   ((= fp-code c.lef-op) (compare 'C.LE))
	   ((= fp-code c.ngtf-op) (compare 'C.NGT))
	   (else (invalid-instruction)))
	  (invalid-instruction)))))

(define (disassemble-coprocessor word op)
  (define (simple-cases op2)
    (if (zero? (extract word 0 11))
	`(,op2 ,(extract word 16 21) ,(extract word 11 16))))
  (define (branch-cases op2)
    `(,op2 ,(relative-offset word)))
  (define (cop0-cases code)
    (case code
      ((1) '(TLBR))
      ((2) '(TLBWI))
      ((6) '(TLBWR))
      ((8) '(TLBP))
      ((16) '(RFE))
      (else `(COP0 ,code))))
  (let ((code-high-bits (+ (* 4 (extract word 21 23))
			  (extract word 16 17)))
	(code-low-bits (extract word 23 26)))
    (let ((code (+ (* code-high-bits 8) code-low-bits)))
      (case code
	((0 8)				; MF
	 (case op
	   ((0) (simple-cases 'mfc0))
	   ((1) (simple-cases 'mfc1))
	   ((2) (simple-cases 'mfc2))
	   ((3) (simple-cases 'mfc3))))	 
	((1 9)				; MT
	 (case op
	   ((0) (simple-cases 'mtc0))
	   ((1) (simple-cases 'mtc1))
	   ((2) (simple-cases 'mtc2))
	   ((3) (simple-cases 'mtc3))))
	((2 3)				; BCF
	 (case op
	   ((0) (branch-cases 'bcf0))
	   ((1) (branch-cases 'bcf1))
	   ((2) (branch-cases 'bcf2))
	   ((3) (branch-cases 'bcf3))))
	((4  5  6  7  12 13 14 15 20 21 22 23 28 29 30 31
	  36 37 38 39 44 45 46 47 52 53 54 55 60 61 62 63) ; CO
	 (case op
	   ((0) (cop0-cases (extract word 0 25)))
	   ((1) (floating-point-cases (bit-substring word 0 25)))
	   ((2) `(cop2 ,(extract word 0 25)))
	   ((3) `(cop3 ,(extract word 0 25)))))
	((10 11)			; BCT
	 (case op
	   ((0) (branch-cases 'bct0))
	   ((1) (branch-cases 'bct1))
	   ((2) (branch-cases 'bct2))
	   ((3) (branch-cases 'bct3))))
	((32 40)			; CF
	 (case op
	   ((0) (simple-cases 'cfc0))
	   ((1) (simple-cases 'cfc1))
	   ((3) (simple-cases 'cfc2))
	   ((3) (simple-cases 'cfc3))))
	((33 41)			; CT
	 (case op
	   ((0) (simple-cases 'ctc0))
	   ((1) (simple-cases 'ctc1))
	   ((2) (simple-cases 'ctc2))
	   ((3) (simple-cases 'ctc3))))
	(else (invalid-instruction))))))

(define (disassemble-load/store word op)
  `(,op ,(extract word 16 21)
	(OFFSET ,(extract-signed word 0 16) ,(extract word 21 26))))
