;;;
;;; cpu-instructions.lisp
;;;
;;; Alpha CPU instruction emulation.
;;;

(cl:in-package :perry)


;;; 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)
  (with-mbox-translation (physaddr valid) (instruction :unmask 7)
    (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)
  (with-mbox-translation (physaddr valid) (instruction :unmask 7)
    (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)))
    (labels (;; All this mess for byte-manipulation instructions.
	     (shift-amount ()
	       (ash (if (logbitp 4 *mbox-mcsr*) ;; 21164 E_BIG_ENDIAN
			(logxor 7 (logand b-value 7))
			(logand b-value 7))
		    3))
	     (low-byte (width function)
	       (let* ((pos (shift-amount))
		      (size (- (min (+ pos width) 64) pos)))
		 (funcall function size pos)))
	     (high-byte (width default function)
	       (let* ((pos (shift-amount))
		      (size (- (+ pos width) 64)))
		 (if (> size 0)
		     (funcall function size (- width size))
		     default)))
	     (insert-low (size pos) (dpb a-value (byte size pos) 0))
	     (extract-low (size pos) (ldb (byte size pos) a-value))
	     (insert-high (size pos) (ldb (byte size pos) a-value))
	     (extract-high (size pos) (dpb a-value (byte size pos) 0))
	     (mask-low (size pos)
	       (dpb 0 (byte size pos) a-value))
	     (mask-high (size pos)
	       (declare (ignore pos))
	       (dpb 0 (byte size 0) a-value)))
      (setf (ireg-c instruction)
	    (case function
	      (#x02 (low-byte  8 #'mask-low)) ;; MSKBL
	      (#x12 (low-byte 16 #'mask-low)) ;; MSKWL
	      (#x22 (low-byte 32 #'mask-low)) ;; MSKLL
	      (#x32 (low-byte 64 #'mask-low)) ;; MSKQL

	      (#x06 (low-byte  8 #'extract-low)) ;; EXTBL
	      (#x16 (low-byte 16 #'extract-low)) ;; EXTWL
	      (#x26 (low-byte 32 #'extract-low)) ;; EXTLL
	      (#x36 (low-byte 64 #'extract-low)) ;; EXTQL

	      (#x0b (low-byte  8 #'insert-low)) ;; INSBL
	      (#x1b (low-byte 16 #'insert-low)) ;; INSWL
	      (#x2b (low-byte 32 #'insert-low)) ;; INSLL
	      (#x3b (low-byte 64 #'insert-low)) ;; INSQL

	      (#x52 (high-byte 16 a-value #'mask-high)) ;; MSKWH
	      (#x62 (high-byte 32 a-value #'mask-high)) ;; MSKLH
	      (#x72 (high-byte 64 a-value #'mask-high)) ;; MSKQH

	      (#x5a (high-byte 16 0 #'extract-high)) ;; EXTWH
	      (#x6a (high-byte 32 0 #'extract-high)) ;; EXTLH
	      (#x7a (high-byte 64 0 #'extract-high)) ;; EXTQH

	      (#x57 (high-byte 16 0 #'insert-high)) ;; INSWH
	      (#x67 (high-byte 32 0 #'insert-high)) ;; INSLH
	      (#x77 (high-byte 64 0 #'insert-high)) ;; INSQH

	      (#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
	       ;; The function codes for this opcode have all been
	       ;; implemented.  This could plausibly be changed to
	       ;; start OPDEC processing.  Or, per the UNPREDICTABLE
	       ;; behavior specification from the archref, continue on
	       ;; with some random value.
	       (error "instruction ~8,'0x (INTS function ~2,'0X) not found"
		      instruction function)))))))

(defparameter *byte-manipulation-test-data*
  '((#x48001041 #xffffffffffffffff #xffffffffffffff00 "MSKBL-R0,0,R1-1")
    (#x48003041 #xffffffffffffffff #xffffffffffff00ff "MSKBL-R0,1,R1-1")
    (#x4800f041 #xffffffffffffffff #x00ffffffffffffff "MSKBL-R0,7,R1-1")

    (#x48001241 #xffffffffffffffff #xffffffffffff0000 "MSKWL-R0,0,R1-1")
    (#x48003241 #xffffffffffffffff #xffffffffff0000ff "MSKWL-R0,1,R1-1")
    (#x4800f241 #xffffffffffffffff #x00ffffffffffffff "MSKWL-R0,7,R1-1")

    (#x48001441 #xffffffffffffffff #xffffffff00000000 "MSKLL-R0,0,R1-1")
    (#x48003441 #xffffffffffffffff #xffffff00000000ff "MSKLL-R0,1,R1-1")
    (#x4800d441 #xffffffffffffffff #x0000ffffffffffff "MSKLL-R0,6,R1-1")

    (#x48001641 #xffffffffffffffff #x0000000000000000 "MSKQL-R0,0,R1-1")
    (#x48003641 #xffffffffffffffff #x00000000000000ff "MSKQL-R0,1,R1-1")
    (#x4800f641 #xffffffffffffffff #x00ffffffffffffff "MSKQL-R0,7,R1-1")

    (#x48001a41 #xffffffffffffffff #xffffffffffffffff "MSKWH-R0,0,R1-1")
    (#x4800da41 #xffffffffffffffff #xffffffffffffffff "MSKWH-R0,6,R1-1")
    (#x4800fa41 #xffffffffffffffff #xffffffffffffff00 "MSKWH-R0,7,R1-1")

    (#x48001c41 #xffffffffffffffff #xffffffffffffffff "MSKLH-R0,0,R1-1")
    (#x48003c41 #xffffffffffffffff #xffffffffffffffff "MSKLH-R0,1,R1-1")
    (#x4800dc41 #xffffffffffffffff #xffffffffffff0000 "MSKLH-R0,6,R1-1")

    (#x48001e41 #xffffffffffffffff #xffffffffffffffff "MSKQH-R0,0,R1-1")
    (#x48003e41 #xffffffffffffffff #xffffffffffffff00 "MSKQH-R0,1,R1-1")
    (#x4800fe41 #xffffffffffffffff #xff00000000000000 "MSKQH-R0,7,R1-1")

    (#x48001161 #xffffffffffffffff #x00000000000000ff "INSBL-R0,0,R1-1")
    (#x48009161 #xffffffffffffffff #x000000ff00000000 "INSBL-R0,4,R1-1")
    (#x48009161 #x000000000000005a #x0000005a00000000 "INSBL-R0,4,R1-2")
    (#x4800f161 #xffffffffffffffff #xff00000000000000 "INSBL-R0,7,R1-1")

    (#x48001361 #x0123456789abcdef #x000000000000cdef "INSWL-R0,0,R1-1")
    (#x4800f361 #x0123456789abcdef #xef00000000000000 "INSWL-R0,7,R1-1")

    (#x48001561 #x0123456789abcdef #x0000000089abcdef "INSLL-R0,0,R1-1")
    (#x48009561 #x0123456789abcdef #x89abcdef00000000 "INSLL-R0,4,R1-1")
    (#x4800f561 #x0123456789abcdef #xef00000000000000 "INSLL-R0,7,R1-1")

    (#x48001761 #x0123456789abcdef #x0123456789abcdef "INSQL-R0,0,R1-1")
    (#x48003761 #x0123456789abcdef #x23456789abcdef00 "INSQL-R0,1,R1-1")
    (#x4800f761 #x0123456789abcdef #xef00000000000000 "INSQL-R0,7,R1-1")

    (#x48001ae1 #x0123456789abcdef #x0000000000000000 "INSWH-R0,0,R1-1")
    (#x4800fae1 #x0123456789abcdef #x00000000000000cd "INSWH-R0,7,R1-1")

    (#x48001ce1 #xfedcba9876543210 #x0000000000000000 "INSLH-R0,0,R1-1")
    (#x48009ce1 #xfedcba9876543210 #x0000000000000000 "INSLH-R0,4,R1-1")
    (#x4800bce1 #xfedcba9876543210 #x0000000000000076 "INSLH-R0,5,R1-1")
    (#x4800fce1 #xfedcba9876543210 #x0000000000765432 "INSLH-R0,7,R1-1")

    (#x48001ee1 #xfedcba9876543210 #x0000000000000000 "INSQH-R0,0,R1-1")
    (#x48003ee1 #xfedcba9876543210 #x00000000000000fe "INSQH-R0,1,R1-1")
    (#x4800fee1 #xfedcba9876543210 #x00fedcba98765432 "INSQH-R0,7,R1-1")

    (#x480010c1 #xfedcba9876543210 #x0000000000000010 "EXTBL-R0,0,R1-1")
    (#x480030c1 #xfedcba9876543210 #x0000000000000032 "EXTBL-R0,1,R1-1")
    (#x4800f0c1 #xfedcba9876543210 #x00000000000000fe "EXTBL-R0,7,R1-1")

    (#x480012c1 #xfedcba9876543210 #x0000000000003210 "EXTWL-R0,0,R1-1")
    (#x480032c1 #xfedcba9876543210 #x0000000000005432 "EXTWL-R0,1,R1-1")
    (#x4800d2c1 #xfedcba9876543210 #x000000000000fedc "EXTWL-R0,6,R1-1")
    (#x4800f2c1 #xfedcba9876543210 #x00000000000000fe "EXTWL-R0,7,R1-1")

    (#x480014c1 #xfedcba9876543210 #x0000000076543210 "EXTLL-R0,0,R1-1")
    (#x480094c1 #xfedcba9876543210 #x00000000fedcba98 "EXTLL-R0,4,R1-1")
    (#x4800b4c1 #xfedcba9876543210 #x0000000000fedcba "EXTLL-R0,5,R1-1")
    (#x4800f4c1 #xfedcba9876543210 #x00000000000000fe "EXTLL-R0,7,R1-1")

    (#x480016c1 #xfedcba9876543210 #xfedcba9876543210 "EXTQL-R0,0,R1-1")
    (#x480036c1 #xfedcba9876543210 #x00fedcba98765432 "EXTQL-R0,1,R1-1")
    (#x4800f6c1 #xfedcba9876543210 #x00000000000000fe "EXTQL-R0,7,R1-1")

    (#x48001b41 #x0123456789abcdef #x0000000000000000 "EXTWH-R0,0,R1-1")
    (#x4800db41 #x0123456789abcdef #x0000000000000000 "EXTWH-R0,6,R1-1")
    (#x4800fb41 #x0123456789abcdef #x000000000000ef00 "EXTWH-R0,7,R1-1")

    (#x48001d41 #x0123456789abcdef #x0000000000000000 "EXTLH-R0,0,R1-1")
    (#x48009d41 #x0123456789abcdef #x0000000000000000 "EXTLH-R0,4,R1-1")
    (#x4800bd41 #x0123456789abcdef #x00000000ef000000 "EXTLH-R0,5,R1-1")
    (#x4800fd41 #x0123456789abcdef #x00000000abcdef00 "EXTLH-R0,7,R1-1")

    (#x48001f41 #x0123456789abcdef #x0000000000000000 "EXTQH-R0,0,R1-1")
    (#x48003f41 #x0123456789abcdef #xef00000000000000 "EXTQH-R0,1,R1-1")
    (#x4800ff41 #x0123456789abcdef #x23456789abcdef00 "EXTQH-R0,7,R1-1")))

(defun test-byte-manipulation-instructions ()
  (let ((success 0)
	(failure 0))
    (dolist (test *byte-manipulation-test-data*)
      (destructuring-bind (instruction a-value c-value name) test
	(setf (ireg-a instruction) a-value)
	(handler-case
	    (progn
	      (emulate-ints-instruction instruction)
	      (if (= (ireg-c instruction) c-value)
		  (incf success)
		  (progn
		    (incf failure)
		    (format t "Test failure: Test ~S, got ~16,'0X~%"
			    name (ireg-c instruction)))))
	  (error (var)
	    (incf failure)
	    (format t "Test failure: Test ~S, caught ~A~%" name var)))))
    (format t "Test results: ~A/~A tests passed.~%"
	    success (+ success failure))))

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

(define-instruction (fltl #x17) (instruction)
  (let ((function (ldb (byte 11 5) instruction)))
    (case function
      ;; #x010 ;; CVTLQ
      ;; #x020 ;; CPYS
      ;; #x021 ;; CPYSN
      ;; #x022 ;; CPYSE
      ;; #x024 ;; MT_FPCR
      (#x025 ;; MF_FPCR
       ;; Fa, Fb and Fc are supposed to be the same register.  There
       ;; are a pile of UNPREDICTABLE things that can happen if they
       ;; aren't.
       (setf (freg-c instruction)
	     *fp-control*))
      ;; #x02a ;; FCMOVEQ
      ;; #x02b ;; FCMOVNE
      ;; #x02c ;; FCMOVLT
      ;; #x02d ;; FCMOVGE
      ;; #x02e ;; FCMOVLE
      ;; #x02f ;; FCMOVGT
      ;; #x030 ;; CVTQL
      ;; #x130 ;; CVTQL/V
      ;; #x530 ;; CVTQL/SV
      (t (error "instruction ~8,'0X (FLTL function ~3,'0X) not found"
		instruction function)))))

(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 (stt #x27) (instruction)
  (with-mbox-translation (physaddr valid) (instruction)
    (when valid
      (write-phys-memory-quad physaddr (freg-a instruction)))))

(define-instruction (ldl #x28) (instruction)
  (with-mbox-translation (physaddr valid) (instruction)
    (when valid
      (setf (ireg-a instruction)
	    (read-phys-memory-long physaddr)))))

(define-instruction (ldq #x29) (instruction)
  (with-mbox-translation (physaddr valid) (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)
  (with-mbox-translation (physaddr valid) (instruction)
    (when valid
      (write-phys-memory-long physaddr
			      (ldb (byte 32 0)
				   (ireg-a instruction))))))

(define-instruction (stq #x2d) (instruction)
  (with-mbox-translation (physaddr valid) (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.
  #+(or)
  (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))
  (let ((address (+ (ireg-b instruction)
		    (sign-extend (ldb (byte 10 0) instruction) 10))))
    (case (ldb (byte 6 10) instruction)
      ;; If the instruction flags are #x20 - #x3f, bitmask #x1a are
      ;; don't-cares (translation flags).
      (#x24 ;; PHYS, QUAD.  Maybe also #x34 (ALT)?
       (setf (ireg-a instruction)
	     (read-phys-memory-quad address)))
      (#x20 ;; PHYS, LONG.  Maybe also #x30 (ALT)?
       (setf (ireg-a instruction)
	     (read-phys-memory-long address)))
      (#x16 ;; VIRT, QUAD, ALT, VPTE.
       (multiple-value-bind
	     (physaddr valid)
	   (mbox-translate-addr address (ldb (byte 11 21) instruction)
				(if (logbitp 14 instruction)
				    *mbox-alt-mode*
				    *mbox-dtb-cm*)
				(logbitp 11 instruction))
	 (if valid
	   (setf (ireg-a instruction)
		 (read-phys-memory-quad physaddr)))))
      (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.
  #+(or)
  (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
