;;;
;;; raven-microengine.lisp
;;;
;;; CPU Microcode interpreter.
;;;

(in-package :nevermore)

(defun microengine-initialize ()
  (setf *micro-instruction-pointer* 0)
  (setf *inhibit-micro-execution* t))

;; FIXME: May want to be in a different file (raven-conditions.lisp?)
(defun interpret-condition (opword m-source a-source &optional (alu-result 0) (fixnum-overflow 0))
  (eq (= 0 (ldb (byte 1 15) opword))
      (if (= 0 (ldb (byte 1 14) opword))
	  (case (ldb (byte 4 10) opword)
	    (0 ;; bit-set
	     (let ((rotation (ldb (byte 5 0) opword)))
	       (= 1 (if (= 1 (ldb (byte 1 16) opword))
			(ldb (byte 1 rotation) m-source)
		      (if (= rotation 0)
			  (ldb (byte 1 0) m-source)
			(ldb (byte 1 (- 32 rotation)) m-source))))))
	    (1 ;; less
	     (< (logxor #x80000000 m-source)
		(logxor #x80000000 a-source)))
	    (2 ;; less-or-equal
	     #+nil(= 1 (ldb (byte 1 32) alu-result))
	     (not (> (logxor #x80000000 m-source)
		     (logxor #x80000000 a-source))))
	    (3 ;; not-equal
	     ;; Cheap hack for M+1 IF-NOT-EQUAL AND-SKIP having to not skip.
	     (if (= (logand opword #xc00000000000f8) #xe0)
		 nil
	       (not (= m-source a-source))))
	    (4 ;; page-fault
	     *page-fault*)
	    (5 ;; page-fault-or-interrupt
	     (or *page-fault* *interrupt-pending*))
	    (6 ;; page-fault-or-interrupt-or-sequence-break
	     (or *page-fault* *interrupt-pending* (/= 0 (logand #x4000 *machine-control-register*))))
	    (7 ;; true
	     t)
	    (8 ;; tag-not-equal
	     (/= (ldb (byte 5 25) m-source)
		 (ldb (byte 5 25) a-source)))
	    (9 ;; not-memory-busy
	     (zerop *memory-busy*))
	    (10 ;; q0
	     (oddp *q-register*))
	    (11 ;; nu-bus-error
	     *nubus-error*)
	    (12 ;; not-fixnum-overflow
	     (= 0 fixnum-overflow))
	    (13 ;; boxed-sign-bit
	     (= #x01000000 (logand #x01000000 alu-result)))
	    (14 ;; no-interrupt
	     (not *interrupt-pending*))
	    (t ;; Unhandled or bogus
	     (format t "Unhandled condition.~%")
	     ))

	;; Look up the tag-memory contents for this index.
	(= 1 (read-t-memory (ldb (byte 4 10) opword) m-source)))))

(defun interpret-abj (opword)
  (case (ldb (byte 3 51) opword)
    (0 ;; Nop
     )
    (1 ;; Skip
     (setf *inhibit-micro-execution* t))
    (2 ;; Call-Illop
     (write-functional-destination 5 (- *micro-instruction-pointer* 1))
     (setf *micro-instruction-pointer* #o10)
     (setf *inhibit-micro-execution* t))
    (3 ;; Call-Trap
     (write-functional-destination 5 (- *micro-instruction-pointer* 1))
     (setf *micro-instruction-pointer* #o12)
     (setf *inhibit-micro-execution* t))
    (4 ;; Call-Buserr
     (write-functional-destination 5 (- *micro-instruction-pointer* 1))
     (setf *micro-instruction-pointer* #o14)
     (setf *inhibit-micro-execution* t))
    (5 ;; "Unused"
     (write-functional-destination 5 (- *micro-instruction-pointer* 1))
     (setf *micro-instruction-pointer* #o16)
     (setf *inhibit-micro-execution* t))
    (6 ;; Popj
     (setf *micro-instruction-pointer* (read-functional-source #o21))
     (setf *inhibit-micro-execution* t))
    (7 ;; Popj-after-next
     (setf *micro-instruction-pointer* (read-functional-source #o21)))
    (t ;; Unimplemented
     (format t "Error dispatching ABJ instruction.~%"))))

;; FIXME: This belongs in raven-alu.lisp
(defun perform-alu-operation (opword m-source a-source &aux alu-result fixnum-overflow)
  (setf fixnum-overflow 0)
  (setf alu-result
	(case (ldb (byte 5 3) opword)
	  (0 ;; SETZ
	   0)
	  (1 ;; AND
	   (logand m-source a-source))
	  (2 ;; ANDCA
	   (logand m-source (logxor a-source #xffffffff)))
	  (3 ;; SETM
	   m-source)
	  (4 ;; ANDCM
	   (logand (logxor m-source #xffffffff) a-source))
	  (5 ;; SETA
	   a-source)
	  (6 ;; XOR
	   (logxor m-source a-source))
	  (7 ;; IOR
	   (logior m-source a-source))
	  (#o10 ;; ANDCB
	   (logand (logxor m-source #xffffffff)
		   (logxor a-source #xffffffff)))
	  (#o11 ;; EQV
	   m-source) ;; FIXME: Should be A=M (whatever that means)
	  (#o12 ;; SETCA
	   (logxor a-source #xffffffff))
	  (#o13 ;; ORCA
	   (logior m-source (logxor a-source #xffffffff)))
	  (#o14 ;; SETCM
	   (logxor m-source #xffffffff))
	  (#o15 ;; ORCM
	   (logior (logxor m-source #xffffffff) a-source))
	  (#o17 ;; SETO
	   #xffffffff)
	  (#o20 ;; MUL
	   (if (oddp *q-register*)
	       (+ m-source a-source)
	     m-source))
	  #+nil(#o21 ;; MUL-Last
		)
	  (#o22 ;; DIV
	   (if (evenp *q-register*)
	       (+ m-source a-source)
	     (- m-source a-source)))
	  (#o23 ;; DIV-First
	   (- m-source a-source))
	  (#o24 ;; DIV-Corr
	   (if (evenp *q-register*)
	       (+ m-source a-source)
	     m-source))
	  (#o31 ;; ADD and M+A+1
	   (let ((result (+ m-source a-source (ldb (byte 1 2) opword))))
	     (setf fixnum-overflow (logand #x01000000
					   (logxor m-source result)
					   (logxor a-source result)))
	     result))
	  (#o34 ;; M+ and friends
	   (+ m-source (ldb (byte 1 2) opword)))
	  (#o36 ;; M-A-1 and SUB
	   (let ((result (logand #xffffffff (- m-source a-source (- 1 (ldb (byte 1 2) opword))))))
	     (setf fixnum-overflow (logand #x01000000
					   (logxor m-source a-source)
					   (logxor m-source result)))
	     result))
	  (#o37 ;; M+M and M+M+1
	   (+ m-source m-source (ldb (byte 1 2) opword)))
	  (t ;; Unsupported or bogus.
	   (format t "Unsupported ALU operation ~A.~%" (ldb (byte 5 3) opword))
	   0)))
  (values alu-result fixnum-overflow))

;; Rotate value left rotation bits.
(defun rotate-value (value rotation)
  (dpb value (byte (- 32 rotation) rotation)
       (ldb (byte rotation (- 32 rotation)) value)))


;; FIXME: This probably belongs in a different file.
;; FIXME: rotation direction?
(defun perform-byte-operation (opword m-source a-source)
  (let* ((rotation (ldb (byte 5 0) opword))
	 (rotation (if (= 1 (ldb (byte 1 16) opword))
		       (logand 31 (- 32 rotation))
		     rotation))
	 (width (ldb (byte 5 5) opword))
	 (mask-rotate (= 1 (ldb (byte 1 18) opword)))
	 (source-rotate (= 1 (ldb (byte 1 17) opword)))
	 (right-mask-index (if mask-rotate rotation 0))
	 (left-mask-index (logand 31 (+ right-mask-index (- width 1))))
	 (right-mask (logxor #xffffffff
			     (1- (dpb 1 (byte 1 right-mask-index) 0))))
	 (left-mask (1- (dpb 1 (byte 1 (1+ left-mask-index)) 0)))
	 (final-mask (logand left-mask right-mask))
	 (rotated-source (if source-rotate (rotate-value m-source rotation) m-source))
	 (result (logior (logand rotated-source final-mask)
			 (logand a-source (logxor #xffffffff final-mask)))))
    result))


(defun store-result (opword result)
  (if (= 1 (ldb (byte 1 31) opword))
      (write-a-memory (ldb (byte 10 19) opword) result)
    (progn
      (write-m-memory (ldb (byte 6 19) opword) result)
      (write-functional-destination (ldb (byte 6 25) opword) result))))

(defun handle-q-control (opword result)
  (case (ldb (byte 2 0) opword)
    (0 ;; nop
     )
    (1 ;; shift-left
     (setf *q-register* (logior (dpb *q-register* (byte 31 1) 0)
				(- 1 (ldb (byte 1 31) result)))))
    (2 ;; shift-right
     (setf *q-register* (logior (ldb (byte 31 1) *q-register*)
				(* #x80000000 (logand 1 result)))))
    (3 ;; load-q
     (setf *q-register* (logand #xffffffff result)))))

(defun handle-output-selector (opword alu-result a-source)
  (case (ldb (byte 3 16) opword)
    (0 ;; A-Bus
     a-source)
    (1 ;; R-Bus
     *q-register*) ;; FIXME: Wrong. Should be rotator output.
    (2 ;; A-Bus (again)
     a-source)
    (3 ;; Normal
     (logand #xffffffff alu-result))
    (4 ;; Leftshift-1
     (dpb alu-result (byte 31 1)
	  (ldb (byte 1 31) *q-register*)))
    (5 ;; Rightshift-1
     ;; Cheap hack for MUL having to shift in sign rather than carry.
     (if (= (logand opword #xc00000000000f8) #x80)
	 (logand #xffffffff (dpb (ldb (byte 31 1) alu-result) (byte 31 0) alu-result))
       (ldb (byte 32 1) alu-result)))
    (6 ;; Sign-Extend
     (if (zerop (logand #x01000000 alu-result))
	 (logand #x00ffffff alu-result)
       (logior #xff000000 alu-result)))
    #+nil(7 ;; Mirror
	  )
    (t ;; Unimplemented
     (format t "Unimplemented output selector.~%")
     alu-result)))

(defun microengine-interpret-alu-instruction (opword)
  (let* ((m-source (read-m-memory (ldb (byte 7 42) opword)))
	 (a-source (read-a-memory (ldb (byte 10 32) opword)))
	 (alu-result-list (multiple-value-list (perform-alu-operation opword m-source a-source)))
	 (alu-result (car alu-result-list))
	 (fixnum-overflow (cadr alu-result-list))
	 (obus-result (handle-output-selector opword alu-result a-source))
	 (result (if (= (logand opword #x10100) #x10100)
		     (logior (logand #xfe000000 a-source)
			     (logand #x01ffffff obus-result))
		   obus-result)))

    ;; FIXME: Fill out the rest of this stuff.

    (if (= 1 (ldb (byte 1 9) opword))
	(write-t-memory (ldb (byte 4 10) opword) alu-result))

    (if (interpret-condition opword m-source a-source alu-result fixnum-overflow)
	(interpret-abj opword))

    (handle-q-control opword alu-result)
    (store-result opword result)))

(defun microengine-interpret-byte-instruction (opword)
  (let* ((m-source (read-m-memory (ldb (byte 7 42) opword)))
	 (a-source (read-a-memory (ldb (byte 10 32) opword)))
	 (result (perform-byte-operation opword m-source a-source)))
    (if (interpret-condition opword m-source a-source)
	(interpret-abj opword))
    (store-result opword result)))


(defun microengine-interpret-jump-instruction (opword)
  (let ((m-source (read-m-memory (ldb (byte 7 42) opword)))
	(a-source (read-a-memory (ldb (byte 10 32) opword)))
	(dest-micro-pc (ldb (byte 14 18) opword)))
    (if (= 1 (ldb (byte 1 17) opword))
	(format t "M-source select (?)~%"))

    (if (= 1 (ldb (byte 1 9) opword))
	(write-i-memory *last-micro-instruction-pointer*
			(dpb a-source (byte 24 32) m-source)))

    (if (= 1 (ldb (byte 1 8) opword))
	(let* ((i-mem (read-i-memory *last-micro-instruction-pointer*))
	       (a-dest (ldb (byte 24 32) i-mem))
	       (m-dest (ldb (byte 32 0) i-mem)))
	  ;; FIXME: Is this the right way round?
	  (if (= 0 (ldb (byte 1 31) opword))
	      (write-m-memory (ldb (byte 6 19) opword) m-dest)
	    (write-a-memory (ldb (byte 10 19) opword) a-dest))))

    (if (interpret-condition opword m-source a-source)
	(progn
	  (setf *inhibit-micro-execution* (= (ldb (byte 1 5) opword) 1))
	  (if (= 1 (ldb (byte 2 6) opword))
	      (write-functional-destination 5
					    (+ *micro-instruction-pointer*
					       (- (ldb (byte 1 5) opword)))))
	  (if (= 2 (ldb (byte 2 6) opword))
	      (setf dest-micro-pc (read-functional-source #o21)))

	  (setf *micro-instruction-pointer* dest-micro-pc))
      (interpret-abj opword))))

(defun microengine-interpret-dispatch-instruction (opword)
  (let* ((m-source (read-m-memory (ldb (byte 7 42) opword)))
	 (dispatch-constant (ldb (byte 10 32) opword))
	 (a-source (read-a-memory dispatch-constant)))
    (setf *dispatch-constant* dispatch-constant)
    (case (ldb (byte 2 8) opword)
      (1 (setf *q-register* (aref *d-memory* (ldb (byte 12 20) opword))))
      (2 (setf (aref *d-memory* (ldb (byte 12 20) opword)) a-source))
      (t (format t "DISPATCH instructions not yet emulated.~%")))))

(defun microengine-interpret-instruction (opword)
  (when *micro-instruction-trace*
    (disassemble-instruction opword))
  (case (ldb (byte 2 54) opword)
    (0 (microengine-interpret-alu-instruction opword))
    (1 (microengine-interpret-byte-instruction opword))
    (2 (microengine-interpret-jump-instruction opword))
    (3 (microengine-interpret-dispatch-instruction opword))))

(defun microengine-step ()
  (let ((opword *next-micro-instruction*))
    (setf *next-micro-instruction* (read-i-memory *micro-instruction-pointer*))
    (when *micro-instruction-trace*
      (format t "L-~A " *last-micro-instruction-pointer*))
    (setf *last-micro-instruction-pointer* *micro-instruction-pointer*)
    (incf *micro-instruction-pointer*)
    (if (not *inhibit-micro-execution*)
	(microengine-interpret-instruction opword)
      (progn
	(when *micro-instruction-trace* (format t "Inhibited.~%"))
	(setf *inhibit-micro-execution* nil))))
  (when *micro-instruction-trace*
    (if (not *inhibit-micro-execution*)
	(progn
	  (format t "L-~A " *last-micro-instruction-pointer*)
	  (disassemble-instruction *next-micro-instruction*))))
  (unless (zerop *memory-busy*)
    (decf *memory-busy*))
  *micro-instruction-pointer*)

(defun microengine-run-to (addr)
  (let ((*micro-instruction-trace* nil))
    (do ()
	;; Not an imem-write, and one of the target address, selftest-fail, or the common error exit.
	((and (/= (logand #xc0000000000200 *next-micro-instruction*) #x80000000000200)
	      (or (= *micro-instruction-pointer* addr)
		  (= *micro-instruction-pointer* 18)
		  (= *micro-instruction-pointer* 40))))
      (microengine-step)

      ;; FIXME: Nasty hack to prevent skipping L-199.
      (when (= *micro-instruction-pointer* 200)
	(setf *inhibit-micro-execution* nil)))
    *micro-instruction-pointer*))

;;; EOF
