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

(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
	     (not (= m-source a-source)))
	    #+nil(4 ;; page-fault
	     )
	    #+nil(5 ;; page-fault-or-interrupt
	     )
	    #+nil(6 ;; page-fault-or-interrupt-or-sequence-break
	     )
	    (7 ;; true
	     t)
	    (8 ;; tag-not-equal
	     (/= (ldb (byte 5 25) m-source)
		 (ldb (byte 5 25) a-source)))
	    (9 ;; not-memory-busy
	     t)
	    (10 ;; q0
	     (oddp *q-register*))
	    (11 ;; nu-bus-error
	     nil)
	    (12 ;; not-fixnum-overflow
	     (= 0 fixnum-overflow))
	    (13 ;; boxed-sign-bit
	     (= #x01000000 (logand #x01000000 alu-result)))
	    #+nil(14 ;; no-interrupt
	     )
	    (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)
  (case (ldb (byte 5 3) opword)
    (0 ;; SETZ
     0)
    (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
     (+ m-source a-source (ldb (byte 1 2) opword)))
    (#o34 ;; M+ and friends
     (+ m-source (ldb (byte 1 2) opword)))
    (#o36 ;; M-A-1 and SUB
     (logand #xffffffff (- m-source a-source (- 1 (ldb (byte 1 2) opword)))))
    (#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.~%")
     0)))

;; 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.
    (3 ;; Normal
     (logand #xffffffff alu-result))
    (4 ;; Leftshift-1
     (dpb alu-result (byte 31 1)
	  (ldb (byte 1 31) *q-register*)))
    (5 ;; Rightshift-1
     (ldb (byte 32 1) alu-result))
    (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 (perform-alu-operation opword m-source a-source))
	 (fixnum-overflow 0) ;; FIXME: Should be 2nd value from perform-alu-operation
	 (result (handle-output-selector opword alu-result a-source)))

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

    #+nil(if (interpret-condition opword (logand #xffffffff alu-result)
			     (logand #xffffffff
				     (- a-source (ldb (byte 1 2) opword))))
	(interpret-abj opword))

    (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)))
    (store-result opword result)
    (if (interpret-condition opword m-source a-source)
	(interpret-abj opword))))


(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*))))
  *micro-instruction-pointer*)

(defun microengine-run-to (addr)
  (let ((*micro-instruction-trace* nil))
    (do ()
	((or (= *micro-instruction-pointer* addr)
	     (= *micro-instruction-pointer* 18)))
      (microengine-step)

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

;;; EOF
