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

(in-package :nevermore)

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

(declaim (inline interpret-condition))
(defun interpret-condition (opword-m opword-a m-source a-source &optional (alu-result 0) (fixnum-overflow 0))
  (declare (type (unsigned-byte 32) opword-m m-source a-source alu-result)
	   (type (unsigned-byte 24) opword-a)
	   (fixnum fixnum-overflow))
  (eq (= 0 (ldb (byte 1 15) opword-m))
      (if (= 0 (ldb (byte 1 14) opword-m))
	  (case (ldb (byte 4 10) opword-m)
	    (0 ;; bit-set
	     (let ((rotation (ldb (byte 5 0) opword-m)))
	       (= 1 (if (= 1 (ldb (byte 1 16) opword-m))
			(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 (and (= (logand opword-m #xf8) #xe0)
		      (zerop (ldb (byte 2 22) opword-a)))
		 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 (aref *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) m-source)))))

(defun interpret-abj (opword-a)
  (declare (type (unsigned-byte 24) opword-a))
  (case (ldb (byte 3 19) opword-a)
    (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.~%"))))

(declaim (inline +-32bit-3))
(defun +-32bit-3 (a b c)
  (declare (type (unsigned-byte 32) a b c))
  (let* ((result-low (+ (ldb (byte 16 0) a)
			(ldb (byte 16 0) b)
			(ldb (byte 16 0) c)))
	 (result-high (+ (ldb (byte 16 16) a)
			 (ldb (byte 16 16) b)
			 (ldb (byte 16 16) c)
			 (ldb (byte 1 16) result-low))))
    (dpb result-high (byte 16 16) result-low)))

(declaim (inline --32bit-3))
(defun --32bit-3 (a b c)
  (declare (type (unsigned-byte 32) a b c))
  (let* ((result-low (- (ldb (byte 16 0) a)
			(ldb (byte 16 0) b)
			(ldb (byte 16 0) c)))
	 (result-high (- (ldb (byte 16 16) a)
			 (ldb (byte 16 16) b)
			 (ldb (byte 16 16) c)
			 (ldb (byte 1 16) result-low))))
    (dpb result-high (byte 16 16) (logand #xffff result-low))))

;; FIXME: Some cleanup to perform in here.
(declaim (inline perform-alu-operation))
(defun perform-alu-operation (opword-m m-source a-source &aux (fixnum-overflow 0) (alu-carry 0))
  (declare (type (unsigned-byte 32) opword-m m-source a-source)
	   (fixnum fixnum-overflow alu-carry))
  (let ((alu-result
	 (case (ldb (byte 5 3) opword-m)
	   (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
	    (let ((result (if (oddp (aref *q-register*))
			      #+sbcl(logand #xffffffff (+ m-source a-source))
			      #-sbcl(+-32bit-3 m-source a-source 0)
			      m-source)))
	      ;; Special case, carry = sign (otherwise output-selector-rightshift-1 doesn't work).
	      (setf alu-carry (ldb (byte 1 31) result))
	      result))
	   #+nil(#o21 ;; MUL-Last
		 )
	   (#o22 ;; DIV
	    (if (evenp (aref *q-register*))
		#+sbcl(logand #xffffffff (+ m-source a-source))
		#-sbcl(+-32bit-3 m-source a-source 0)
		#+sbcl(logand #xffffffff (- m-source a-source))
		#-sbcl(--32bit-3 m-source a-source 0)))
	   (#o23 ;; DIV-First
	    #+sbcl(logand #xffffffff (- m-source a-source))
	    #-sbcl(--32bit-3 m-source a-source 0))
	   (#o24 ;; DIV-Corr
	    (if (evenp (aref *q-register*))
		#+sbcl(+ m-source a-source)
		#-sbcl(+-32bit-3 m-source a-source 0)
		m-source))
	   (#o31 ;; ADD and M+A+1
	    (let #+sbcl ((result (logand #xffffffff (+ m-source a-source (ldb (byte 1 2) opword-m)))))
		 #-sbcl ((result (+-32bit-3 m-source a-source (ldb (byte 1 2) opword-m))))
		 (setf fixnum-overflow (logand #x01000000
					       (logxor m-source result)
					       (logxor a-source result)))
		 (setf alu-carry (if (< result m-source) 1 0))
		 result))
	   (#o34 ;; M+ and friends
	    #+sbcl(logand #xffffffff (+ m-source (ldb (byte 1 2) opword-m)))
	    #-sbcl(let ((result (+-32bit-3 m-source (ldb (byte 1 2) opword-m) 0)))
		    (setf alu-carry (if (< result m-source) 1 0))
		    result))
	   (#o36 ;; M-A-1 and SUB
	    (let* #-sbcl((result (--32bit-3 m-source a-source (- 1 (ldb (byte 1 2) opword-m)))))
		  #+sbcl((result (logand #xffffffff (- m-source a-source (- 1 (ldb (byte 1 2) opword-m))))))
		  (setf fixnum-overflow (logand #x01000000
						(logxor m-source a-source)
						(logxor m-source result)))
		  (setf alu-carry (if (< result m-source) 1 0))
		  result))
	   (#o37 ;; M+M and M+M+1
	    #+sbcl(logand #xffffffff (+ m-source m-source (ldb (byte 1 2) opword-m)))
	    #-sbcl(+-32bit-3 m-source m-source (ldb (byte 1 2) opword-m)))
	   (t ;; Unsupported or bogus.
	    (format t "Unsupported ALU operation ~A.~%" (ldb (byte 5 3) opword-m))
	    0))))
    (values alu-result fixnum-overflow alu-carry)))

#|
;; Rotate value left rotation bits.
(declaim (inline rotate-value))
(defun rotate-value (value rotation)
  (declare (type (integer 0 31) rotation)
	   (type (unsigned-byte 32) value))
  (dpb value (byte (- 32 rotation) rotation)
       (ldb (byte rotation (- 32 rotation)) value)))

;; Implementation of rotate-right by Raymond Toy.
(defun rotate-right (v n)
  (declare (type (integer 0 31) n)
	   (type (unsigned-byte 32) v)
	   (optimize (speed 3) (safety 0)))
  (let ((low (ldb (byte n 0) v)))
    (logior (ash v (- n)) (the (unsigned-byte 32) (ash low (- 32 n))))))
|#

(declaim (inline rotate-left))
(defun rotate-left (v n)
  (declare (type (integer 0 31) n)
	   (type (unsigned-byte 32) v)
	   (optimize (speed 3) (safety 0)))
  (let ((low (ldb (byte (- 32 n) 0) v)))
    (logior (ash v (- (- 32 n))) (the (unsigned-byte 32) (ash low n)))))

;; %make-ones by Raymond Toy.
(declaim (inline %make-ones))
(defun %make-ones (len)
  (declare (type (integer 1 32) len)
	   (optimize (speed 3) (safety 0)))
  (if (< len 32)
      (1- (ash 1 len))
      #.(1- (ash 1 32))))

(declaim (inline perform-byte-operation))
(defun perform-byte-operation (opword-m m-source a-source)
  (declare (type (unsigned-byte 32) opword-m m-source a-source))
  (let* ((rotation (ldb (byte 5 0) opword-m))
	 (rotation (if (= 1 (ldb (byte 1 16) opword-m))
		       (logand 31 (- 32 rotation))
		     rotation))
	 (width (ldb (byte 5 5) opword-m))
	 (mask-rotate (= 1 (ldb (byte 1 18) opword-m)))
	 (source-rotate (= 1 (ldb (byte 1 17) opword-m)))
	 (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 (%make-ones (1+ left-mask-index)) #+nil(1- (dpb 1 (byte 1 (1+ left-mask-index)) 0)))
	 (final-mask (logand left-mask right-mask))
	 (rotated-source (if source-rotate (rotate-left m-source rotation) m-source))
	 (result (logior (logand rotated-source final-mask)
			 (logand a-source (logxor #xffffffff final-mask)))))
    (declare (type (unsigned-byte 32) right-mask left-mask final-mask rotated-source result)
	     (type (integer 0 31) rotation width right-mask-index left-mask-index))
    result))


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

(declaim (inline handle-q-control))
(defun handle-q-control (opword-m result)
  (declare (type (unsigned-byte 32) opword-m result))
  (case (ldb (byte 2 0) opword-m)
    (0 ;; nop
     )
    (1 ;; shift-left
     (setf (aref *q-register*) (logior (dpb (aref *q-register*) (byte 31 1) 0)
				(- 1 (ldb (byte 1 31) result)))))
    (2 ;; shift-right
     (setf (aref *q-register*) (logior (ldb (byte 31 1) (aref *q-register*))
				(* #x80000000 (logand 1 result)))))
    (3 ;; load-q
     (setf (aref *q-register*) result)))
  (values))

(declaim (inline handle-output-selector))
(defun handle-output-selector (opword-m alu-result a-source alu-carry)
  (declare (type (unsigned-byte 32) opword-m a-source alu-result)
	   (type (integer 0 1) alu-carry))
  (case (ldb (byte 3 16) opword-m)
    (0 ;; A-Bus
     a-source)
    (1 ;; R-Bus
     (aref *q-register*)) ;; FIXME: Wrong. Should be rotator output.
    (2 ;; A-Bus (again)
     a-source)
    (3 ;; Normal
     alu-result)
    (4 ;; Leftshift-1
     (dpb alu-result (byte 31 1)
	  (ldb (byte 1 31) (aref *q-register*))))
    (5 ;; Rightshift-1
     (logior (ash alu-carry 31) (ldb (byte 31 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)))

(declaim (inline microengine-interpret-alu-instruction))
(defun microengine-interpret-alu-instruction (opword-m opword-a)
  (declare (type (unsigned-byte 24) opword-a)
	   (type (unsigned-byte 32) opword-m))
  (let ((m-source (read-m-memory (ldb (byte 7 10) opword-a)))
	(a-source (read-a-memory (ldb (byte 10 0) opword-a))))
    (multiple-value-bind (alu-result fixnum-overflow alu-carry)
	(perform-alu-operation opword-m m-source a-source)
      (declare (type (unsigned-byte 32) alu-result))
      (let* ((obus-result (handle-output-selector opword-m alu-result a-source alu-carry))
	     (result (if (= (logand opword-m #x10100) #x10100)
			 (logior (logand #xfe000000 a-source)
				 (logand #x01ffffff obus-result))
			 obus-result)))
	(declare (type (unsigned-byte 32) obus-result))
	
	;; FIXME: Fill out the rest of this stuff.
	
	(if (= 1 (ldb (byte 1 9) opword-m))
	    (write-t-memory (ldb (byte 4 10) opword-m) alu-result))
	
	(if (interpret-condition opword-m opword-a m-source a-source alu-result fixnum-overflow)
	    (interpret-abj opword-a))
	
	(handle-q-control opword-m alu-result)
	(store-result opword-m result))))
  (values))

(declaim (inline microengine-interpret-byte-instruction))
(defun microengine-interpret-byte-instruction (opword-m opword-a)
  (declare (type (unsigned-byte 24) opword-a)
	   (type (unsigned-byte 32) opword-m))
  (let* ((m-source (read-m-memory (ldb (byte 7 10) opword-a)))
	 (a-source (read-a-memory (ldb (byte 10 0) opword-a)))
	 (result (perform-byte-operation opword-m m-source a-source)))
    (if (interpret-condition opword-m opword-a m-source a-source)
	(interpret-abj opword-a))
    (store-result opword-m result))
  (values))

(declaim (inline microengine-interpret-jump-instruction))
(defun microengine-interpret-jump-instruction (opword-m opword-a)
  (declare (type (unsigned-byte 24) opword-a)
	   (type (unsigned-byte 32) opword-m))
  (let ((m-source (read-m-memory (ldb (byte 7 10) opword-a)))
	(a-source (read-a-memory (ldb (byte 10 0) opword-a)))
	(dest-micro-pc (ldb (byte 14 18) opword-m)))
    (if (= 1 (ldb (byte 1 17) opword-m))
	(format t "M-source select (?)~%"))
    
    (when (= 1 (ldb (byte 1 9) opword-m))
      (write-i-memory-m *last-micro-instruction-pointer* m-source)
      (write-i-memory-a *last-micro-instruction-pointer* (ldb (byte 24 0) a-source)))

    (if (= 1 (ldb (byte 1 8) opword-m))
	(if (= 0 (ldb (byte 1 31) opword-m))
	    (write-m-memory (ldb (byte 6 19) opword-m) (read-i-memory-m *last-micro-instruction-pointer*))
	    (write-a-memory (ldb (byte 10 19) opword-m) (read-i-memory-a *last-micro-instruction-pointer*))))
    
    (if (interpret-condition opword-m opword-a m-source a-source)
	(progn
	  (setf *inhibit-micro-execution* (= (ldb (byte 1 5) opword-m) 1))
	  (if (= 1 (ldb (byte 2 6) opword-m))
	      (write-functional-destination 5
					    (+ *micro-instruction-pointer*
					       (- (ldb (byte 1 5) opword-m)))))
	  (if (= 2 (ldb (byte 2 6) opword-m))
	      (setf dest-micro-pc (read-functional-source #o21)))
	  
	  (setf *micro-instruction-pointer* (logand #xfffff dest-micro-pc)))
	(interpret-abj opword-a)))
  (values))

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

(declaim (inline microengine-interpret-instruction))
(defun microengine-interpret-instruction (opword-m opword-a)
  (declare (type (unsigned-byte 24) opword-a)
	   (type (unsigned-byte 32) opword-m))
  (when *micro-instruction-trace*
    (disassemble-split-instruction opword-a opword-m))
  (case (ldb (byte 2 22) opword-a)
    (0 (microengine-interpret-alu-instruction opword-m opword-a))
    (1 (microengine-interpret-byte-instruction opword-m opword-a))
    (2 (microengine-interpret-jump-instruction opword-m opword-a))
    (3 (microengine-interpret-dispatch-instruction opword-m opword-a)))
  (values))

(defun microengine-step ()
  (let ((opword-a *next-micro-instruction-a*)
	(opword-m (aref *next-micro-instruction-m*)))
    (setf *next-micro-instruction-a* (logand #xffffff (read-i-memory-a *micro-instruction-pointer*)))
    (setf (aref *next-micro-instruction-m*) (read-i-memory-m *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-m opword-a)
      (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-split-instruction *next-micro-instruction-a* (aref *next-micro-instruction-m*)))))
  (unless (zerop *memory-busy*)
    (decf *memory-busy*))
  *micro-instruction-pointer*)

(defun microengine-run-to (addr)
  (declare (fixnum 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 (or (= *micro-instruction-pointer* addr)
		  (= *micro-instruction-pointer* 18)
		  (= *micro-instruction-pointer* 40))
	      (not
	       (and
		(= (logand #xc00000 *next-micro-instruction-a*) #x800000)
		(= (logand #x00000200 (aref *next-micro-instruction-m*)) #x00000200)))))
      (microengine-step)

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

;;; EOF
