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

(cl:in-package :perry)
;;(cl:in-package :ev5-cpu)

;;; The 21164 was EV5.
;;; The 21164A was EV56, with BWX.
;;; The 21164PC was PCA56 and PCA57 (functionally equivalent), with BWX and MVI.

;;; The chipset for EV5 was Alcor (21171).
;;; The chipset for EV56 was Alcor-2 (21172).  (Maybe Alcor + BWX PCI space?)
;;; A later chipset was Pyxis (21174), maybe for PCA5[67]?


;;; CPU state.

(declaim (type (simple-array (unsigned-byte 64) (31))
	       *integer-regs* *floaty-regs*))
(defvar *integer-regs* (make-array 31 :element-type '(unsigned-byte 64)))
(defvar *floaty-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)

(defvar *fp-control* 0)

;; These are all simple accessors.  The more inline they are, the
;; better.
(declaim (inline ireg   (setf ireg)   freg   (setf freg)
		 ireg-a (setf ireg-a) freg-a (setf freg-a)
		 ireg-b ireg-b-value  freg-b
		 ireg-c (setf ireg-c) freg-c (setf freg-c)
		 memory-offset branch-offset))

(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 freg (num)
  "Read floating register NUM."
  (if (= num 31)
      0
      (aref *floaty-regs* num)))

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

;; These next functions are all parameterized on an instruction field.

(defun ireg-a (instruction)
  (ireg (ldb %%instruction-ra instruction)))

(defun (setf ireg-a) (val instruction)
  (setf (ireg (ldb %%instruction-ra instruction)) val))

(defun freg-a (instruction)
  (freg (ldb %%instruction-ra instruction)))

(defun (setf freg-a) (val instruction)
  (setf (freg (ldb %%instruction-ra instruction)) val))

(defun ireg-b (instruction)
  (ireg (ldb %%instruction-rb instruction)))

(defun ireg-b-value (instruction)
  (if (logbitp %%instruction-operate-register-flag-bit instruction)
      (ldb %%instruction-rb instruction)
      (ireg-b instruction)))

(defun freg-b (instruction)
  (freg (ldb %%instruction-rb instruction)))

(defun ireg-c (instruction)
  "For testing purposes; emulation never does this."
  (ireg (ldb %%instruction-rc instruction)))

(defun (setf ireg-c) (val instruction)
  (setf (ireg (ldb %%instruction-rc instruction)) val))

(defun freg-c (instruction)
  "For testing purposes; emulation never does this."
  (freg (ldb %%instruction-rc instruction)))

(defun (setf freg-c) (val instruction)
  (setf (freg (ldb %%instruction-rc instruction)) val))

(defun memory-offset (instruction)
  (sign-extend (ldb %%instruction-memory-disp instruction) 16))

(defun branch-offset (instruction)
  (ash (sign-extend (ldb %%instruction-branch-disp instruction) 21) 2))


;;; CPU Internal Processor Registers

;; This entire section is specific to the 21164.

(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.")
(defvar *mbox-alt-mode* 0
  "The alternate control mode?")

;; Mbox Control Register.
(defvar *mbox-mcsr* 0
  "The Mbox Control Register.")

(defun read-ipr (index)
  (let ((name (getf *ipr-names* index)))
    (format t "IPR read ~4,'0X [~A]" index name)
    (let ((result (case index
		    (#x10b ;; EXC_ADDR
		     *exc-addr*)

		    (#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
      (#x10b ;; EXC_ADDR
       (setf *exc-addr* (logandc2 value 2)))

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

      (#x20c ;; ALT_MODE
       (setf *mbox-alt-mode* (ldb (byte 2 3) value)))

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


;;; PALmode entry.

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


;;; Address translation.

(defun mbox-translate-addr (va instruction-bits mode vpte-fetch)
  (declare (ignore mode))
  (flet ((fail (reason)
	   (unless *mbox-va-locked*
	     (setf *mbox-mm-stat* (dpb instruction-bits
				       (byte 11 6)
				       #x11))
	     (setf *mbox-va* va)
	     (setf *mbox-va-form*
		   (if (logbitp 1 *mbox-mcsr*)
		       ;; NT_Mode enabled.
		       (dpb (ldb (byte 19 13) va)
			    (byte 19 3)
			    *mbox-mvptbr*)
		       ;; NT_Mode disabled.
		       (dpb (ldb (byte 30 13) va)
			    (byte 30 3)
			    *mbox-mvptbr*)))
	     (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 (if vpte-fetch :dtbmiss_double :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)))))))

(defmacro with-mbox-translation ((physaddr valid) (instruction &key unmask)
				 &body body)
  `(multiple-value-bind (,physaddr ,valid)
       (mbox-translate-addr (logandc2 (+ (ireg-b ,instruction)
					 (memory-offset ,instruction))
				      ,(or unmask 0))
			    (ldb (byte 11 21) ,instruction)
			    *mbox-dtb-cm* nil)
     ,@body))

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


;;; Memory access.

(declaim (inline read-phys-memory-long))
(defun read-phys-memory-long (address)
  (alcor-2:cpu-read-long address))

(declaim (inline write-phys-memory-long))
(defun write-phys-memory-long (address value)
  (alcor-2:cpu-write-long address value))

(defun read-phys-memory-quad (address)
  ;;(format t "rpmq: ~16,'0X~%" address)
  (cond
    ((<= #xfffff00000 address #xfffffffff8)
     ;; 21164 Cbox IPRs
     (case (logand address #xfffff)
       (#x00068 ;; FILL_SYN
	;; Hack, syndrome of 0000 means no error.
	0)
       (#x000a8 ;; SC_CTL
	;; Hack, 64 byte cache blocks, all three Scache sets enabled.
	#x00000f00)
       (#x000e8 ;; SC_STAT
	;; See 21164_hrm section 5.3.2 (page 262) for details.
	;; Just return as if no error occurred.
	0)
       (#x00108 ;; BC_TAG_ADDR
	;; Hack, return all non-RAO fields as zero.
	#xffffff00000c0fff)
       (#x00148 ;; EI_ADDR
	;; Hack, return EI_ADDR of 0, other fields are all RAO.
	#xffffff000000000f)
       (#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)))
       (#x00188 ;; SC_ADDR
	;; Hack, return SC_ADDR of 0, other fields are all RAZ or RAO.
	#xffffff000000000f)
       (#x001e8 ;; UNDOCUMENTED Cbox IPR?
	;; FIXME: Find out more about this?
	0)
       (t
	(error "read from unknown/unhandled Cbox IPR #x~5,'0X"
	       (logand address #xfffff)))))
    (t
     (alcor-2:cpu-read-quad 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
     (alcor-2:cpu-write-quad address value))))

;;(declaim (inline read-instruction))
(defun read-instruction (address)
  (if (zerop *pal-mode*)
      (error "IFetch while not in PALMode")
      (read-phys-memory-long address)))


;;; 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
	 (declare (type (unsigned-byte 32) ,(first 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 ()
  (alcor-2:init-alcor-2)
  (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)))


;;; EOF
