;;;
;;; disassembler.lisp
;;;
;;; Alpha AXP disassembler.
;;;

(cl:in-package :perry)


;;;; Instruction fields.

;;; We use define-symbol-macro for the byte specifiers in order to
;;; have them be effectively constant when compiling code that uses
;;; them without having syntactic silliness like #. or using a
;;; macrolet.  This also means that we can use them in this file
;;; without an eval-when.

;; Alpha instructions are all 32 bits wide.  There are five basic
;; instruction formats, all of which have a six-bit opcode field in
;; (byte 6 26).
;;
;;   1.: Memory instructions.
;;
;;     (byte 6 26): opcode.
;;     (byte 5 21): Ra.
;;     (byte 5 16): Rb.
;;
;;     (byte 16 0): Memory_disp (sign extended).
;;                  -or-
;;     (byte 16 0): Function code (unknown use).
;;                  -or-
;;     (byte 16 0): Branch prediction hints (unknown use).

(define-symbol-macro %%instruction-opcode (byte 6 26))
(define-symbol-macro %%instruction-ra (byte 5 21))
(define-symbol-macro %%instruction-rb (byte 5 16))
(define-symbol-macro %%instruction-memory-disp (byte 16 0))
(define-symbol-macro %%instruction-memory-function (byte 16 0))
(define-symbol-macro %%instruction-branch-hints (byte 16 0))

;;   2.: Branch instructions.
;;
;;     (byte 6 26): opcode.
;;     (byte 5 21): Ra.
;;     (byte 21 0): Branch_disp (sign extended, longword offset).

(define-symbol-macro %%instruction-branch-disp (byte 21 0))

;;   3.: Operate instructions.
;;
;;     (byte 6 26): opcode.
;;     (byte 5 21): Ra.
;;
;;     (byte 5 16): Rb.
;;     (byte 3 13): SBZ.
;;     (byte 1 12): 1
;;                  -or-
;;     (byte 8 13): Literal (zero extended).
;;     (byte 1 12): 0
;;
;;     (byte 7 5): Function.
;;     (byte 5 0): Rc.

(defconstant %%instruction-operate-register-flag-bit 12)
(define-symbol-macro %%instruction-opreate-literal (byte 8 13))
(define-symbol-macro %%instruction-opreate-function (byte 7 5))
(define-symbol-macro %%instruction-rc (byte 5 0))

;;   4.: Floating-Point Operate instructions.
;;
;;     (byte 6 26): opcode.
;;     (byte 5 21): Fa.
;;     (byte 5 16): Fb.
;;     (byte 11 5): Function.
;;     (byte 5 0): Fc.

(define-symbol-macro %%instruction-fp-operate-function (byte 11 5))

;;   5.: PALcode instructions.
;;
;;     (byte 6 26): opcode.
;;     (byte 26 0): PALcode Function.

(define-symbol-macro %%instruction-palcode-function (byte 26 0))


(defparameter *operand-column* 12)

(defvar *inta-instructions* nil)
(defvar *intl-instructions* nil)
(defvar *ints-instructions* nil)
(defvar *intm-instructions* nil)

(defun disassemble-unknown-opcode (instruction)
  (format t "<unknown>~vT~(~8,'0X~)" *operand-column* instruction))

(defvar *instruction-decode-table* (make-array 64 :initial-element #'disassemble-unknown-opcode))

(defmacro define-opcode (name (opcode &rest args) &body body)
  (let ((fname (intern (format nil "DISASSEMBLE-~A-OPCODE" name))))
    `(progn
       (defun ,fname ,args ,@body)
       (setf (aref *instruction-decode-table* ,opcode) #',fname))))

(defun disassemble-instruction (instruction)
  (funcall (aref *instruction-decode-table*
		 (ldb (byte 6 26) instruction))
	   instruction))

(defmacro define-unknown-opcode (name opcode)
  `(define-opcode ,name (,opcode instruction)
     (format t ,(format nil "~A~~vT~~(~~8,'0X~~)" name)
	     *operand-column* instruction)))

(defmacro define-memory-opcode (name opcode &optional floaty)
  `(define-opcode ,name (,opcode instruction)
     (format t ,(format nil "~A~~vT~C~~D,#x~~(~~X~~)(R~~D)"
			name (if floaty #\F #\R))
	     *operand-column*
	     (ldb (byte 5 21) instruction)
	     (sign-extend (ldb (byte 16 0) instruction) 16)
	     (ldb (byte 5 16) instruction))))

(defmacro define-integer-operate-opcode (name opcode)
  `(define-opcode ,name (,opcode instruction)
     (let ((function (getf ,(intern (format nil "*~A-INSTRUCTIONS*" name))
			   (ldb (byte 7 5) instruction))))
       (if (and function
		(or (logbitp 12 instruction)
		    (zerop (ldb (byte 3 13) instruction))))
	   (format t "~A~vTR~D,~A,R~D"
		   (car function)
		   *operand-column*
		   (ldb (byte 5 21) instruction)
		   (if (logbitp 12 instruction)
		       (format nil "~D" (ldb (byte 8 13) instruction))
		       (format nil "R~D" (ldb (byte 5 16) instruction)))
		   (ldb (byte 5 0) instruction))
	   (disassemble-unknown-opcode instruction)))))

;;(defmacro define-floating-operate-opcode (name opcode))

(defmacro define-branch-opcode (name opcode &optional floaty)
  `(define-opcode ,name (,opcode instruction)
     (format t ,(format nil "~A~~vT~C~~D,~~@D"
			name (if floaty #\F #\R))
	     *operand-column*
	     (ldb (byte 5 21) instruction)
	     (sign-extend (ldb (byte 21 0) instruction) 21))))

(defmacro define-operate-opcode-function (opcode function name)
  `(setf (getf ,(intern (format nil "*~A-INSTRUCTIONS*" opcode)) ,function)
	 '(,name)))

(define-opcode call-pal (#x00 instruction)
  ;; FIXME: Look up PALcode function names.
  (format t "CALL_PAL~vT~(~7,'0X~)" *operand-column*
	  (ldb (byte 26 0) instruction)))

(define-unknown-opcode opc01 #x01)
(define-unknown-opcode opc02 #x02)
(define-unknown-opcode opc03 #x03)
(define-unknown-opcode opc04 #x04)
(define-unknown-opcode opc05 #x05)
(define-unknown-opcode opc06 #x06)
(define-unknown-opcode opc07 #x07)

(define-memory-opcode lda #x08)
(define-memory-opcode ldah #x09)
(define-memory-opcode ldbu #x0a)
(define-memory-opcode ldq_u #x0b)
(define-memory-opcode ldwu #x0c)
(define-memory-opcode stw #x0d)
(define-memory-opcode stb #x0e)
(define-memory-opcode stq_u #x0f)

(define-integer-operate-opcode inta #x10)
(define-integer-operate-opcode intl #x11)
(define-integer-operate-opcode ints #x12)
(define-integer-operate-opcode intm #x13)
;;(define-dispatch-opcode itfp #x14 t)
;;(define-dispatch-opcode fltv #x15 t)
;;(define-dispatch-opcode flti #x16 t)
;;(define-dispatch-opcode fltl #x17 t)

(define-opcode misc (#x18 instruction)
  (let ((function (ldb (byte 16 0) instruction)))
    (case function
      (#x0000
       (format t "TRAPB"))
      (#x0400
       (format t "EXCB"))
      (#x4000
       (format t "MB"))
      (#x4400
       (format t "WMB"))
      (#x8000
       (format t "FETCH~vT(R~D)" *operand-column*
	       (ldb (byte 5 16) instruction)))
      (#xa000
       (format t "FETCH_M~vT(R~D)" *operand-column*
	       (ldb (byte 5 16) instruction)))
      (#xc000
       (format t "RPCC~vTR~D,R~D" *operand-column*
	       (ldb (byte 5 21) instruction)
	       (ldb (byte 5 16) instruction)))
      (#xe000
       (format t "RC~vT(R~D)" *operand-column*
	       (ldb (byte 5 21) instruction)))
      (#xe800
       (format t "ECB~vT(R~D)" *operand-column*
	       (ldb (byte 5 16) instruction)))
      (#xf000
       (format t "RS~vT(R~D)" *operand-column*
	       (ldb (byte 5 21) instruction)))
      (#xf800
       (format t "WH64~vT(R~D)" *operand-column*
	       (ldb (byte 5 16) instruction)))
      (#xfc00
       (format t "WH64EN~vT(R~D)" *operand-column*
	       (ldb (byte 5 16) instruction)))
      (t (format t "unknown misc function ~4,'0X R~D, R~D"
		 function (ldb (byte 5 21) instruction)
		 (ldb (byte 5 16) instruction))))))

;;(define-unknown-opcode pal19 #x19)

(define-opcode jmp (#x1a instruction)
  (let ((sub-op (ldb (byte 2 14) instruction))
	(hint (ldb (byte 14 0) instruction)))
    (format t "~A~vTR~D,(R~D),#x~X"
	    (elt '(jmp jsr ret jsr_coroutine) sub-op)
	    *operand-column*
	    (ldb (byte 5 21) instruction)
	    (ldb (byte 5 16) instruction)
	    hint)))

;;(define-unknown-opcode pal1b #x1b)
;;(define-dispatch-opcode fpti #x1c t)
;;(define-unknown-opcode pal1d #x1d)
;;(define-unknown-opcode pal1e #x1e)
;;(define-unknown-opcode pal1f #x1f)

(define-memory-opcode ldf #x20 t)
(define-memory-opcode ldg #x21 t)
(define-memory-opcode lds #x22 t)
(define-memory-opcode ldt #x23 t)
(define-memory-opcode stf #x24 t)
(define-memory-opcode stg #x25 t)
(define-memory-opcode sts #x26 t)
(define-memory-opcode stt #x27 t)

(define-memory-opcode ldl #x28)
(define-memory-opcode ldq #x29)
(define-memory-opcode ldl_l #x2a)
(define-memory-opcode ldq_l #x2b)
(define-memory-opcode stl #x2c)
(define-memory-opcode stq #x2d)
(define-memory-opcode stl_c #x2e)
(define-memory-opcode stq_c #x2f)

(define-branch-opcode br #x30)
(define-branch-opcode fbeq #x31 t)
(define-branch-opcode fblt #x32 t)
(define-branch-opcode fble #x33 t)
(define-branch-opcode bsr #x34)
(define-branch-opcode fbne #x35 t)
(define-branch-opcode fbge #x36 t)
(define-branch-opcode fbgt #x37 t)

(define-branch-opcode blbc #x38)
(define-branch-opcode beq #x39)
(define-branch-opcode blt #x3a)
(define-branch-opcode ble #x3b)
(define-branch-opcode blbs #x3c)
(define-branch-opcode bne #x3d)
(define-branch-opcode bge #x3e)
(define-branch-opcode bgt #x3f)

(define-operate-opcode-function inta #x00 addl)
(define-operate-opcode-function inta #x02 s4addl)
(define-operate-opcode-function inta #x09 subl)
(define-operate-opcode-function inta #x0b s4subl)
(define-operate-opcode-function inta #x0f cmpbge)
(define-operate-opcode-function inta #x12 s8addl)
(define-operate-opcode-function inta #x1b s8subl)
(define-operate-opcode-function inta #x1d cmpult)
(define-operate-opcode-function inta #x20 addq)
(define-operate-opcode-function inta #x22 s4addq)
(define-operate-opcode-function inta #x29 subq)
(define-operate-opcode-function inta #x2b s4subq)
(define-operate-opcode-function inta #x2d cmpeq)
(define-operate-opcode-function inta #x32 s8addq)
(define-operate-opcode-function inta #x3b s8subq)
(define-operate-opcode-function inta #x3d cmpule)
(define-operate-opcode-function inta #x40 addl/v)
(define-operate-opcode-function inta #x49 subl/v)
(define-operate-opcode-function inta #x4d cmplt)
(define-operate-opcode-function inta #x60 addq/v)
(define-operate-opcode-function inta #x69 subq/v)
(define-operate-opcode-function inta #x6d cmple)

(define-operate-opcode-function intl #x00 and)
(define-operate-opcode-function intl #x08 bic)
(define-operate-opcode-function intl #x14 cmovlbs)
(define-operate-opcode-function intl #x16 cmovlbc)
(define-operate-opcode-function intl #x20 bis)
(define-operate-opcode-function intl #x24 cmoveq)
(define-operate-opcode-function intl #x26 cmovne)
(define-operate-opcode-function intl #x28 ornot)
(define-operate-opcode-function intl #x40 xor)
(define-operate-opcode-function intl #x44 cmovlt)
(define-operate-opcode-function intl #x46 cmovge)
(define-operate-opcode-function intl #x48 eqv)
(define-operate-opcode-function intl #x61 amask) ;; Ra must be R31
(define-operate-opcode-function intl #x64 cmovle)
(define-operate-opcode-function intl #x66 cmovgt)
(define-operate-opcode-function intl #x6c implver) ;; Ra must be R31, Rb must be literal #1

(define-operate-opcode-function ints #x02 mskbl)
(define-operate-opcode-function ints #x06 extbl)
(define-operate-opcode-function ints #x0b insbl)
(define-operate-opcode-function ints #x12 mskwl)
(define-operate-opcode-function ints #x16 extwl)
(define-operate-opcode-function ints #x1b inswl)
(define-operate-opcode-function ints #x22 mskll)
(define-operate-opcode-function ints #x26 extll)
(define-operate-opcode-function ints #x2b insll)
(define-operate-opcode-function ints #x30 zap)
(define-operate-opcode-function ints #x31 zapnot)
(define-operate-opcode-function ints #x32 mskql)
(define-operate-opcode-function ints #x34 srl)
(define-operate-opcode-function ints #x36 extql)
(define-operate-opcode-function ints #x39 sll)
(define-operate-opcode-function ints #x3b insql)
(define-operate-opcode-function ints #x3c sra)
(define-operate-opcode-function ints #x52 mskwh)
(define-operate-opcode-function ints #x57 inswh)
(define-operate-opcode-function ints #x5a extwh)
(define-operate-opcode-function ints #x62 msklh)
(define-operate-opcode-function ints #x67 inslh)
(define-operate-opcode-function ints #x6a extlh)
(define-operate-opcode-function ints #x72 mskqh)
(define-operate-opcode-function ints #x77 insqh)
(define-operate-opcode-function ints #x7a extqh)

(define-operate-opcode-function intm #x00 mull)
(define-operate-opcode-function intm #x20 mulq)
(define-operate-opcode-function intm #x30 umulh)
(define-operate-opcode-function intm #x40 mull/v)
(define-operate-opcode-function intm #x60 mulq/v)

(defun disassemble-file-range (file offset length)
  (let ((buffer (make-array (* length 4) :element-type '(unsigned-byte 8)))
	(*operand-column* (+ *operand-column* 10)))
    (with-open-file (foo file :element-type '(unsigned-byte 8))
      (file-position foo offset)
      (read-sequence buffer foo))
    (dotimes (i length)
      (format t "~8,'0X: " (+ offset (* i 4)))
      (let ((instruction (logior (ash (aref buffer (+ (* i 4) 3)) 24)
				 (ash (aref buffer (+ (* i 4) 2)) 16)
				 (ash (aref buffer (+ (* i 4) 1))  8)
				 (ash (aref buffer (+ (* i 4) 0))  0))))
	(disassemble-instruction instruction)
	(terpri)))))

;;; 21164-specific PAL instructions.

(defparameter *ipr-names*
  '(
    ;; Ibox IPRs
    #x100 isr
    #x101 itb_tag
    #x102 itb_pte
    #x103 itb_asn
    #x104 itb_pte_temp
    #x105 itb_ia
    #x106 itb_iap
    #x107 itb_is
    #x108 sirr
    #x109 astrr
    #x10a aster
    #x10b exc_addr
    #x10c exc_sum
    #x10d exc_mask
    #x10e pal_base
    #x10f icm
    #x110 iplr
    #x111 intid
    #x112 ifault_va_form
    #x113 ivptbr
    #x115 hwint_clr
    #x116 sl_xmit
    #x117 sl_rcv
    #x118 icsr
    #x119 ic_flush_ctl
    #x11a icperr_stat
    #x11c pmctr

    ;; PALtemp IPRs
    #x140 |PALtemp0|
    #x141 |PALtemp1|
    #x142 |PALtemp2|
    #x143 |PALtemp3|
    #x144 |PALtemp4|
    #x145 |PALtemp5|
    #x146 |PALtemp6|
    #x147 |PALtemp7|
    #x148 |PALtemp8|
    #x149 |PALtemp9|
    #x14a |PALtemp10|
    #x14b |PALtemp11|
    #x14c |PALtemp12|
    #x14d |PALtemp13|
    #x14e |PALtemp14|
    #x14f |PALtemp15|
    #x150 |PALtemp16|
    #x151 |PALtemp17|
    #x152 |PALtemp18|
    #x153 |PALtemp19|
    #x154 |PALtemp20|
    #x155 |PALtemp21|
    #x156 |PALtemp22|
    #x157 |PALtemp23|

    ;; Mbox IPRs
    #x200 dtb_asn
    #x201 dtb_cm
    #x202 dtb_tag
    #x203 dtb_pte
    #x204 dtb_pte_temp
    #x205 mm_stat
    #x206 va
    #x207 va_form
    #x208 mvptbr
    #x209 dtb_iap
    #x20a dtb_ia
    #x20b dtb_is
    #x20c alt_mode
    #x20d cc
    #x20e cc_ctl
    #x20f mcsr
    #x210 dc_flush
    #x212 dc_perr_stat
    #x213 dc_test_ctl
    #x214 dc_test_tag
    #x215 dc_test_tag_temp
    #x216 dc_mode
    #x217 maf_mode
    ))

(define-opcode hw_mfpr (#x19 instruction)
  (let ((ipr (ldb (byte 16 0) instruction)))
    (format t "HW_MFPR~vTR~D, ~A"
	    *operand-column*
	    (ldb (byte 5 21) instruction)
	    (getf *ipr-names* ipr ipr))))

(define-opcode hw_ld (#x1b instruction)
  (format t "HW_LD~vTR~D,#x~X(R~D),~:[virt~;phys~],~:[long~;quad~]~@[,~{~(~A~)~#[~:;,~]~}~]"
	  *operand-column*
	  (ldb (byte 5 21) instruction)
	  (sign-extend (ldb (byte 10 0) instruction) 10)
	  (ldb (byte 5 16) instruction)
	  (logbitp 15 instruction) (logbitp 12 instruction)
	  `(,@(when (logbitp 14 instruction) '(alt))
	    ,@(when (logbitp 13 instruction) '(wrtck))
	    ,@(when (logbitp 11 instruction) '(vpte))
	    ,@(when (logbitp 10 instruction) '(lock)))))

(define-opcode hw_mtpr (#x1d instruction)
  (let ((ipr (ldb (byte 16 0) instruction)))
    (format t "HW_MTPR~vTR~D, ~A"
	    *operand-column*
	    (ldb (byte 5 21) instruction)
	    (getf *ipr-names* ipr ipr))))

(define-opcode hw_rei (#x1e instruction)
  (declare (ignore instruction))
  (format t "HW_REI"))

(define-opcode hw_st (#x1f instruction)
  (format t "HW_ST~vTR~D,#x~X(R~D),~:[virt~;phys~],~:[long~;quad~]~@[,~{~(~A~)~#[~:;,~]~}~]"
	  *operand-column*
	  (ldb (byte 5 21) instruction)
	  (sign-extend (ldb (byte 10 0) instruction) 10)
	  (ldb (byte 5 16) instruction)
	  (logbitp 15 instruction) (logbitp 12 instruction)
	  `(,@(when (logbitp 14 instruction) '(alt))
	    ,@(when (logbitp 10 instruction) '(cond)))))

;;; EOF
