;;;
;;; lameulator.lisp
;;;
;;; Lame emulator for Alphaserver800 and AXP 21164.
;;;

(cl:in-package :axp-tools)


;;; Memory access.

(defvar *memory-image*)

(defun init-memory-system ()
  ;; Minimum memory size is 32 megs (8 megs/DIMM) in bank 0 (of two banks).
  ;; Per as800 service guide, 6.2.2, page 111.

  ;; To make instruction fetch cheaper, memory is stored as an array
  ;; of (unsigned-byte 32) values.  (ash (ash 32 20) -2) => #x800000.
  (setf *memory-image* (make-array #x800000
				   :element-type '(unsigned-byte 32)
				   :initial-element 0))
  (values))

;; RAM is mapped starting at physical address 0, and that's all we
;; handle for right now.

(defun read-phys-memory-long (address &key (when-unmapped :return-zero))
  (let ((index (ash address -2)))
    (cond ((< index (length *memory-image*))
	   (aref *memory-image* index))
	  #+(or)
	  ((eq when-unmapped :return-zero)
	   (format t "Phys read [long] from #x~X unmapped, returning 0~%"
		   address)
	   0)
	  (t
	   (error "Memory read long, address #x~X, unmapped" address)))))

(defun write-phys-memory-long (address value)
  (let ((index (ash address -2)))
    (if (< index (length *memory-image*))
	(setf (aref *memory-image* index) value)
	(format t "Phys write [long] #x~8,'0X to #x~X unmapped, ignoring~%"
		value address))))

(defun read-phys-memory-quad (address)
  ;;(format t "rpmq: ~16,'0X~%" address)
  (cond
    ((<= #xfffff00000 address #xfffffffff8)
     ;; 21164 Cbox IPRs
     (case (logand address #xfffff)
       #+(or)
       (#x00068 ;; FILL_SYN
	)
       #+(or)
       (#x000a8 ;; SC_CTL
	)
       (#x000e8 ;; SC_STAT
	;; See 21164_hrm section 5.3.2 (page 262) for details.
	;; Just return as if no error occurred.
	0)
       #+(or)
       (#x00108 ;; BC_TAG_ADDR
	)
       #+(or)
       (#x00148 ;; EI_ADDR
	)
       (#x00168 ;; EI_STAT
	;; See 21164_hrm section 5.3.7 (page 281) for details.
	;; Just return as if no error occurred.
	(ldb (byte 64 0)
	     (dpb 4 (byte 12 24) -1)))
       #+(or)
       (#x00188 ;; SC_ADDR
	)
       (t
	(error "read from unknown/unhandled Cbox IPR #x~5,'0X"
	       (logand address #xfffff)))))
    (t
     (dpb (read-phys-memory-long (+ address 4))
	  (byte 32 32)
	  (read-phys-memory-long address)))))

(defun write-phys-memory-quad (address value)
  (cond
    ((<= #xfffff00000 address #xfffffffff8)
     ;; 21164 Cbox IPRs
     (case (logand address #xfffff)
       #+(or)
       (#x000a8 ;; SC_CTL
	)
       #+(or)
       (#x00128 ;; BC_CONTROL
	)
       #+(or)
       (#x001c8 ;; BC_CONFIG
	)
       (t
	(error "write ~16,'0X to unknown/unhandled Cbox IPR ~5,'0X"
	       value (logand address #xfffff)))))
    (t
     (write-phys-memory-long address (ldb (byte 32 0) value))
     (write-phys-memory-long (+ address 4) (ldb (byte 32 32) value)))))

(defun read-instruction (address)
  (read-phys-memory-long address :when-unmapped :error))


;;; CPU state.

(defvar *integer-regs* (make-array 31 :element-type '(unsigned-byte 64)))

(defparameter *instruction-emulators* (make-array 64 :initial-element nil))

(defvar *program-counter* 0)

(defvar *intr-flag* 0)

(defun ireg (num)
  "Read integer register NUM."
  (if (= num 31)
      0
      (aref *integer-regs* num)))

(defun (setf ireg) (val num)
  "Store VAL to integer register NUM."
  (if (= num 31)
      val
      (setf (aref *integer-regs* num) val)))

(defun ireg-a (instruction)
  (ireg (ldb (byte 5 21) instruction)))

(defun (setf ireg-a) (val instruction)
  (setf (ireg (ldb (byte 5 21) instruction)) val))

(defun ireg-b (instruction)
  (ireg (ldb (byte 5 16) instruction)))

(defun ireg-b-value (instruction)
  (if (logbitp 12 instruction)
      (ldb (byte 8 13) instruction)
      (ireg-b instruction)))

(defun (setf ireg-c) (val instruction)
  (setf (ireg (ldb (byte 5 0) instruction)) val))

(defun memory-offset (instruction)
  (sign-extend (ldb (byte 16 0) instruction) 16))

(defun branch-offset (instruction)
  (ash (sign-extend (ldb (byte 21 0) instruction) 21) 2))


;;; CPU Internal Processor Registers

;; This entire section is specific to the 21164.

(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
    )))

(defvar *pal-base* 0)
(defvar *pal-mode* 0)
(defvar *pal-temps* (make-array 24 :element-type '(unsigned-byte 64)))

(defvar *exc-addr* 0)

;; Memory fault information.
(defvar *mbox-va-locked* nil)
(defvar *mbox-mm-stat* 0)
(defvar *mbox-va* 0)
(defvar *mbox-va-form* 0)
(defvar *mbox-mvptbr* 0)

;; Dstream Translation Buffer storage.
(defvar *mbox-dtb-tags* (make-array #x40 :element-type '(unsigned-byte 30)))
(defvar *mbox-dtb-ptes* (make-array #x40 :element-type '(unsigned-byte 39)))
(defvar *mbox-dtb-asns* (make-array #x40 :element-type '(unsigned-byte 7)))
(defvar *mbox-dtb-misc* (make-array #x40 :element-type '(unsigned-byte 3)))
(defvar *mbox-dtb-valid* 0)

;; Dstream Translation Buffer controls.
(defvar *mbox-dtb-asn* 0
  "The current address space number?")
(defvar *mbox-dtb-cm* 0
  "The current control mode?")
(defvar *mbox-dtb-pointer* 0
  "The TB entry pointer.")
(defvar *mbox-dtb-pte* 0
  "The temporary storage location for PTEs written to the DTB.")
(defvar *mbox-dtb-pte-temp* 0
  "The temporary storage location for PTEs read from the DTB.")

(defun read-ipr (index)
  (let ((name (getf *ipr-names* index)))
    (format t "IPR read ~4,'0X [~A]" index name)
    (let ((result (case index
		    (#x10e ;; PAL_BASE
		     *pal-base*)

		    ((#x140 #x141 #x142 #x143 #x144 #x145 #x146 #x147
			    #x148 #x149 #x14a #x14b #x14c #x14d #x14e #x14f
			    #x150 #x151 #x152 #x153 #x154 #x155 #x156 #x157)
		     ;; PALtempNN (for NN from 0 through 23, inclusive)
		     (aref *pal-temps* (- index #x140)))

		    (#x203 ;; DTB_PTE
		     (setf *mbox-dtb-pte-temp*
			   (aref *mbox-dtb-ptes* *mbox-dtb-pointer*))
		     ;; XXX: What should this do for an invalid DTB entry?
		     (setf *mbox-dtb-pointer*
			   (logand #x3f (1+ *mbox-dtb-pointer*)))
		     0)
		    (#x204 ;; DTB_PTE_TEMP
		     *mbox-dtb-pte-temp*)
		    (#x205 ;; MM_STAT
		     *mbox-mm-stat*)
		    (#x206 ;; VA
		     (setf *mbox-va-locked* nil)
		     *mbox-va*)
		    (#x207 ;; VA_FORM
		     *mbox-va-form*))))
      (if result
	  (format t ", returning ~16,'0X~%" result)
	  (format t ", unsupported, returning 0~%"))
      (or result 0))))

(defun write-ipr (index value)
  (let ((name (getf *ipr-names* index)))
    (format t "IPR write ~16,'0X to ~4,'0X [~A]"
	    value index name)
    (case index
      (#x10e ;; PAL_BASE
       (setf *pal-base* (mask-field (byte 26 14) value)))

      ((#x140 #x141 #x142 #x143 #x144 #x145 #x146 #x147
	      #x148 #x149 #x14a #x14b #x14c #x14d #x14e #x14f
	      #x150 #x151 #x152 #x153 #x154 #x155 #x156 #x157)
       ;; PALtempNN (for NN from 0 through 23, inclusive)
       (setf (aref *pal-temps* (- index #x140)) value))

      (#x200 ;; DTB_ASN
       (setf *mbox-dtb-asn* (ldb (byte 7 57) value)))

      (#x201 ;; DTB_CM
       (setf *mbox-dtb-cm* (ldb (byte 2 3) value)))

      (#x202 ;; DTB_TAG
       (setf (aref *mbox-dtb-tags* *mbox-dtb-pointer*)
	     (ldb (byte 30 13) value))
       (setf (aref *mbox-dtb-ptes* *mbox-dtb-pointer*)
	     (logior (ash (mask-field (byte 2 1) *mbox-dtb-pte*) -1)
		     (ash (mask-field (byte 8 8) *mbox-dtb-pte*) -6)
		     (ash (mask-field (byte 27 32) *mbox-dtb-pte*) -19)))
       (setf (aref *mbox-dtb-misc* *mbox-dtb-pointer*)
	     (ldb (byte 3 4) *mbox-dtb-pte*))
       (setf (aref *mbox-dtb-asns* *mbox-dtb-pointer*) *mbox-dtb-asn*)
       (setf (logbitp *mbox-dtb-pointer* *mbox-dtb-valid*) t)
       (setf *mbox-dtb-pointer*
	     (logand #x3f (1+ *mbox-dtb-pointer*))))

      (#x203 ;; DTB_PTE
       (setf *mbox-dtb-pte* value))

      (#x208 ;; MVPTBR
       (setf *mbox-mvptbr* (mask-field (byte 34 30) value)))

      (#x209 ;; DTB_IAP
       ;; Invalidate all DTB entries where ASM bit is zero.
       (dotimes (i #x40)
	 (unless (logbitp 0 (aref *mbox-dtb-misc* i))
	   (setf (logbitp i *mbox-dtb-valid*) nil))))

      (#x20a ;; DTB_IA
       ;; Invalidate all DTB entries and reset pointer.
       (setf *mbox-dtb-valid* 0)
       (setf *mbox-dtb-pointer* 0))

      (#x20b ;; DTB_IS
       ;; FIXME: Invalidate DTB entry with tag matching (byte 30 13)
       ;; of value if the ASN field matches DTB_ASN or if the ASM bit
       ;; is set.
       )

      (t (format t ", ignored")))
    (terpri)))

(defun mbox-translate-addr (va instruction-bits)
  (flet ((fail (reason)
	   (unless *mbox-va-locked*
	     (setf *mbox-mm-stat* (dpb instruction-bits
				       (byte 11 6)
				       #x11))
	     (setf *mbox-va* va)
	     ;; FIXME: Set *mbox-va-form*
	     (setf *mbox-va-locked* t))
	   (enter-palmode reason)
	   (return-from mbox-translate-addr (values nil nil))))
    (let ((tag (ldb (byte 30 13) va)))
      ;; Check for matching PTE for address.
      (dotimes (i #x40 (fail :dtbmiss_single))
	(if (and (logbitp i *mbox-dtb-valid*)
		 (= (aref *mbox-dtb-tags* i) tag)
		 (or (logbitp 0 (aref *mbox-dtb-misc* i))
		     (= (aref *mbox-dtb-asns* i) *mbox-dtb-asn*)))
	    ;; Found matching PTE, check access permissions.
	    ;; FIXME: Check access permissions.
	    (return-from mbox-translate-addr
	      (values (dpb va (byte 13 0) (aref *mbox-dtb-ptes* i)) t)))))))

(defun init-mbox ()
  (setf *mbox-dtb-valid* 0)
  (setf *mbox-dtb-pointer* 0))

(defparameter *palmode-entry-addresses*
  '(:reset          #x000
    :iaccvio        #x080
    :interrupt      #x100
    :itbmiss        #x180
    :dtbmiss_single #x200
    :dtbmiss_double #x280
    :unalign        #x300
    :dfault         #x380
    :mchk           #x400
    :opdec          #x480
    :arith          #x500
    :fen            #x580))

;; This is the 21164 version of PALmode entry.
(defun enter-palmode (reason)
  ;; A bit of a hack, but should work so long as we see
  ;; already-incremented program counter values and the instruction
  ;; was not a branch (or, if it was a branch, we fault before
  ;; altering the program counter).
  (setf *exc-addr* (logior (- *program-counter* 4) *pal-mode*))
  (setf *pal-mode* 1)

  (cond
    ((and (symbolp reason)
	  (let ((entry (getf *palmode-entry-addresses* reason)))
	    (when entry
	      (setf *program-counter* (logior *pal-base* entry))))))

    ((integerp reason)
     ;; FIXME: Should use OPDEC entry if priv check fails.
     (let ((cpf-7 (ldb (byte 1 7) reason))
	   (cpf-5-0 (ldb (byte 6 0) reason)))
       ;; If we pass our priv check, we use -next- instruction as our
       ;; exception address.
       (incf *exc-addr* 4)
       (setf *program-counter* (logior *pal-base*
				       #x2000
				       (ash cpf-7 12)
				       (ash cpf-5-0 6)))))

    (t (error "Unknown palmode entry reason ~A" reason))))


;;; CPU instruction decoding and control logic.

(defmacro define-instruction ((mnemonic opcode) arglist &body body)
  (let ((fname (intern (format nil "EMULATE-~A-INSTRUCTION" mnemonic))))
    `(progn
       (defun ,fname ,arglist ,@body)
       (setf (aref *instruction-emulators* ,opcode) #',fname))))

(defun disassemble-current-instruction ()
  (let ((instruction (read-instruction *program-counter*)))
    (format t "~16,'0X " *program-counter*)
    (let ((*operand-column* 29))
      (disassemble-instruction instruction))
    (terpri)))

(defun cpu-step ()
  (let* ((instruction (read-instruction *program-counter*))
	 (emulator (aref *instruction-emulators*
			 (ldb (byte 6 26) instruction))))
    (disassemble-current-instruction)
    (let ((original-pc *program-counter*))
      (incf *program-counter* 4)
      (restart-case
	  (progn
	    (if emulator
		(funcall emulator instruction)
		(error "instruction ~8,'0x (opcode ~2,'0X) not found"
		       instruction (ldb (byte 6 26) instruction)))
	    (disassemble-current-instruction))
	(abort-instruction ()
	  (setf *program-counter* original-pc))))))

(defun cpu-run ()
  (loop
     (let* ((instruction (read-instruction *program-counter*))
	    (emulator (aref *instruction-emulators*
			    (ldb (byte 6 26) instruction))))
       (let ((original-pc *program-counter*))
	 (incf *program-counter* 4)
	 (restart-case
	     (if emulator
		 (funcall emulator instruction)
		 (error "instruction ~8,'0x (opcode ~2,'0X) not found"
			instruction (ldb (byte 6 26) instruction)))
	   (abort-instruction ()
	     (setf *program-counter* original-pc)
	     (disassemble-current-instruction)
	     (return-from cpu-run)))))))

(defun init-lameulator ()
  (init-memory-system)
  (init-mbox)
  (let* ((srm-file-data
	  (load-file-data "/home/nyef/Downloads/as800-roms/crsrmrom.exe"))
	 (srm-code (data-section srm-file-data #x240
				 (- (length srm-file-data) #x240))))
    (loop
       for offset from 0 below (length srm-code) by 4
       do (write-phys-memory-long (+ #x400000 offset)
				  (u32le@ srm-code offset))))
  (setf *pal-mode* 1)
  (setf *program-counter* #x400000))


;;; Single-reg value tests (used for branches and conditional moves).

(declaim (inline single-reg-test-lbs single-reg-test-lbc
		 single-reg-test-eq  single-reg-test-ne
		 single-reg-test-lt  single-reg-test-ge
		 single-reg-test-le  single-reg-test-gt))
(defun single-reg-test-lbs (value) (logbitp 0 value))
(defun single-reg-test-eq  (value) (zerop value))
(defun single-reg-test-lt  (value) (logbitp 63 value))
(defun single-reg-test-le  (value) (or (zerop value) (logbitp 63 value)))
(defun single-reg-test-lbc (value) (not (single-reg-test-lbs value)))
(defun single-reg-test-ne  (value) (not (single-reg-test-eq value)))
(defun single-reg-test-ge  (value) (not (single-reg-test-lt value)))
(defun single-reg-test-gt  (value) (not (single-reg-test-le value)))


;;; CPU instruction emulation.

(define-instruction (call_pal #x00) (instruction)
  (enter-palmode (ldb (byte 26 0) instruction)))

;; #x01 - #x07 are reserved for future expansion.

(define-instruction (lda #x08) (instruction)
  (setf (ireg-a instruction)
	(ldb (byte 64 0)
	     (+ (memory-offset instruction)
		(ireg-b instruction)))))

(define-instruction (ldah #x09) (instruction)
  (setf (ireg-a instruction)
	(ldb (byte 64 0)
	     (+ (ash (memory-offset instruction) 16)
		(ireg-b instruction)))))

;; #x0a is LDBU, a BWX instruction.

(define-instruction (ldq_u #x0b) (instruction)
  (multiple-value-bind
	(physaddr valid)
      (mbox-translate-addr (logandc2 (+ (ireg-b instruction)
					(memory-offset instruction))
				     7)
			   (ldb (byte 11 21) instruction))
    (when valid
      (setf (ireg-a instruction)
	    (read-phys-memory-quad physaddr)))))

;; #x0c is LDWU, a BWX instruction.

;; #x0d is STW, a BWX instruction.

;; #x0e is STB, a BWX instruction.

(define-instruction (stq_u #x0f) (instruction)
  (multiple-value-bind
	(physaddr valid)
      (mbox-translate-addr (logandc2 (+ (ireg-b instruction)
					(memory-offset instruction))
				     7)
			   (ldb (byte 11 21) instruction))
    (when valid
      (write-phys-memory-quad physaddr (ireg-a instruction)))))

(define-instruction (inta #x10) (instruction)
  (let ((function (ldb (byte 7 5) instruction))
	(a-value (ireg-a instruction))
	(b-value (ireg-b-value instruction)))
    (flet
	((longmath (result)
	   (ldb (byte 64 0) (sign-extend (ldb (byte 32 0) result) 32)))
	 (quadmath (result)
	   (ldb (byte 64 0) result))
	 (cmp (test signed)
	   (if (if signed
		   (funcall test (sign-extend a-value 64)
			    (sign-extend b-value 64))
		   (funcall test a-value b-value))
	       1
	       0)))
      (setf (ireg-c instruction)
	    (case function
	      (#x00 (longmath (+      a-value    b-value))) ;; ADDL
	      (#x02 (longmath (+ (ash a-value 2) b-value))) ;; S4ADDL
	      (#x09 (longmath (-      a-value    b-value))) ;; SUBL
	      (#x0b (longmath (- (ash a-value 2) b-value))) ;; S4SUBL
	      (#x12 (longmath (+ (ash a-value 3) b-value))) ;; S8ADDL
	      (#x1b (longmath (- (ash a-value 3) b-value))) ;; S8SUBL

	      (#x20 (quadmath (+      a-value    b-value))) ;; ADDQ
	      (#x22 (quadmath (+ (ash a-value 2) b-value))) ;; S4ADDQ
	      (#x29 (quadmath (-      a-value    b-value))) ;; SUBQ
	      (#x2b (quadmath (- (ash a-value 2) b-value))) ;; S4SUBQ
	      (#x32 (quadmath (+ (ash a-value 3) b-value))) ;; S8ADDQ
	      (#x3b (quadmath (- (ash a-value 3) b-value))) ;; S8SUBQ

	      #+(or)
	      (#x40 ) ;; ADDL/V
	      #+(or)
	      (#x49 ) ;; SUBL/V
	      #+(or)
	      (#x60 ) ;; ADDQ/V
	      #+(or)
	      (#x69 ) ;; SUBQ/V

	      (#x0f ;; CMPBGE
	       (let ((result 0))
		 (dotimes (i 8 result)
		   (setf (logbitp i result)
			 (>= (ldb (byte 8 (ash i 3)) a-value)
			     (ldb (byte 8 (ash i 3)) b-value))))))

	      (#x1d (cmp #'<  nil)) ;; CMPULT
	      (#x2d (cmp #'=  nil)) ;; CMPEQ
	      (#x3d (cmp #'<= nil)) ;; CMPULE
	      (#x4d (cmp #'<    t)) ;; CMPLT
	      (#x6d (cmp #'<=   t)) ;; CMPLE

	      (t (error "instruction ~8,'0x (INTA function ~2,'0x) not found"
			instruction function)))))))

(define-instruction (intl #x11) (instruction)
  (let ((function (ldb (byte 7 5) instruction))
	(a-value (ireg-a instruction))
	(b-value (ireg-b-value instruction)))
    (symbol-macrolet
	((negated-b-value (mask-field (byte 64 0) (lognot b-value))))
      (macrolet
	  ((cmov (condition)
	     `(progn
		(unless (,(intern (format nil "SINGLE-REG-TEST-~A" condition))
			  a-value)
		  (return-from emulate-intl-instruction))
		b-value)))
	;; There are three distinct groups of instructions here.
	;;   ALU logical operations (00, 08, 20, 28, 40, 48).
	;;   Conditional moves (14, 16, 24, 26, 44, 46, 64, 66).
	;;   Architecture queries (61, 6c).
	;;
	;; Bitfields!  Bitfields everywhere!
	;;
	;; If bit 2 is set and bit 3 is clear, it's a CMOV, as selected by
	;; bits 4-6 (bit 4 for the lowbit checker, bits 5 and 6 for the
	;; arithmetic relations) and sense polarity from bit 1.
	;;
	;; If bits 0, 2 and 3 are clear, it's an ALU operation, as
	;; selected by bits 5 and 6 and b-value inversion from bit 3.
	;;
	;; AMASK has bit 0 set, which is likely an enable.
	;;
	;; IMPLVER has bits 2 and 3 set, which is likely an enable.
	(setf (ireg-c instruction)
	      (case function
		(#x00 (logand a-value         b-value)) ;; AND
		(#x08 (logand a-value negated-b-value)) ;; BIC
		(#x20 (logior a-value         b-value)) ;; BIS
		(#x28 (logior a-value negated-b-value)) ;; ORNOT
		(#x40 (logxor a-value         b-value)) ;; XOR
		(#x48 (logxor a-value negated-b-value)) ;; EQV

		(#x14 (cmov lbs)) ;; CMOVLBS
		(#x16 (cmov lbc)) ;; CMOVLBC
		(#x24 (cmov  eq)) ;; CMOVEQ
		(#x26 (cmov  ne)) ;; CMOVNE
		(#x44 (cmov  lt)) ;; CMOVLT
		(#x46 (cmov  ge)) ;; CMOVGE
		(#x64 (cmov  le)) ;; CMOVLE
		(#x66 (cmov  gt)) ;; CMOVGT

		#+(or)
		(#x61 ;; AMASK
		 ;; FIXME: Implement.
		 )
		#+(or)
		(#x6c ;; IMPLVER
		 ;; FIXME: Implement.
		 )

		(t (error "instruction ~8,'0x (INTL function ~2,'0x) not found"
			  instruction function))))))))

(define-instruction (ints #x12) (instruction)
  (let ((function (ldb (byte 7 5) instruction))
	(a-value (ireg-a instruction))
	(b-value (ireg-b-value instruction)))
    (setf (ireg-c instruction)
	  (case function
	    (#x02 ;; MSKBL
	     (dpb 0       (byte 8  (ash (logand b-value 7) 3)) a-value))
	    (#x12 ;; MSKWL
	     (dpb 0       (byte 16 (ash (logand b-value 7) 3)) a-value))
	    (#x22 ;; MSKLL
	     (dpb 0       (byte 32 (ash (logand b-value 7) 3)) a-value))
	    (#x32 ;; MSKQL
	     (dpb 0       (byte 64 (ash (logand b-value 7) 3)) a-value))

	    (#x06 ;; EXTBL
	     (ldb         (byte 8  (ash (logand b-value 7) 3)) a-value))
	    (#x16 ;; EXTWL
	     (ldb         (byte 16 (ash (logand b-value 7) 3)) a-value))
	    (#x26 ;; EXTLL
	     (ldb         (byte 32 (ash (logand b-value 7) 3)) a-value))
	    (#x36 ;; EXTQL
	     (ldb         (byte 64 (ash (logand b-value 7) 3)) a-value))

	    (#x0b ;; INSBL
	     (dpb a-value (byte 8  (ash (logand b-value 7) 3)) 0))
	    (#x1b ;; INSWL
	     (dpb a-value (byte 16 (ash (logand b-value 7) 3)) 0))
	    (#x2b ;; INSLL
	     (dpb a-value (byte 32 (ash (logand b-value 7) 3)) 0))
	    (#x3b ;; INSQL
	     (dpb a-value (byte 64 (ash (logand b-value 7) 3)) 0))

	    (#x30 ;; ZAP
	     ;; See commentary for ZAPNOT
	     (let ((result a-value))
	       (dotimes (i 8 result)
		 (when (logbitp i b-value)
		   (setf (ldb (byte 8 (ash i 3)) result) 0)))))
	    (#x31 ;; ZAPNOT
	     ;; There's probably some clever way to do this in
	     ;; reasonable constant time, but this'll do for now.
	     (let ((result a-value))
	       (dotimes (i 8 result)
		 (unless (logbitp i b-value)
		   (setf (ldb (byte 8 (ash i 3)) result) 0)))))

	    (#x34 ;; SRL
	     (ash a-value (- b-value)))
	    (#x39 ;; SLL
	     (ldb (byte 64 0) (ash a-value b-value)))
	    (#x3c ;; SRA
	     (ldb (byte 64 0) (ash (sign-extend a-value 64) (- b-value))))

	    (t (error "instruction ~8,'0x (INTS function ~2,'0X) not found"
		      instruction function))))))

(define-instruction (intm #x13) (instruction)
  (let ((function (ldb (byte 7 5) instruction))
	(a-value (ireg-a instruction))
	(b-value (ireg-b-value instruction)))
    (setf (ireg-c instruction)
	  (case function
	    ;; #x00 ;; MULL
	    (#x20 ;; MULQ
	     (ldb (byte 64 0) (* a-value b-value)))
	    ;; #x30 ;; UMULH
	    ;; #x40 ;; MULL/V
	    ;; #x60 ;; MULQ/V
	    (t (error "instruction ~8,'0X (INTM function ~2,'0X) not found"
		      instruction function))))))

;; #x14 is ITFP group.

;; #x15 is FLTV group.

;; #x16 is FLTI group.

;; #x17 is FLTL group.

(define-instruction (misc #x18) (instruction)
  (let ((function (ldb (byte 16 0) instruction)))
    (case function
      (#x4000 ;; MB
       ;; Do nothing (memory barrier)
       )
      (#xe000 ;; RC
       (setf (ireg-a instruction) *intr-flag*)
       (setf *intr-flag* 0))
      (t (error "instruction ~8,'0X (MISC function ~4,'0X) not found"
		instruction function)))))

;; #x19 is PAL19, defined later.

(define-instruction (jmp #x1a) (instruction)
  (let ((target (ireg-b instruction)))
    (setf (ireg-a instruction) *program-counter*)
    (setf *program-counter* target)))

;; #x1b is PAL1B, defined later.

;; #x1c is FPTI group.

;; #x1d is PAL1D, defined later.

;; #x1e is PAL1E, defined later.

;; #x1f is PAL1F, defined later.

;; #x20 - #x27 are floating point loads and stores.

(define-instruction (ldl #x28) (instruction)
  (multiple-value-bind
	(physaddr valid)
      (mbox-translate-addr (+ (ireg-b instruction)
			      (memory-offset instruction))
			   (ldb (byte 11 21) instruction))
    (when valid
      (setf (ireg-a instruction)
	    (read-phys-memory-long physaddr)))))

(define-instruction (ldq #x29) (instruction)
  (multiple-value-bind
	(physaddr valid)
      (mbox-translate-addr (+ (ireg-b instruction)
			      (memory-offset instruction))
			   (ldb (byte 11 21) instruction))
    (when valid
      (setf (ireg-a instruction)
	    (read-phys-memory-quad physaddr)))))

;; #x2a is LDL_L.

;; #x2b is LDQ_L.

(define-instruction (stl #x2c) (instruction)
  (multiple-value-bind
	(physaddr valid)
      (mbox-translate-addr (+ (ireg-b instruction)
			      (memory-offset instruction))
			   (ldb (byte 11 21) instruction))
    (when valid
      (write-phys-memory-long physaddr (ldb (byte 32 0)
					    (ireg-a instruction))))))

(define-instruction (stq #x2d) (instruction)
  (multiple-value-bind
	(physaddr valid)
      (mbox-translate-addr (+ (ireg-b instruction)
			      (memory-offset instruction))
			   (ldb (byte 11 21) instruction))
    (when valid
      (write-phys-memory-quad physaddr (ireg-a instruction)))))

;; #x2e is STL_C.

;; #x2f is STQ_C.

(define-instruction (br #x30) (instruction)
  (setf (ireg-a instruction) *program-counter*)
  (incf *program-counter* (branch-offset instruction)))

;; #x31 is FBEQ.

;; #x32 is FBLT.

;; #x33 is FBLE.

(define-instruction (bsr #x34) (instruction)
  (setf (ireg-a instruction) *program-counter*)
  (incf *program-counter* (branch-offset instruction)))

;; #x35 is FBNE.

;; #x36 is FBGE.

;; #x37 is FBGT.

(macrolet ((define-branch-instruction (condition opcode)
	     (let ((fname (intern (format nil "B~A" condition)))
		   (test (intern (format nil "SINGLE-REG-TEST-~A" condition))))
	       `(define-instruction (,fname ,opcode) (instruction)
		  (when (,test (ireg-a instruction))
		    (incf *program-counter* (branch-offset instruction)))))))
  (define-branch-instruction lbc #x38)
  (define-branch-instruction eq  #x39)
  (define-branch-instruction lt  #x3a)
  (define-branch-instruction le  #x3b)
  (define-branch-instruction lbs #x3c)
  (define-branch-instruction ne  #x3d)
  (define-branch-instruction ge  #x3e)
  (define-branch-instruction gt  #x3f))

;;; These next instructions are specific to the 21164, and supposed to
;;; be PALmode (or kernel mode if ICSR<HWE> is set) only.

(define-instruction (pal19 #x19) (instruction)
  ;; HW_MFPR, see 21164_hrm, section 6.6.4 (page 305) for details.
  ;; See 21164_hrm, Table 5-1 (page 192) for index values.
  (format t "HW_MFPR: index ~4,'0X, R~D,R~D (#x~16,'0X)~%"
	  (ldb (byte 16 0) instruction)
	  (ldb (byte 5 21) instruction)
	  (ldb (byte 5 16) instruction)
	  (ireg-a instruction))
  (unless (= (ldb (byte 5 21) instruction)
	     (ldb (byte 5 16) instruction))
    (error "HW_MFPR: A/B register mismatch"))
  (setf (ireg-a instruction)
	(read-ipr (ldb (byte 16 0) instruction))))

(define-instruction (pal1b #x1b) (instruction)
  ;; HW_LD, see 21164_hrm, section 6.6.1 (page 302) for details.
  (format t "HW_LD: ~:[virt~;phys~] ~:[long~;quad~]~@[ ~{~(~A~)~#[~:;,~]~}~] R~D = #x~X(R~D)~%"
	  (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)))
	  (ldb (byte 5 21) instruction)
	  (sign-extend (ldb (byte 10 0) instruction) 10)
	  (ldb (byte 5 16) instruction))
  (cond 
    ((= #x00009000 (logand instruction #x0000fc00))
     (setf (ireg-a instruction)
	   (read-phys-memory-quad
	    (+ (ireg-b instruction)
	       (sign-extend (ldb (byte 10 0) instruction) 10)))))
    ((= #x00008000 (logand instruction #x0000fc00))
     (setf (ireg-a instruction)
	   (read-phys-memory-long
	    (+ (ireg-b instruction)
	       (sign-extend (ldb (byte 10 0) instruction) 10)))))
    (t
     (error "unsupported variant of HW_LD"))))

(define-instruction (pal1d #x1d) (instruction)
  ;; HW_MTPR, see 21164_hrm, section 6.6.4 (page 305) for details.
  ;; See 21164_hrm, Table 5-1 (page 192) for index values.
  (format t "HW_MTPR: index ~4,'0X, R~D,R~D (#x~16,'0X)~%"
	  (ldb (byte 16 0) instruction)
	  (ldb (byte 5 21) instruction)
	  (ldb (byte 5 16) instruction)
	  (ireg-a instruction))
  (unless (= (ldb (byte 5 21) instruction)
	     (ldb (byte 5 16) instruction))
    (error "HW_MTPR: A/B register mismatch"))
  (write-ipr (ldb (byte 16 0) instruction) (ireg-a instruction)))

(define-instruction (pal1e #x1e) (instruction)
  (declare (ignore instruction))
  ;; HW_REI, see 21164_hrm, section 6.6.3 (page 305) for details.
  (let ((target *exc-addr*))
    (setf *program-counter* (logandc2 target 3))
    (setf *pal-mode* (logand target 1))))

(define-instruction (pal1f #x1f) (instruction)
  ;; HW_ST, see 21164_hrm, section 6.6.2 (page 304) for details.
  (format t "HW_ST: ~:[virt~;phys~] ~:[long~;quad~]~@[ ~{~(~A~)~#[~:;,~]~}~] R~D = #x~X(R~D)~%"
	  (logbitp 15 instruction) (logbitp 12 instruction)
	  `(,@(when (logbitp 14 instruction) '(alt))
	    ,@(when (logbitp 10 instruction) '(cond)))
	  (ldb (byte 5 21) instruction)
	  (sign-extend (ldb (byte 10 0) instruction) 10)
	  (ldb (byte 5 16) instruction))
  (unless (zerop (logand instruction #x00002800))
    (error "HW_ST ~8,'0X with MBZ fields set" instruction))
  (case (ldb (byte 6 10) instruction)
    (#x24 ;; PHYS, QUAD.  Maybe also #x34 (ALT)?
     (write-phys-memory-quad (+ (ireg-b instruction)
				(sign-extend (ldb (byte 10 0) instruction) 10))
			     (ireg-a instruction)))
    (#x20 ;; PHYS, LONG.  Maybe also #x30 (ALT)?
     (write-phys-memory-long (+ (ireg-b instruction)
				(sign-extend (ldb (byte 10 0) instruction) 10))
			     (ireg-a instruction)))
    (t
     (error "unsupported variant of HW_ST"))))

;;; EOF