;;; -*- Mode:LISP; Package:SIM; Readtable:CL; Base:10 -*-

(defsubst read-register (name)
  (micro:%read-a-mem (get name 'micro:a-mem-adr)))

(defsubst write-register (name val)
  (let ((adr (get name 'micro:a-mem-adr)))
    (when (not (fixp adr))
      (ferror nil "bad address ~s" name))
    (micro:%write-a-mem adr val)))

(defsetf read-register write-register)

(defconst *main-memory-pages* 1024.)
(defvar *main-memory-end*)
(defconst *pages-of-frames* 16.)
(defvar *frames-end*)

(defvar *main-memory-array* (si:make-wireable-array (+ *pages-of-frames* 1) 'art-32b nil))
(defvar *frames-array* (si:make-wireable-array (* 4 *main-memory-pages*) 'art-32b nil))

(defun make-structures ()
  ;;frames + functional registers
  (write-register 'micro:a-sim-frames (+ (si:%pointer-unsigned (%pointer *frames-array*))
					 (si:array-data-offset *frames-array*)))
  (setq *frames-end* (+ (si:%pointer-unsigned (%pointer *frames-array*))
			(si:array-data-offset *frames-array*)
			(array-length *frames-array*)))
  (write-register 'micro:a-sim-main-memory (+ (si:%pointer-unsigned (%pointer *main-memory-array*))
					      (si:array-data-offset *main-memory-array*)))
  (setq *main-memory-end* (+ (si:%pointer-unsigned (%pointer *main-memory-array*))
			     (si:array-data-offset *main-memory-array*)
			     (array-length *main-memory-array*)))
  )

(defun reset-registers ()
  (write-register 'micro:m-sim-src-1-ptr 0)
  (write-register 'micro:m-sim-src-2-ptr 0)
  (write-register 'micro:m-sim-dest-ptr 0)
  (write-register 'micro:m-sim-last-src-1 0)
  (write-register 'micro:m-sim-last-aluf 0)
  (write-register 'micro:m-sim-inst-0 0)
  (write-register 'micro:m-sim-inst-1 0)
  (write-register 'micro:m-sim-inst-2 0)
  (write-register 'micro:m-open-frame 0)
  (write-register 'micro:m-active-frame 0)
  (write-register 'micro:m-return-frame 0)

 (write-register 'micro:a-sim-pc 0)
 (write-register 'micro:a-sim-next-pc 0)
 (write-register 'micro:a-sim-noop-next-bit 0)
 (write-register 'micro:a-sim-last-src-2 0)
 (write-register 'micro:a-sim-last-result 0)

 (write-register 'micro:a-sim-src-ptrs-valid 0)
 )

(defun %p-contents-as-bignum (adr)
  (check-type adr integer)
  (dpb (%p-ldb (byte 16. 16.) adr)
       (byte 16. 16.)
       (%p-ldb (byte 16. 0) adr)))

(defun %p-store-contents-as-bignum (adr val)
  (check-type adr integer)
  (%p-dpb (ldb (byte 16. 0) val) (byte 16. 0) adr)
  (%p-dpb (ldb (byte 16. 16.) val) (byte 16. 16.) adr)
  val)

(defsetf %p-contents-as-bignum %p-store-contents-as-bignum)

(defflavor ucode-sim
	 (
	  )
	 ()
  :settable-instance-variables)

(defmethod (ucode-sim :after :init) (ignore)
  (make-structures)
  (send self :reset))

(defmethod (ucode-sim :reset) ()
  (reset-registers))

(defmethod (ucode-sim :reset-and-clear) ()
  (reset-registers)
  (let ((main-memory-base (read-register 'micro:a-sim-main-memory))
	(frames-base (read-register 'micro:a-sim-frames)))
    (setf (%p-contents-as-bignum main-memory-base) 0)
    (%blt main-memory-base (1+ main-memory-base) (- *main-memory-end* main-memory-base 1) 1)
    (setf (%p-contents-as-bignum frames-base) 0)
    (%blt frames-base (1+ frames-base) (- *frames-end* frames-base 1) 1)))

(defmethod (ucode-sim :read-main-mem) (adr)
  (when (or (< adr 0)
	    (>= adr *main-memory-end*))
    (ferror nil "bad adr"))
  (let* ((real-adr (si:%make-pointer-unsigned (+ (* 4 adr) (read-register 'micro:a-sim-main-memory))))
	 (real-adr+1 (+ real-adr 1))
	 (real-adr+2 (+ real-adr 2)))
    (+ (%p-ldb (byte 16. 0) real-adr)
       (dpb (%p-ldb (byte 16. 16.) real-adr) (byte 16. 16.) 0)
       (dpb (%p-ldb (byte 16. 0) real-adr+1) (byte 16. 32.) 0)
       (dpb (%p-ldb (byte 16. 16.) real-adr+1) (byte 16. 48.) 0)
       (dpb (%p-ldb (byte 16. 0) real-adr+2) (byte 16. 64.) 0)
       (dpb (%p-ldb (byte 16. 16.) real-adr+2) (byte 16. 80.) 0))))

(defmethod (ucode-sim :write-main-mem) (adr val)
  (when (or (< adr 0)
	    (>= adr *main-memory-end*))
    (ferror nil "bad adr"))
  (let* ((real-adr (si:%make-pointer-unsigned (+ (* 4 adr) (read-register 'micro:a-sim-main-memory))))
	 (real-adr+1 (+ real-adr 1))
	 (real-adr+2 (+ real-adr 2)))
    (%p-dpb (ldb (byte 16. 0) val) (byte 16. 0) real-adr)
    (%p-dpb (ldb (byte 16. 16.) val) (byte 16. 16.) real-adr)
    (%p-dpb (ldb (byte 16. 32.) val) (byte 16. 0) real-adr+1)
    (%p-dpb (ldb (byte 16. 48.) val) (byte 16. 16.) real-adr+1)
    (%p-dpb (ldb (byte 16. 64.) val) (byte 16. 0) real-adr+2)
    (%p-dpb (ldb (byte 16. 80.) val) (byte 16. 16.) real-adr+2))
  val)

(defmethod (ucode-sim :read-frame-mem) (adr)
  (when (or (< adr 0)
	    (>= adr (* 256. 16.)))
    (ferror nil "bad adr"))
  (let ((frame-base (read-register 'micro:a-sim-frames)))
    (%p-contents-as-bignum (+ frame-base adr))))

(defmethod (ucode-sim :write-frame-mem) (adr val)
  (when (or (< adr 0)
	    (>= adr (* 256. 16.)))
    (ferror nil "bad adr"))
  (let ((frame-base (read-register 'micro:a-sim-frames)))
    (setf (%p-contents-as-bignum (+ frame-base adr)) val))
  val)

(defmethod (ucode-sim :read-open-base) ()
  (read-register 'micro:m-sim-open-frame))

(defmethod (ucode-sim :write-open-base) (val)
  (write-register 'micro:m-sim-open-frame val))

(defmethod (ucode-sim :read-open) (adr)
  (when (or (< adr 0)
	    (>= adr 16.))
    (ferror nil "bad adr"))
  (%p-contents-as-bignum (+ (send self :read-open-base) adr)))

(defmethod (ucode-sim :read-open) (adr val)
  (when (or (< adr 0)
	    (>= adr 16.))
    (ferror nil "bad adr"))
  (setf (%p-contents-as-bignum (+ (send self :read-open-base) adr)) val))

(defmethod (ucode-sim :read-active-base) ()
  (read-register 'micro:m-sim-active-frame))

(defmethod (ucode-sim :write-active-base) (val)
  (write-register 'micro:m-sim-active-frame val))

(defmethod (ucode-sim :read-active) (adr)
  (when (or (< adr 0)
	    (>= adr 16.))
    (ferror nil "bad adr"))
  (%p-contents-as-bignum (+ (send self :read-active-base) adr)))

(defmethod (ucode-sim :read-active) (adr val)
  (when (or (< adr 0)
	    (>= adr 16.))
    (ferror nil "bad adr"))
  (setf (%p-contents-as-bignum (+ (send self :read-active-base) adr)) val))

(defmethod (ucode-sim :read-return-base) ()
  (read-register 'micro:m-sim-return-frame))

(defmethod (ucode-sim :write-return-base) (val)
  (write-register 'micro:m-sim-return-frame val))

(defmethod (ucode-sim :read-return) (adr)
  (when (or (< adr 0)
	    (>= adr 16.))
    (ferror nil "bad adr"))
  (%p-contents-as-bignum (+ (send self :read-return-base) adr)))

(defmethod (ucode-sim :read-return) (adr val)
  (when (or (< adr 0)
	    (>= adr 16.))
    (ferror nil "bad adr"))
  (setf (%p-contents-as-bignum (+ (send self :read-return-base) adr)) val))

(defmethod (ucode-sim :read-pc) ()
  (read-register 'micro:a-sim-pc))

(defmethod (ucode-sim :write-pc) (val)
  (setf (read-register 'micro:a-sim-pc) val))

(defmethod (ucode-sim :read-next-pc) ()
  (read-register 'micro:a-sim-next-pc))

(defmethod (ucode-sim :write-next-pc) (val)
  (setf (read-register 'micro:a-sim-next-pc) val))

(defmethod (ucode-sim :read-noop-next-bit) ()
  (read-register 'micro:a-sim-noop-next-bit))

(defmethod (ucode-sim :write-noop-next-bit) (val)
  (setf (read-register 'micro:a-sim-noop-next-bit) val))